diff --git a/LIBTOOLS/LIBTOOLS_CVS.TXT b/LIBTOOLS/LIBTOOLS_CVS.TXT
new file mode 100644
index 0000000000000000000000000000000000000000..3a48705dc788ff844b18de81a717729c9b7a17a6
--- /dev/null
+++ b/LIBTOOLS/LIBTOOLS_CVS.TXT
@@ -0,0 +1,87 @@
+Libtools sources may be retrieved with the following commands.
+Choose a working directory to install the sources, then
+
+- To get the latest stable revision :
+
+ cvs co libtools
+
+- To get the latest development release :
+
+ cvs co -r LIBTOOLS-DEVEL-branch libtools
+
+- To get the latest CNRM development release :
+
+ cvs co -r LIBTOOLS-CNRM-branch libtools
+
+- to get the LIBTOOLS-DEVEL-1-0-2 release :
+
+ cvs co -r LIBTOOLS-DEVEL-1-0-2 libtools
+
+
+
+
+Tags that may appear in this repository are explained below :
+
+ MAIN
+ ====
+ | LIBTOOLS-DEVEL-branch LIBTOOLS-CNRM-branch
+ | ===================== ====================
+ | | |
+ | | |
+ LIBTOOLS-1-0-0 ------------------+---------------------------------+
+ | | |
+ | | |
+ | | |
+ | DEV-SURC-7-4-1 |
+ | | |
+ | | |
+ | DEV-SURC-7-4-1-1 |
+ | | |
+ | | |
+ | DEV-SURC-7-4-1-2 |
+ | | |
+ | | |
+ | LIBTOOLS-DEVEL-1-0-1 |
+ | | |
+ | | |
+ | | |
+ | LIBTOOLS-DEVEL-1-0-2 merge |
+ | merged_from_DEVEL_to_CNRM ---------> LIBTOOLS-CNRM-1-0-2
+ | | |
+ . . .
+ . . .
+ . . .
+
+
+
+Branch TAGS
+===========
+
+ MAIN : this branch contains official stable LibTools sources.
+
+ LIBTOOLS-DEVEL-branch : this branch contains sources currently under
+ development that sooner or later are merged to
+ main branch.
+
+ LIBTOOLS-CNRM-branch : this branch is reserved to CNRM development/tests.
+ Sources may be merged to MAIN or LIBTOOLS-DEVEL-branch
+ branch.
+
+
+Release TAGS
+============
+
+LIBTOOLS-x-y-z : this tag is applied to all sources of a stable LIBTOOLS release
+ on the MAIN branch.
+
+LIBTOOLS-DEVEL-x-y-z : this tag is applied to all sources of a development LIBTOOLS
+ release on the LIBTOOLS-DEVEL-branch development branch.
+
+DEV-SURC-x-y... : this tag is only applied to the lib/SURCOUCHE sources on the
+ LIBTOOLS-DEVEL-branch development branch.
+
+LIBTOOLS-CNRM-x-y... : this tag is applied to all sources of a development/test LIBTOOLS
+ release on the LIBTOOLS-CNRM-branch development branch.
+
+Note that all sources from LIBTOOLS-DEVEL-1-0-2 and LIBTOOLS-CNRM-1-0-2 release
+are strictly identical (except maybe for the README.TXT file).
diff --git a/LIBTOOLS/README.TXT b/LIBTOOLS/README.TXT
new file mode 100644
index 0000000000000000000000000000000000000000..921fe6e83b6679e591ad49ecf8dd043e864aefbe
--- /dev/null
+++ b/LIBTOOLS/README.TXT
@@ -0,0 +1,54 @@
+Release tag : LIBTOOLS-CNRM-4-8-a on September 24 2009
+
+Welcome to MESONH Libtools...
+
+Branch : LIBTOOLS-CNRM-branch
+TAG : $Name$
+
+
+Support for gfortran ver > 4.3 and NCL/NCAR 5.1.1
+with :
+
+export ARCH=LXgfortran
+
+Documentation can be found in 'readme' directory.
+
+LaTeX sources of documentation can be found in 'readme/LATEX'
+directory : type make in the LATEX directory to build the
+postscript documentation file : tools.ps
+
+
+How to compile ?
+
+ cd lib
+ export ARCH=LXgfortran
+ make COMPRESS
+ make NEWLFI
+ make SURCOUCHE
+ make MPIvide
+ make RAD2
+ make vis5d
+ cd gribex_1302b
+ export ARCH=linux
+ export CNAME=_gfortran
+ export A64=A64
+ make
+
+ cd ../../tools
+ cd diachro
+ export ARCH=LXgfortran
+ export MNH_LIBTOOLS= absolute path for libtools directory
+ make
+# The executables are in the directory LXgfortran_64 conv2dia and LXgfortran_32 for the others
+
+
+ cd ../fmmore
+ make
+
+# The executable is in the directory LXgfortran_64
+
+ cd ../lfiz
+ make
+
+# The executables ate in the directory LXgfortran
+
diff --git a/LIBTOOLS/conf/config.AIX32 b/LIBTOOLS/conf/config.AIX32
new file mode 100644
index 0000000000000000000000000000000000000000..583e43690be307516b5705fa145b5aa796ec8ef7
--- /dev/null
+++ b/LIBTOOLS/conf/config.AIX32
@@ -0,0 +1,8 @@
+CPP = cc -C -E
+AR = ar
+F77 = xlf90 -q32 -qextname
+F90 = xlf90 -q32 -qextname
+F77FLAGS = -qfixed -O3 -qstrict
+F90FLAGS = -qfree=f90 -qsuffix=f=f90 -O3 -qstrict
+CPPFLAGS =
+LDFLAGS = -bloadmap:map_ld
diff --git a/LIBTOOLS/conf/config.AIX64 b/LIBTOOLS/conf/config.AIX64
new file mode 100644
index 0000000000000000000000000000000000000000..ba8c8c80bb33660aade9298d04922baa42ebb3dd
--- /dev/null
+++ b/LIBTOOLS/conf/config.AIX64
@@ -0,0 +1,9 @@
+CPP = cc -C -E
+AR = ar -X64
+F77 = xlf90_r -qarch=pwr4 -qzerosize -qautodbl=dbl4 -qmaxmem=-1
+F90 = xlf90_r -qarch=pwr4 -qzerosize -qautodbl=dbl4 -qmaxmem=-1
+F77FLAGS = -q64 -qfixed -O3 -qstrict
+F90FLAGS = -q64 -qfree=f90 -qsuffix=f=f90 -O3 -qstrict
+CFLAGS = -q64
+CPPFLAGS =
+LDFLAGS = -q64 -bloadmap:map_ld
diff --git a/LIBTOOLS/conf/config.HPNAGf95 b/LIBTOOLS/conf/config.HPNAGf95
new file mode 100644
index 0000000000000000000000000000000000000000..ba20c060a52586af0776607920abb2ee4de4d1c6
--- /dev/null
+++ b/LIBTOOLS/conf/config.HPNAGf95
@@ -0,0 +1,10 @@
+CPP = /usr/lib/cpp -P -C
+AR = ar
+CC = cc
+F77 = f95
+F90 = f95
+
+F90FLAGS = -f77 -kind=byte -w -mismatch_all
+F77FLAGS = -f77 -kind=byte -w -mismatch_all -dusty
+LDFLAGS = -unsharedf95
+
diff --git a/LIBTOOLS/conf/config.HPf90 b/LIBTOOLS/conf/config.HPf90
new file mode 100644
index 0000000000000000000000000000000000000000..24c2342f13bd991ce2b7207d1bd5adcb8d2c193e
--- /dev/null
+++ b/LIBTOOLS/conf/config.HPf90
@@ -0,0 +1,10 @@
+CPP = /usr/lib/cpp -P -C
+AR = ar
+F90 = f90 +DAportable
+F77 = f90 +DAportable
+
+CPPFLAGS = -DHP -DF90HP
+F90FLAGS = -w
+F77FLAGS = -w
+
+
diff --git a/LIBTOOLS/conf/config.LXNAGf95 b/LIBTOOLS/conf/config.LXNAGf95
new file mode 100644
index 0000000000000000000000000000000000000000..135222408c5bf484dd48f0712f0cbd545403d77d
--- /dev/null
+++ b/LIBTOOLS/conf/config.LXNAGf95
@@ -0,0 +1,12 @@
+CPP = cpp -P -traditional -Wcomment
+AR = ar
+CC = cc
+F77 = f95
+F90 = f95
+
+CPPFLAGS = -DNAGf95
+#F90FLAGS = -kind=byte -w -C=all -gline
+F90FLAGS = -kind=byte -w -mismatch_all -gline
+F77FLAGS = -kind=byte -w -mismatch_all -dusty
+LDFLAGS = -unsharedf95
+
diff --git a/LIBTOOLS/conf/config.LXg95 b/LIBTOOLS/conf/config.LXg95
new file mode 100644
index 0000000000000000000000000000000000000000..2ab5c7e0080f9d7e84b4cc87643c6c42e38b31c2
--- /dev/null
+++ b/LIBTOOLS/conf/config.LXg95
@@ -0,0 +1,12 @@
+CPP = cpp -P -traditional -Wcomment
+AR = ar
+CC = cc
+F77 = g95
+F90 = g95
+
+CPPFLAGS = -DG95
+F90FLAGS = -w -fno-second-underscore
+F77FLAGS = -w -fno-second-underscore
+
+LDFLAGS =
+
diff --git a/LIBTOOLS/conf/config.LXgfortran b/LIBTOOLS/conf/config.LXgfortran
new file mode 100644
index 0000000000000000000000000000000000000000..d2b0fa11ed90ab6772573ee4e0501052a21e593f
--- /dev/null
+++ b/LIBTOOLS/conf/config.LXgfortran
@@ -0,0 +1,12 @@
+CPP = cpp -P -traditional -Wcomment
+AR = ar
+CC = cc
+F77 = gfortran
+F90 = gfortran
+
+CPPFLAGS = -DGFORTRAN
+F90FLAGS = -w -fno-second-underscore
+F77FLAGS = -w -fno-second-underscore
+
+LDFLAGS =
+
diff --git a/LIBTOOLS/conf/config.LXifort b/LIBTOOLS/conf/config.LXifort
new file mode 100644
index 0000000000000000000000000000000000000000..1c70b0f3a5cecd292255e0a62a19a0c553a5f69e
--- /dev/null
+++ b/LIBTOOLS/conf/config.LXifort
@@ -0,0 +1,12 @@
+CPP = cpp -P -traditional -Wcomment
+AR = ar
+CC = cc
+F77 = ifort
+F90 = ifort
+
+CPPFLAGS =
+F90FLAGS =
+F77FLAGS =
+
+LDFLAGS =
+
diff --git a/LIBTOOLS/conf/config.LXpgf90 b/LIBTOOLS/conf/config.LXpgf90
new file mode 100644
index 0000000000000000000000000000000000000000..cd9029a4e0e679345a62b4bc009007e553d57f16
--- /dev/null
+++ b/LIBTOOLS/conf/config.LXpgf90
@@ -0,0 +1,11 @@
+CPP = cpp -P -traditional -Wcomment
+AR = ar
+CC = cc
+F77 = pgf90
+F90 = pgf90
+
+CPPFLAGS = -Dpgf
+F90FLAGS = -w
+F77FLAGS = -w
+LDFLAGS = -Wl,-noinhibit-exec -Wl,-warn-once
+
diff --git a/LIBTOOLS/conf/config.SGI32 b/LIBTOOLS/conf/config.SGI32
new file mode 100644
index 0000000000000000000000000000000000000000..fd5dfd0bcf43a0b884ba039a3b467d698b5c4842
--- /dev/null
+++ b/LIBTOOLS/conf/config.SGI32
@@ -0,0 +1,12 @@
+CPP = /usr/lib/cpp -P -C
+AR = ar
+F90 = f90
+F77 = f90
+CC = cc
+
+F90FLAGS = -n32 -w
+F77FLAGS = -n32 -w
+CFLAGS = -c -O2
+CPPFLAGS =
+LDFLAGS = -n32
+
diff --git a/LIBTOOLS/conf/config.SGI64 b/LIBTOOLS/conf/config.SGI64
new file mode 100644
index 0000000000000000000000000000000000000000..547bbeb426658b3d6a23e66607c749e2ecff10b5
--- /dev/null
+++ b/LIBTOOLS/conf/config.SGI64
@@ -0,0 +1,11 @@
+CPP = /usr/lib/cpp -P -C
+AR = ar
+F90 = f90
+F77 = f90
+
+F90FLAGS = -64 -w
+F77FLAGS = -64 -w
+CFLAGS = -64
+CPPFLAGS =
+LDFLAGS = -64
+
diff --git a/LIBTOOLS/conf/config.SP4Idris b/LIBTOOLS/conf/config.SP4Idris
new file mode 100644
index 0000000000000000000000000000000000000000..53f3de37785c03ddc09abd02d98d048a051e7f68
--- /dev/null
+++ b/LIBTOOLS/conf/config.SP4Idris
@@ -0,0 +1,8 @@
+CPP = cc -C -E
+AR = ar -X64
+F77 = xlf90_r -qarch=pwr4 -qzerosize -qautodbl=dbl4 -qmaxmem=-1
+F90 = xlf90_r -qarch=pwr4 -qzerosize -qautodbl=dbl4 -qmaxmem=-1
+F77FLAGS = -q64 -qfixed -qsave -O3 -qstrict
+F90FLAGS = -q64 -qfree=f90 -qsuffix=f=f90 -qsave -O3 -qstrict
+CPPFLAGS =
+LDFLAGS =
diff --git a/LIBTOOLS/conf/config.SX5 b/LIBTOOLS/conf/config.SX5
new file mode 100644
index 0000000000000000000000000000000000000000..e972f908d0f176dccaa7abce800f4897c4ae40b5
--- /dev/null
+++ b/LIBTOOLS/conf/config.SX5
@@ -0,0 +1,11 @@
+CPP = /usr/lib/cpp -P -C
+AR = sxar
+F90 = sxf90
+F77 = sxf90
+CC = sxcc
+
+F90FLAGS = -w -Cvsafe
+F77FLAGS = -w -Cvsafe
+
+LDFLAGS =
+
diff --git a/LIBTOOLS/conf/config.SX8 b/LIBTOOLS/conf/config.SX8
new file mode 100644
index 0000000000000000000000000000000000000000..532c235f9030eb0a11d5c0534f537034ddc92ca4
--- /dev/null
+++ b/LIBTOOLS/conf/config.SX8
@@ -0,0 +1,11 @@
+CPP = sxcpp -P -C
+AR = sxar
+F90 = sxf90
+F77 = sxf90
+CC = sxcc
+
+F90FLAGS = -w -Cvsafe
+F77FLAGS = -w -Cvsafe
+
+LDFLAGS =
+
diff --git a/LIBTOOLS/conf/config.VPP b/LIBTOOLS/conf/config.VPP
new file mode 100644
index 0000000000000000000000000000000000000000..a0c049cd8b54df250d284a7c38933037ecbc3209
--- /dev/null
+++ b/LIBTOOLS/conf/config.VPP
@@ -0,0 +1,9 @@
+CPP = /usr/ccs/lib/cpp -P -C
+AR = ar
+F90 = frt
+F77 = frt
+F90FLAGS = -X9 -Am -Sw
+F77FLAGS = -Sw
+CPPFLAGS = -DFUJI
+LDFLAGS =
+
diff --git a/LIBTOOLS/conf/config.gfortranR64 b/LIBTOOLS/conf/config.gfortranR64
new file mode 100644
index 0000000000000000000000000000000000000000..647e0de140590d566740b03f3ca859f73a7ddd01
--- /dev/null
+++ b/LIBTOOLS/conf/config.gfortranR64
@@ -0,0 +1,19 @@
+#
+# Configuration file for PGF (64-bit reals).
+#
+AR = ar
+ARFLAGS = rv
+#
+CC = gcc
+CFLAGS = -O2 -D__hpux -DREAL_8 -DREAL_BIGGER_THAN_INTEGER
+FASTCFLAGS =
+#
+FC = gfortran
+VECTFFLAGS =
+CPPFLAGS = -D__hpux -DREAL_8 -DREAL_BIGGER_THAN_INTEGER -Dextend2o -Dg95
+FFLAGS = -w -g -O2 -fdefault-real-8
+#
+LDFLAGS = -L . -l emos$(R64)
+RANLIB = /bin/true
+CT = /bin/true
+NPROC = 1
diff --git a/LIBTOOLS/conf/listing b/LIBTOOLS/conf/listing
new file mode 100755
index 0000000000000000000000000000000000000000..3f69ec78cd81faa4182731928e48e78306e342b4
--- /dev/null
+++ b/LIBTOOLS/conf/listing
@@ -0,0 +1,8 @@
+>lst.conf
+for i in config.* ; do
+echo $i >>lst.conf
+echo '---------------' >> lst.conf
+cat $i >>lst.conf
+echo '======================================='>> lst.conf
+done
+
diff --git a/LIBTOOLS/lib/COMPRESS/Makefile b/LIBTOOLS/lib/COMPRESS/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..ed63fbb9ab2c5698d940aaee7f00235241f1432f
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Makefile
@@ -0,0 +1,38 @@
+LIBCOMP = liblficomp.a
+#######################################
+DIR_OBJ = ./$(ARCH)
+
+VPATH = src:$(DIR_OBJ)
+INC = -I$(DIR_OBJ)
+
+DIR_CONF:=$(shell pwd|sed -e 's/lib\/.*/conf/')
+
+include $(DIR_CONF)/config.$(ARCH)
+include Rules.$(ARCH)
+
+
+%.o:%.f90
+ $(CPP) $(INC) $(CPPFLAGS) $< > $(DIR_OBJ)/cpp_$(*F).f90
+ $(F90) $(INC) -c $(F90FLAGS) $(DIR_OBJ)/cpp_$(*F).f90 -o $(DIR_OBJ)/$(*F).o
+ -@mv *.mod $(DIR_OBJ)/. 2> /dev/null || echo pas de module dans $*.f90
+
+%.o:%.c
+ $(CC) $(INC) $(CFLAGS) $(CPPFLAGS) -c $< -o $(DIR_OBJ)/$(*F).o
+
+$(LIBCOMP) : $(DIR_OBJ)/.dummy $(OBJS)
+ cd $(DIR_OBJ);$(AR) crv $@ $(OBJS)
+
+$(DIR_OBJ)/.dummy :
+ mkdir -p $(DIR_OBJ)
+ @touch $(DIR_OBJ)/.dummy
+
+compress.o : searchgrp.o comppar.o
+decompress.o : searchgrp.o comppar.o
+
+clean:
+ (if [ -d $(DIR_OBJ) ] ; then cd $(DIR_OBJ); rm -f cpp_*.f90 *.o ; fi)
+
+distclean:
+ rm -rf $(DIR_OBJ)
+
+
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.AIX32 b/LIBTOOLS/lib/COMPRESS/Rules.AIX32
new file mode 100644
index 0000000000000000000000000000000000000000..2c1ea286ea1475272e2e67fb96714704d9c121e9
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.AIX32
@@ -0,0 +1,3 @@
+CPPFLAGS += -DBIG_endian
+
+OBJS=ieee_is_nan.o comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.AIX64 b/LIBTOOLS/lib/COMPRESS/Rules.AIX64
new file mode 100644
index 0000000000000000000000000000000000000000..2c1ea286ea1475272e2e67fb96714704d9c121e9
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.AIX64
@@ -0,0 +1,3 @@
+CPPFLAGS += -DBIG_endian
+
+OBJS=ieee_is_nan.o comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.HPNAGf95 b/LIBTOOLS/lib/COMPRESS/Rules.HPNAGf95
new file mode 100644
index 0000000000000000000000000000000000000000..f8db3945595c8efa09cd1995d2f7d907f2273b14
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.HPNAGf95
@@ -0,0 +1,4 @@
+F90FLAGS += -O2
+CPPFLAGS += -DNAGf95 -DBIG_endian -DNO_UNDERSCORE
+
+OBJS=comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.HPf90 b/LIBTOOLS/lib/COMPRESS/Rules.HPf90
new file mode 100644
index 0000000000000000000000000000000000000000..94847a511f395adb48febdac540254a2d860d0a1
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.HPf90
@@ -0,0 +1,5 @@
+CFLAGS += -Ae
+F90FLAGS += -O3
+CPPFLAGS += -DNO_UNDERSCORE -DBIG_endian
+
+OBJS=ieee_is_nan.o comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.LXNAGf95 b/LIBTOOLS/lib/COMPRESS/Rules.LXNAGf95
new file mode 100644
index 0000000000000000000000000000000000000000..ec7348338f27ad7a0ab2503bd3b2d1b85289d4f3
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.LXNAGf95
@@ -0,0 +1,5 @@
+F77FLAGS +=
+F90FLAGS += -O2
+CPPFLAGS = -DNAGf95 -DLITTLE_endian
+
+OBJS=comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.LXg95 b/LIBTOOLS/lib/COMPRESS/Rules.LXg95
new file mode 100644
index 0000000000000000000000000000000000000000..c2925600f33bc5c794c65bf276dc5245f7373899
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.LXg95
@@ -0,0 +1,5 @@
+F77FLAGS +=
+F90FLAGS += -O2
+CPPFLAGS = -DLITTLE_endian
+
+OBJS=comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o ieee_is_nan.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.LXgfortran b/LIBTOOLS/lib/COMPRESS/Rules.LXgfortran
new file mode 100644
index 0000000000000000000000000000000000000000..c2925600f33bc5c794c65bf276dc5245f7373899
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.LXgfortran
@@ -0,0 +1,5 @@
+F77FLAGS +=
+F90FLAGS += -O2
+CPPFLAGS = -DLITTLE_endian
+
+OBJS=comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o ieee_is_nan.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.LXifort b/LIBTOOLS/lib/COMPRESS/Rules.LXifort
new file mode 100644
index 0000000000000000000000000000000000000000..c2925600f33bc5c794c65bf276dc5245f7373899
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.LXifort
@@ -0,0 +1,5 @@
+F77FLAGS +=
+F90FLAGS += -O2
+CPPFLAGS = -DLITTLE_endian
+
+OBJS=comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o ieee_is_nan.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.LXpgf90 b/LIBTOOLS/lib/COMPRESS/Rules.LXpgf90
new file mode 100644
index 0000000000000000000000000000000000000000..2e9dcee5b6b3929a068a8a4bfe3fff40566088e7
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.LXpgf90
@@ -0,0 +1,3 @@
+CPPFLAGS = -DLITTLE_endian
+
+OBJS=ieee_is_nan.o comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.SGI32 b/LIBTOOLS/lib/COMPRESS/Rules.SGI32
new file mode 100644
index 0000000000000000000000000000000000000000..b6f88252b5b65a766baabeea3723d478ce277a6d
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.SGI32
@@ -0,0 +1,6 @@
+F77LAGS +=
+F90FLAGS += -O2
+CFLAGS +=
+CPPFLAGS += -DBIG_endian
+
+OBJS = ieee_is_nan.o comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.SGI64 b/LIBTOOLS/lib/COMPRESS/Rules.SGI64
new file mode 100644
index 0000000000000000000000000000000000000000..b7a01ad1159d3f600918d3444ce8ef1ba96bd728
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.SGI64
@@ -0,0 +1,5 @@
+F77FLAGS +=
+F90FLAGS += -O2
+CPPFLAGS += -DBIG_endian
+
+OBJS = ieee_is_nan.o comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.SX5 b/LIBTOOLS/lib/COMPRESS/Rules.SX5
new file mode 100644
index 0000000000000000000000000000000000000000..3682a9662052b3574c49acd2714e05a1498756ea
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.SX5
@@ -0,0 +1,4 @@
+F90FLAGS +=
+CPPFLAGS += -DBIG_endian -DSX5
+
+OBJS=ieee_is_nan.o comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.SX8 b/LIBTOOLS/lib/COMPRESS/Rules.SX8
new file mode 100644
index 0000000000000000000000000000000000000000..3682a9662052b3574c49acd2714e05a1498756ea
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.SX8
@@ -0,0 +1,4 @@
+F90FLAGS +=
+CPPFLAGS += -DBIG_endian -DSX5
+
+OBJS=ieee_is_nan.o comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o
diff --git a/LIBTOOLS/lib/COMPRESS/Rules.VPP b/LIBTOOLS/lib/COMPRESS/Rules.VPP
new file mode 100644
index 0000000000000000000000000000000000000000..43ffdda88ed9d3a35331b25cd8f87053e322a1de
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/Rules.VPP
@@ -0,0 +1,5 @@
+F77FLAGS +=
+F90FLAGS +=
+CPPFLAGS += -DVPP -DBIG_endian
+
+OBJS=ieee_is_nan.o comppar.o compress.o decompress.o nearestpow2.o searchgrp.o bitbuff.o
diff --git a/LIBTOOLS/lib/COMPRESS/src/bitbuff.c b/LIBTOOLS/lib/COMPRESS/src/bitbuff.c
new file mode 100644
index 0000000000000000000000000000000000000000..48e5ed483d438b7e2cf322aee2695796d22d60fa
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/src/bitbuff.c
@@ -0,0 +1,118 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#ifdef VPP
+# include <sys/types.h>
+typedef __uint64_t WORD;
+#else
+#ifdef SX5
+typedef unsigned long uint64_t;
+#else
+# include <inttypes.h>
+#endif
+typedef uint64_t WORD;
+#endif
+
+#define WORDSIZE 64
+
+#ifdef NO_UNDERSCORE
+# define SET_FILLIDX set_fillidx
+# define GET_FILLIDX get_fillidx
+# define FILL_BBUFF fill_bbuff
+# define SET_EXTRACTIDX set_extractidx
+# define GET_EXTRACTIDX get_extractidx
+# define EXTRACT_BBUFF extract_bbuff
+#else
+# define SET_FILLIDX set_fillidx_
+# define GET_FILLIDX get_fillidx_
+# define FILL_BBUFF fill_bbuff_
+# define SET_EXTRACTIDX set_extractidx_
+# define GET_EXTRACTIDX get_extractidx_
+# define EXTRACT_BBUFF extract_bbuff_
+#endif
+
+int outidx = 0;
+int outbrem = WORDSIZE ;
+
+int inidx = 0;
+int inbrem = WORDSIZE;
+
+void SET_FILLIDX(unsigned *idx, unsigned *bitoffset){
+ inidx = *idx;
+ inidx += (*bitoffset/WORDSIZE);
+ inbrem = WORDSIZE - (*bitoffset%WORDSIZE);
+}
+
+void GET_FILLIDX(unsigned *idx, unsigned *bitoffset){
+ *idx = inidx;
+ *bitoffset = WORDSIZE - inbrem;
+}
+
+void FILL_BBUFF(WORD *out, int *n, unsigned *val){
+ /* inidx = index of the current buffer elt to fill */
+ /* inbrem = number of bits remaining on buffer elt out[idx] */
+
+ /* fill buffer out with n low bits of val */
+
+ if (inbrem >= *n){
+ inbrem = inbrem - *n;
+ /* turn to 0 the n bits of out */
+ out[inidx] &= ~(~(~(WORD)0 << *n) << inbrem);
+ /* now set the n bits of out to val */
+ out[inidx] |= (*val & ~(~(WORD)0 << *n)) << inbrem;
+ return;
+ } else {
+ int nex = *n - inbrem; /* number of bits that will be filled later */
+ if (inbrem != 0){
+ /* turn to 0 the inbrem lower bits of out */
+ out[inidx] &= (~(WORD)0 << inbrem) ;
+ /* now set the inbrem lower bits of out with val */
+ out[inidx] |= ((*val >> nex) & ~(~(WORD)0 << inbrem));
+ }
+ inidx++;
+ inbrem = WORDSIZE;
+ FILL_BBUFF(out, &nex, val);
+ }
+
+}
+
+void SET_EXTRACTIDX(unsigned *idx, unsigned *bitoffset) {
+ outidx = *idx;
+ outidx += (*bitoffset/WORDSIZE);
+ outbrem = WORDSIZE-(*bitoffset%WORDSIZE);
+}
+
+void GET_EXTRACTIDX(unsigned *idx, unsigned *bitoffset){
+ *idx = outidx;
+ *bitoffset = WORDSIZE - outbrem;
+}
+
+
+void extract_bbuff_rec(WORD *buff, int *n, unsigned *val) {
+
+ if (outbrem >= *n){
+ outbrem = outbrem - *n;
+ *val = (*val << *n) | (unsigned)((buff[outidx]>>outbrem) & ~(~(WORD)0 << *n));
+ return;
+ } else {
+ int nex = *n - outbrem;
+ if (outbrem != 0){
+ *val = (*val << outbrem)| (unsigned)(buff[outidx] & ~(~(WORD)0 << outbrem));
+
+ }
+ outidx++;
+ outbrem=WORDSIZE;
+ extract_bbuff_rec(buff,&nex,val);
+ }
+}
+
+void EXTRACT_BBUFF(WORD *buff, int *n, unsigned *val) {
+
+ unsigned tmpval;
+
+ tmpval=0;
+ extract_bbuff_rec(buff,n,&tmpval);
+ *val = tmpval;
+}
+
diff --git a/LIBTOOLS/lib/COMPRESS/src/comppar.f90 b/LIBTOOLS/lib/COMPRESS/src/comppar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c2712baddea91592e4f24b677080e36180161a1f
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/src/comppar.f90
@@ -0,0 +1,32 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+MODULE MODD_COMPPAR
+IMPLICIT NONE
+! Debug mode : set LPDEBUG to .TRUE.
+LOGICAL,PARAMETER :: LPDEBUG = .FALSE.
+
+
+! contains coding parameters for (de)compress routines
+
+INTEGER,PARAMETER :: JPCSTENCOD = 1 ! constant array
+INTEGER,PARAMETER :: JPSOPENCOD = 2 ! second order packing
+INTEGER,PARAMETER :: JPEXTENCOD = 3 ! second order packing with min/max values excluded
+
+! Extended code when JPEXTENCOD enabled
+!
+! BE CAREFUL : 3 bits are reserved for coding this code => max value is 7
+INTEGER,PARAMETER :: JPCONST = 0 ! constant value array
+INTEGER,PARAMETER :: JPNORM = 1 ! same as JPSOPENCOD
+INTEGER,PARAMETER :: JPMINEXCL = 2 ! Min value is isolated
+INTEGER,PARAMETER :: JPMAXEXCL = 3 ! Max value is isolated
+INTEGER,PARAMETER :: JPMINMAXEXCL = 4 ! Min&Max values are isolated
+INTEGER,PARAMETER :: JP2VAL = 5 ! 2 different values in array
+INTEGER,PARAMETER :: JP3VAL = 6 ! 3 different values in array
+INTEGER,PARAMETER :: JPOTHER = 7 ! for future use
+INTEGER,PARAMETER :: JPLOG = 8
+END MODULE MODD_COMPPAR
diff --git a/LIBTOOLS/lib/COMPRESS/src/compress.f90 b/LIBTOOLS/lib/COMPRESS/src/compress.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2bc2dfaf3afcef1c5dadadcd0053d18659904d51
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/src/compress.f90
@@ -0,0 +1,380 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+SUBROUTINE COMPRESS_FIELD(XTAB,KX,KY,KNBTOT,KNBUSE)
+USE MODD_COMPPAR
+USE MODE_SEARCHGRP
+
+#ifdef NAGf95
+USE,INTRINSIC :: IEEE_ARITHMETIC
+#endif
+
+IMPLICIT NONE
+
+REAL,PARAMETER :: PPFLOATMIN = 2.0**(-126)
+
+INTEGER, INTENT(IN) :: KX,KY
+!INTEGER, INTENT(IN) :: KNBLEV
+INTEGER, INTENT(IN) :: KNBTOT
+REAL(KIND=8),DIMENSION(KNBTOT),INTENT(INOUT) :: XTAB
+
+INTEGER, INTENT(OUT) :: KNBUSE
+
+INTEGER :: INBLEV
+INTEGER,DIMENSION(:), ALLOCATABLE :: ITAB
+REAL :: XMIN,XMAX
+TYPE(SOP_t) :: SOPRES
+INTEGER :: IND1, IND2
+INTEGER :: GELT,IBE
+INTEGER :: ILEVNBELT
+INTEGER :: NBITCOD
+INTEGER :: II, JI, JJ
+INTEGER :: BITOFFSET
+INTEGER :: GRPIDX,GRPOFF,IDXSAVE,OFFSAVE
+INTEGER :: nbgroupmod
+INTEGER :: IEXTCOD
+CHARACTER(LEN=8),PARAMETER :: KEYWORD='COMPRESS'
+REAL,DIMENSION(KNBTOT) :: XWORKTAB
+LOGICAL :: LUPREAL,LNAN
+#ifndef NAGf95
+LOGICAL, EXTERNAL :: IEEE_IS_NAN
+#endif
+
+ILEVNBELT = KX*KY
+LUPREAL = .FALSE.
+LNAN = .FALSE.
+
+! Check for NAN and change Upper and Lower bound according to 32bits real limits.
+DO JI=1,KNBTOT
+ IF (IEEE_IS_NAN(XTAB(JI))) THEN
+ XTAB(JI)=0.
+ LNAN = .TRUE.
+ ELSE IF (ABS(XTAB(JI)) > HUGE(1.0_4)) THEN
+ XTAB(JI) = SIGN(REAL(HUGE(1.0_4)/1.1,8),XTAB(JI))
+ LUPREAL = .TRUE.
+ ELSEIF (ABS(XTAB(JI)) < TINY(1.0_4)) THEN
+ XTAB(JI) = 0.
+ END IF
+END DO
+
+XMIN=MINVAL(XTAB)
+XMAX=MAXVAL(XTAB)
+PRINT *,'MINVAL,MAXVAL= ',XMIN,XMAX
+IF (LNAN) PRINT *,"==================> NAN values DETECTED : set to 0.0"
+IF (LUPREAL) PRINT *,"==================> OVERFLOW values DETECTED : set to ",HUGE(1.0_4)/1.1
+
+! Convert 64 bits real to 32 bits real
+XWORKTAB(:) = XTAB(:)
+!
+! BEWARE : Now XTAB is overwritten.
+! XWORKTAB contains the 32 bits floating point data.
+!
+CALL SET_FILLIDX(0,0)
+! store 8 characters header string in buffer
+DO II=1,LEN(KEYWORD)
+ CALL FILL_BBUFF(XTAB,8,ICHAR(KEYWORD(II:II)))
+END DO
+
+! is whole array XTAB64 a constant field ?
+
+IF (xmin == xmax) THEN
+ PRINT *,"--------> CONSTANT ARRAY !"
+ CALL FILL_BBUFF(XTAB,32,JPCSTENCOD)
+ CALL FILL_BBUFF(XTAB,32,KNBTOT)
+ CALL FILL_BBUFF(XTAB,32,xmin)
+ CALL GET_FILLIDX(KNBUSE,BITOFFSET)
+ KNBUSE=KNBUSE+1
+ RETURN
+END IF
+
+
+INBLEV = KNBTOT/(ILEVNBELT)
+IF (KNBTOT /= (INBLEV*ILEVNBELT)) THEN
+ PRINT *,'Pb in COMPRESS_FIELD : KNBTOT must be a multiple of KX*KY'
+ STOP
+END IF
+
+
+
+ALLOCATE(ITAB(ILEVNBELT))
+CALL INI_SOPDATA(SOPRES)
+
+CALL FILL_BBUFF(XTAB,32,JPEXTENCOD)
+CALL FILL_BBUFF(XTAB,32,KNBTOT)
+CALL FILL_BBUFF(XTAB,32,KX)
+CALL FILL_BBUFF(XTAB,32,KY)
+
+DO JI=1,INBLEV
+ IND1=(JI-1)*ILEVNBELT+1
+ IND2=JI*ILEVNBELT
+ IF (LPDEBUG) PRINT *,"---- Compressing Level ",JI," ----"
+ CALL COMP_FOPEXT(XWORKTAB(IND1:IND2),ITAB,IEXTCOD)
+ IF (IEXTCOD /= JPCONST) THEN
+ CALL INVERTCOL(ITAB,KX,KY)
+ CALL RECSEARCH(ITAB,SOPRES)
+ GELT = MAXVAL(SOPRES%IEND(1:SOPRES%NBGRP)-SOPRES%IBEG(1:SOPRES%NBGRP)+1)
+ IBE = FMINBITS_IN_WORD(GELT)
+ CALL GET_FILLIDX(GRPIDX,GRPOFF) ! save the idx/offset for future NBGRP modification
+ CALL FILL_BBUFF(XTAB,32,SOPRES%NBGRP)
+ CALL FILL_BBUFF(XTAB,5,IBE)
+
+ NBGROUPMOD = SOPRES%NBGRP
+ DO II=1,SOPRES%NBGRP
+ GELT = SOPRES%IEND(II)-SOPRES%IBEG(II)+1
+ nbitcod = FMINBITS_IN_WORD(SOPRES%VALMAX(II)-SOPRES%VALMIN(II))
+ ! PRINT *, 'Groupe',II,'(',GELT,')',':',SOPRES%IBEG(II),SOPRES%IEND(II),&
+ ! &'MIN,MAX=',SOPRES%VALMIN(II),SOPRES%VALMAX(II),&
+ ! &'(',SOPRES%VALMAX(II)-SOPRES%VALMIN(II),'/',&
+ ! &nbitcod,')'
+ IF (nbitcod >= 16) THEN
+ PRINT *,'-----> ERREUR FATALE : Groupe',II,'codage sur ',nbitcod,'bits'
+ END IF
+ IF (GELT > 1) THEN
+ ! Plus d'un element dans le groupe
+ IF ((17*GELT) < (17+4+IBE+nbitcod*GELT)) THEN
+ ! on prefere GELT groupes de 1 elt
+ DO JJ=SOPRES%IBEG(II),SOPRES%IEND(II)
+ ! 1 seul elt par groupe
+ CALL FILL_BBUFF(XTAB,1,1)
+ CALL FILL_BBUFF(XTAB,16,ITAB(JJ))
+ END DO
+ NBGROUPMOD = NBGROUPMOD+GELT-1
+ ELSE
+ CALL FILL_BBUFF(XTAB,1,0)
+ CALL FILL_BBUFF(XTAB,16,SOPRES%VALMIN(II))
+ CALL FILL_BBUFF(XTAB,4,nbitcod)
+ CALL FILL_BBUFF(XTAB,IBE,GELT)
+ IF (nbitcod > 0) THEN
+ DO JJ=SOPRES%IBEG(II),SOPRES%IEND(II)
+ ! stockage des GELT écarts/VALMIN
+ CALL FILL_BBUFF(XTAB,nbitcod,ITAB(JJ)-SOPRES%VALMIN(II))
+ END DO
+ END IF
+ END IF
+ ELSE
+ ! 1 seul elt dans groupe
+ CALL FILL_BBUFF(XTAB,1,1)
+ CALL FILL_BBUFF(XTAB,16,SOPRES%VALMIN(II))
+ END IF
+ END DO
+ IF (NBGROUPMOD > SOPRES%NBGRP) THEN
+ ! we must change the number of elements
+ CALL GET_FILLIDX(IDXSAVE,OFFSAVE) ! save the current idx/offset
+ CALL SET_FILLIDX(GRPIDX,GRPOFF)
+ CALL FILL_BBUFF(XTAB,32,NBGROUPMOD)
+ CALL SET_FILLIDX(IDXSAVE,OFFSAVE) ! restore the current idx/offset
+ END IF
+ END IF
+END DO
+
+CALL GET_FILLIDX(IDXSAVE,OFFSAVE)
+KNBUSE=IDXSAVE+1
+
+DEALLOCATE(ITAB)
+
+CONTAINS
+
+SUBROUTINE COMP_FOPEXT(PTAB,KTAB,KEXTCOD)
+REAL, DIMENSION(:), INTENT(IN) :: PTAB
+INTEGER, DIMENSION(:), INTENT(OUT):: KTAB
+INTEGER, INTENT(OUT):: KEXTCOD
+
+LOGICAL,DIMENSION(SIZE(PTAB)) :: GMASK
+REAL,DIMENSION(SIZE(PTAB)) :: PTABWORK
+REAL :: XMIN1,XMAX1,XRANGE1
+REAL :: XMIN2,XMAX2,XRANGE2
+REAL :: XREF,XMAX,XCOEFF
+INTEGER :: INTRANGE
+INTEGER :: INDCOR ! correction d'index pour la supression du min
+LOGICAL :: GMINEXCL,GMAXEXCL,GLOG
+INTEGER :: IEXTCOD2
+REAL, PARAMETER :: XUNDEF = 999.
+REAL, PARAMETER :: XUNDEFSURF = 1.E+20
+
+
+!! G. TANGUY avril 2010 : on change la valeur indéfinie 999. a une valeur
+!indéfinie plus grande que sera de façon certaine le max du champ s'il est
+!present. POur ça on travaille dans le tableau de travail PTABWORK
+PTABWORK=PTAB
+WHERE(PTABWORK == XUNDEF)
+ PTABWORK=XUNDEFSURF
+END WHERE
+
+XMIN1=MINVAL(PTABWORK(:))
+XMAX1=MAXVAL(PTABWORK(:))
+XRANGE1=XMAX1-XMIN1
+IF (LPDEBUG) PRINT *,"XMIN1,XMAX1,XRANGE1 = ",XMIN1,XMAX1,XRANGE1
+
+IF (XRANGE1 > 0.) THEN
+ XMIN2=MINVAL(PTABWORK,MASK=PTABWORK>XMIN1)
+ XMAX2=MAXVAL(PTABWORK,MASK=PTABWORK<XMAX1)
+ XRANGE2 = XMAX2-XMIN2
+ IF (LPDEBUG) PRINT *,"XMIN2,XMAX2,XRANGE2 = ",XMIN2,XMAX2,XRANGE2
+ IF (XRANGE2 > 0.) THEN
+ GLOG = .FALSE.
+ GMINEXCL = .FALSE.
+ GMAXEXCL = .FALSE.
+ GMASK(:) = .TRUE.
+ INDCOR = 0
+ KEXTCOD = JPNORM
+ INTRANGE=65535
+ XREF = XMIN1
+ XMAX = XMAX1
+
+ ! Check for range between 0 and 1 to convert to LOG values
+ IF (XMIN1 >= 0. .AND. XMAX1 < 1.) THEN
+ IF ((XMAX2/XMIN2)>10.) THEN
+ GLOG = .TRUE.
+ KEXTCOD = JPOTHER
+ IEXTCOD2 = JPLOG
+ INTRANGE=INTRANGE-1
+ INDCOR = 1 ! On reserve la valeur 0 dans tous les cas
+ IF (XMIN1 == 0.0) THEN
+ XREF = LOG(XMIN2)
+ WHERE (PTABWORK < XMIN2)
+ KTAB = 0
+ GMASK = .FALSE.
+ END WHERE
+ ELSE
+ XREF = LOG(XMIN1)
+ END IF
+ XMAX1 = LOG(XMAX1)
+ XMAX = XMAX1
+ XMAX2 = LOG(XMAX2)
+ XRANGE2 = XMAX2 - XREF
+ IF (LPDEBUG) PRINT *,"EXTENCOD, LOG conversion enabled : XMIN1, XREF, XMAX1, XMAX2 =",&
+ &XMIN1,XREF,XMAX1,XMAX2
+ END IF
+ ELSE
+ ! Check for MIN value exclusion
+ IF (XMIN1 == XUNDEFSURF .OR. (XMIN2-XMIN1) > XRANGE2) THEN
+ ! Min value excluded
+ GMINEXCL = .TRUE.
+ XREF=XMIN2
+ INTRANGE=INTRANGE-1
+ INDCOR = 1
+ WHERE (PTABWORK < XMIN2)
+ KTAB = 0
+ GMASK = .FALSE.
+ END WHERE
+ IF (LPDEBUG) PRINT *,"EXTENCOD, Min value isolated :",XMIN1
+ KEXTCOD = JPMINEXCL
+ IF (XMIN1 == XUNDEFSURF) THEN
+ XMIN1=XUNDEF
+ END IF
+ END IF
+ ! Check for MAX value exclusion
+ IF (XMAX1 == XUNDEFSURF .OR. (XMAX1-XMAX2) > XRANGE2) THEN
+ ! Max value excluded
+ GMAXEXCL = .TRUE.
+ XMAX=XMAX2
+ INTRANGE=INTRANGE-1
+ WHERE (PTABWORK > XMAX2)
+ KTAB = 65535
+ GMASK = .FALSE.
+ END WHERE
+
+ IF (GMINEXCL) THEN
+ KEXTCOD = JPMINMAXEXCL ! Min et Max exclus
+ IF (LPDEBUG) PRINT *,"EXTENCOD, and Max value isolated :",XMAX1
+ ELSE
+ KEXTCOD = JPMAXEXCL ! Max exclus
+ IF (LPDEBUG) PRINT *,"EXTENCOD, Max value isolated :",XMAX1
+ END IF
+ ! avril 2010 : on remet la valeur indefine de mesonh 999.
+ IF (XMAX1 == XUNDEFSURF) THEN
+ XMAX1=XUNDEF
+ END IF
+ END IF
+ END IF
+ !
+ XCOEFF=(XMAX-XREF)/INTRANGE
+ IF (XCOEFF < PPFLOATMIN) THEN
+ XCOEFF = PPFLOATMIN
+ PRINT *, "very low range DATA : XCOEFF set to",XCOEFF
+ END IF
+ IF (LPDEBUG) PRINT *,"XCOEFF = ",XCOEFF
+ IF (GLOG) THEN
+ WHERE(GMASK)
+ KTAB = INDCOR + NINT((LOG(PTABWORK)-XREF)/XCOEFF)
+ END WHERE
+ ELSE
+ WHERE(GMASK)
+ KTAB = INDCOR + NINT((PTABWORK(:)-XREF)/XCOEFF)
+ END WHERE
+ END IF
+ IF (LPDEBUG) PRINT *,"KEXTCOD = ",KEXTCOD
+ CALL FILL_BBUFF(XTAB,3,KEXTCOD)
+ IF (GLOG) CALL FILL_BBUFF(XTAB,3,IEXTCOD2)
+ IF (GMINEXCL) CALL FILL_BBUFF(XTAB,32,XMIN1)
+ IF (GMAXEXCL) CALL FILL_BBUFF(XTAB,32,XMAX1)
+ CALL FILL_BBUFF(XTAB,32,XREF)
+ CALL FILL_BBUFF(XTAB,32,XCOEFF)
+ ELSE
+ IF (XRANGE2 < 0.) THEN
+ ! only 2 values in PTAB array
+ !
+ ! KTAB(i)= 0 if PTAB(i)==XMIN1
+ ! 1 if PTAB(i)==XMAX1
+ !
+ IF (LPDEBUG) PRINT *,"EXTENCOD, 2 values in array :",XMIN1,XMAX1
+ IF (XMAX1 == XUNDEFSURF) THEN
+ XMAX1=XUNDEF
+ END IF
+ IF (XMIN1 == XUNDEFSURF) THEN
+ XMIN1=XUNDEF
+ END IF
+ KEXTCOD = JP2VAL
+ CALL FILL_BBUFF(XTAB,3,KEXTCOD)
+ CALL FILL_BBUFF(XTAB,32,XMIN1)
+ CALL FILL_BBUFF(XTAB,32,XMAX1)
+ WHERE (PTABWORK < XMAX1)
+ KTAB = 0
+ ELSEWHERE
+ KTAB = 1
+ END WHERE
+ ELSE
+ ! XRANGE2 == 0. <==> XMIN2=XMAX2
+ ! 3 values in PTAB array :
+ !
+ ! 0 if PTAB(i)==XMIN1 ! KTAB(i)= 1 if PTAB(i)==XMIN2(=XMAX2)
+ ! 2 if PTAB(i)==XMAX1
+ !
+ IF (LPDEBUG) PRINT *,"EXTENCOD, 3 values in array :",XMIN1,XMIN2,XMAX1
+ IF (XMAX1 == XUNDEFSURF) THEN
+ XMAX1=XUNDEF
+ END IF
+ IF (XMIN1 == XUNDEFSURF) THEN
+ XMIN1=XUNDEF
+ END IF
+
+ KEXTCOD = JP3VAL
+ CALL FILL_BBUFF(XTAB,3,KEXTCOD)
+ CALL FILL_BBUFF(XTAB,32,XMIN1)
+ CALL FILL_BBUFF(XTAB,32,XMIN2)
+ CALL FILL_BBUFF(XTAB,32,XMAX1)
+ WHERE (PTABWORK < XMIN2)
+ KTAB = 0
+ ELSEWHERE
+ KTAB = 1
+ END WHERE
+ WHERE (PTABWORK > XMIN2) KTAB = 2
+ END IF
+
+ END IF
+ELSE
+ IF (XMIN1 == XUNDEFSURF) THEN
+ XMIN1=XUNDEF
+ END IF
+
+ ! Constant array found : save its 32 bits real value.
+ KEXTCOD=JPCONST
+ CALL FILL_BBUFF(XTAB,3,KEXTCOD)
+ CALL FILL_BBUFF(XTAB,32,XMIN1)
+ IF (LPDEBUG) PRINT *,"EXTENCOD, constant array : ",XMIN1
+END IF
+END SUBROUTINE COMP_FOPEXT
+
+END SUBROUTINE COMPRESS_FIELD
diff --git a/LIBTOOLS/lib/COMPRESS/src/decompress.f90 b/LIBTOOLS/lib/COMPRESS/src/decompress.f90
new file mode 100644
index 0000000000000000000000000000000000000000..095f7dcbd559defd4b9c6a2987319d15ff73ea60
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/src/decompress.f90
@@ -0,0 +1,303 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+SUBROUTINE GET_COMPHEADER(KTAB,SIZEKTAB,KNBELT,KTYPECOD)
+
+INTEGER, INTENT(IN) :: SIZEKTAB
+INTEGER(KIND=8), DIMENSION(SIZEKTAB), INTENT(IN) :: KTAB
+INTEGER, INTENT(OUT) :: KNBELT ! size of decompressed array
+INTEGER, INTENT(OUT) :: KTYPECOD ! code for compression type
+
+CHARACTER(LEN=8) :: STRKEY
+
+INTEGER :: INTCHAR
+INTEGER :: JI
+
+CALL SET_EXTRACTIDX(0,0)
+! extract string header
+DO JI=1,8
+ CALL EXTRACT_BBUFF(KTAB,8,INTCHAR)
+ STRKEY(JI:JI) = CHAR(INTCHAR)
+END DO
+
+! Treat array if it is compressed
+IF (STRKEY == 'COMPRESS') THEN
+ CALL EXTRACT_BBUFF(KTAB,32,KTYPECOD)
+ CALL EXTRACT_BBUFF(KTAB,32,KNBELT)
+ELSE
+ KNBELT =-1
+ KTYPECOD = 0
+END IF
+
+END SUBROUTINE GET_COMPHEADER
+
+SUBROUTINE DECOMPRESS_FIELD(XTAB,NBELT,COMPTAB,NBCOMPELT,CODINGTYPE)
+USE MODD_COMPPAR
+USE MODE_SEARCHGRP
+
+IMPLICIT NONE
+INTEGER, INTENT(IN) :: NBELT
+INTEGER, INTENT(IN) :: NBCOMPELT
+REAL (KIND=8),DIMENSION(NBELT),TARGET,INTENT(OUT) :: XTAB
+INTEGER(KIND=8),DIMENSION(NBCOMPELT), INTENT(IN) :: COMPTAB
+INTEGER, INTENT(IN) :: CODINGTYPE
+
+INTEGER,DIMENSION(:), ALLOCATABLE :: ITAB
+LOGICAL,DIMENSION(:), ALLOCATABLE :: GMASK
+
+REAL :: XREF, XCOEFF
+INTEGER :: INBLEV
+INTEGER :: ILEVNBELT
+INTEGER :: JI
+INTEGER :: IND1, IND2
+INTEGER :: IDIMX,IDIMY
+INTEGER :: IEXTCOD
+REAL(KIND=8),DIMENSION(:),POINTER :: XPTRTAB
+REAL :: XMIN,XMAX
+
+SELECT CASE (CODINGTYPE)
+CASE (JPCSTENCOD)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
+ XTAB(:) = XREF
+
+CASE (JPSOPENCOD)
+ CALL EXTRACT_BBUFF(COMPTAB,32,IDIMX)
+ CALL EXTRACT_BBUFF(COMPTAB,32,IDIMY)
+ ILEVNBELT = IDIMX * IDIMY
+ INBLEV = NBELT/(ILEVNBELT)
+ ALLOCATE(ITAB(ILEVNBELT))
+ DO JI=1,INBLEV
+ IND1=(JI-1)*ILEVNBELT+1
+ IND2=JI*ILEVNBELT
+ XPTRTAB=>XTAB(IND1:IND2)
+ IF (LPDEBUG) PRINT *,'###### Decompress(SOPENCOD) LEVEL ',JI,'######'
+ CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XCOEFF)
+ CALL EXTRACTINTARRAY(ITAB)
+ CALL DECOMP_FOP(XPTRTAB,ITAB,XREF,XCOEFF)
+ END DO
+
+CASE (JPEXTENCOD)
+ CALL EXTRACT_BBUFF(COMPTAB,32,IDIMX)
+ CALL EXTRACT_BBUFF(COMPTAB,32,IDIMY)
+ ILEVNBELT = IDIMX * IDIMY
+ INBLEV = NBELT/(ILEVNBELT)
+ ALLOCATE(ITAB(ILEVNBELT))
+ ALLOCATE(GMASK(ILEVNBELT))
+ DO JI=1,INBLEV
+
+ IF (LPDEBUG) PRINT *,'###### Decompress(EXTENCOD) LEVEL ',JI,'######'
+ IND1=(JI-1)*ILEVNBELT+1
+ IND2=JI*ILEVNBELT
+ XPTRTAB=>XTAB(IND1:IND2)
+ !
+ CALL EXTRACT_BBUFF(COMPTAB,3,IEXTCOD)
+ IF (IEXTCOD == JPOTHER) THEN
+ CALL EXTRACT_BBUFF(COMPTAB,3,IEXTCOD)
+ IEXTCOD = IEXTCOD + 8
+ END IF
+ IF (LPDEBUG) PRINT *, "IEXTCOD = ",IEXTCOD
+ SELECT CASE(IEXTCOD)
+ CASE(JPLOG)
+ ! Conversion to log values of original data 0<=x<1
+ CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XCOEFF)
+ CALL EXTRACTINTARRAY(ITAB)
+ GMASK(:) = .TRUE.
+ WHERE (ITAB == 0)
+ GMASK = .FALSE.
+ XPTRTAB = 0.0
+ END WHERE
+ CALL DECOMP_FOP(XPTRTAB,ITAB,XREF,XCOEFF,GMASK,1)
+ WHERE(GMASK)
+ XPTRTAB = EXP(XPTRTAB)
+ END WHERE
+
+ CASE(JPCONST)
+ ! constant value array
+ CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
+ XPTRTAB(:) = XREF
+ IF (LPDEBUG) PRINT *," CONST value=",XREF
+
+ CASE(JP2VAL)
+ ! 2 different values in array
+ CALL EXTRACT_BBUFF(COMPTAB,32,XMIN)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XMAX)
+ CALL EXTRACTINTARRAY(ITAB)
+ WHERE (ITAB == 0)
+ XPTRTAB = XMIN
+ ELSEWHERE
+ XPTRTAB = XMAX
+ END WHERE
+ IF (LPDEBUG) PRINT *," 2 values:",XMIN,XMAX
+
+ CASE(JP3VAL)
+ ! 3 different values in array
+ CALL EXTRACT_BBUFF(COMPTAB,32,XMIN)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XMAX)
+ CALL EXTRACTINTARRAY(ITAB)
+ WHERE (ITAB == 0)
+ XPTRTAB = XMIN
+ ELSEWHERE
+ XPTRTAB = XREF
+ END WHERE
+ WHERE (ITAB == 2) XPTRTAB = XMAX
+ IF (LPDEBUG) PRINT *," 3 values:",XMIN,XREF,XMAX
+
+ CASE(JPNORM)
+ ! same as JPSOPENCOD
+ CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XCOEFF)
+ CALL EXTRACTINTARRAY(ITAB)
+ CALL DECOMP_FOP(XPTRTAB,ITAB,XREF,XCOEFF)
+ IF (LPDEBUG) PRINT *," normal, XREF/XCOEFF = ",XREF,XCOEFF
+
+ CASE(JPMINEXCL)
+ ! Min value is isolated
+ CALL EXTRACT_BBUFF(COMPTAB,32,XMIN)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XCOEFF)
+ CALL EXTRACTINTARRAY(ITAB)
+ GMASK(:) = .TRUE.
+ WHERE (ITAB == 0)
+ GMASK = .FALSE.
+ XPTRTAB = XMIN
+ END WHERE
+ CALL DECOMP_FOP(XPTRTAB,ITAB,XREF,XCOEFF,GMASK,1)
+ IF (LPDEBUG) PRINT *," Min exclus, MIN/XREF/XCOEFF = ",XMIN,XREF,XCOEFF
+
+ CASE(JPMAXEXCL)
+ ! Max value is isolated
+ CALL EXTRACT_BBUFF(COMPTAB,32,XMAX)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XCOEFF)
+ CALL EXTRACTINTARRAY(ITAB)
+ GMASK(:) = .TRUE.
+ WHERE (ITAB == 65535)
+ GMASK = .FALSE.
+ XPTRTAB = XMAX
+ END WHERE
+ CALL DECOMP_FOP(XPTRTAB,ITAB,XREF,XCOEFF,GMASK,0)
+ IF (LPDEBUG) PRINT *," Max exclus, MAX/XREF/XCOEFF = ",XMAX,XREF,XCOEFF
+
+ CASE(JPMINMAXEXCL)
+ ! Min&Max value are isolated
+ CALL EXTRACT_BBUFF(COMPTAB,32,XMIN)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XMAX)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XREF)
+ CALL EXTRACT_BBUFF(COMPTAB,32,XCOEFF)
+ CALL EXTRACTINTARRAY(ITAB)
+ GMASK(:) = .TRUE.
+ WHERE (ITAB == 0)
+ GMASK = .FALSE.
+ XPTRTAB = XMIN
+ END WHERE
+ WHERE (ITAB == 65535)
+ GMASK = .FALSE.
+ XPTRTAB = XMAX
+ END WHERE
+ CALL DECOMP_FOP(XPTRTAB,ITAB,XREF,XCOEFF,GMASK,1)
+ IF (LPDEBUG) PRINT *," Min et Max exclus, MIN/MAX/XREF/XCOEFF = ",&
+ &XMIN,XMAX,XREF,XCOEFF
+ END SELECT
+ END DO
+
+CASE DEFAULT
+ PRINT *,'Error in CODINGTYPE : program aborted'
+ STOP
+END SELECT
+
+CONTAINS
+
+SUBROUTINE DECOMP_FOP(PTAB,KTAB,PREF,PCOEFF,OMASK,KINDCOR)
+REAL(KIND=8), DIMENSION(:), INTENT(INOUT) :: PTAB
+! Attention: avec le compilateur PGF, utiliser INTENT(OUT) provoque une recopie
+! complete du tableau dans PTAB (avec ecrasement possible des valeurs
+! presentes a l'appel de la procedure). Le phenomene est genant lorsque
+! DECOMP_FOP ne calcule que sur une portion de PTAB (valeurs min et/ou max
+! sont presentes). En declarant PTAB en INOUT, les valeurs en entree de la routine
+! sont conservees si elles n'ont pas ete modifiees.
+
+INTEGER, DIMENSION(:), INTENT(IN) :: KTAB
+REAL, INTENT(IN) :: PREF
+REAL, INTENT(IN) :: PCOEFF
+LOGICAL, DIMENSION(:),INTENT(IN),OPTIONAL :: OMASK
+INTEGER,INTENT(IN),OPTIONAL :: KINDCOR ! 1 if Min value is isolated, 0 otherwise
+
+INTEGER :: INDCOR
+
+IF (.NOT. PRESENT(KINDCOR)) THEN
+ INDCOR = 0
+ELSE
+ INDCOR = KINDCOR
+END IF
+
+IF (PRESENT(OMASK)) THEN
+ WHERE (OMASK)
+ PTAB(:) = PCOEFF*(KTAB(:)-INDCOR)+PREF
+ END WHERE
+ELSE
+ IF (PCOEFF == 0.0) THEN
+ PTAB(:) = PREF
+ ELSE
+ PTAB(:) = PCOEFF*KTAB(:)+PREF
+ END IF
+END IF
+
+END SUBROUTINE DECOMP_FOP
+
+SUBROUTINE EXTRACTINTARRAY(KTAB)
+INTEGER,DIMENSION(:),INTENT(OUT) :: KTAB
+!
+! COMPTAB, IDIMX and IDIMY are defined in the calling routine
+!
+INTEGER :: NBGRP
+INTEGER :: IBE
+INTEGER :: CPT
+INTEGER :: JJ
+INTEGER :: ALONE
+INTEGER :: NBITCOD,IMIN
+INTEGER :: GELT
+INTEGER :: JELT
+INTEGER :: IEPS
+
+CALL EXTRACT_BBUFF(COMPTAB,32,NBGRP)
+! PRINT *,'Nbre de groupes =',NBGRP
+CALL EXTRACT_BBUFF(COMPTAB,5,IBE)
+! PRINT *,'Nbre de bits pour coder le nombre d''elements:',IBE
+CPT = 1
+DO JJ=1,NBGRP
+ ! PRINT *,'Groupe ',JJ,' : '
+ CALL EXTRACT_BBUFF(COMPTAB,1,ALONE)
+ CALL EXTRACT_BBUFF(COMPTAB,16,IMIN)
+ ! PRINT *,'IREF=',IMIN
+
+ IF (ALONE == 1) THEN
+ ! 1 seul elt dans le groupe
+ ! PRINT *,'--> un seul element dans le groupe'
+ KTAB(CPT)=IMIN
+ CPT=CPT+1
+ ELSE
+ CALL EXTRACT_BBUFF(COMPTAB,4,NBITCOD)
+ CALL EXTRACT_BBUFF(COMPTAB,IBE,GELT)
+ ! PRINT *,'--> ',GELT,' elts, codage ecart sur ',nbitcod,'bits'
+ IF (NBITCOD > 0) THEN
+ DO JELT=1,GELT
+ CALL EXTRACT_BBUFF(COMPTAB,NBITCOD,IEPS)
+ KTAB(CPT) = IMIN+IEPS
+ CPT=CPT+1
+ END DO
+ ELSE
+ KTAB(CPT:CPT+GELT-1) = IMIN
+ CPT = CPT+GELT
+ END IF
+ END IF
+END DO
+CALL INVERTCOL(KTAB,IDIMX,IDIMY)
+END SUBROUTINE EXTRACTINTARRAY
+
+END SUBROUTINE DECOMPRESS_FIELD
+
diff --git a/LIBTOOLS/lib/COMPRESS/src/ieee754.h b/LIBTOOLS/lib/COMPRESS/src/ieee754.h
new file mode 100644
index 0000000000000000000000000000000000000000..0f5802ba1a1a070dc72d43991b140d22caf3af0b
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/src/ieee754.h
@@ -0,0 +1,63 @@
+#undef __BYTE_ORDER
+
+#ifdef BIG_endian
+# define __BYTE_ORDER 1234
+#endif
+#ifdef LITTLE_endian
+# define __BYTE_ORDER 4321
+#endif
+#if !(defined(__BYTE_ORDER))
+ #error "ieee754.h : you MUST specify \
+-DBIG_endian or -DLITTLE_endian \
+in CPPFLAGS of your Makefile."
+/* Compiler must throw us out at this point! */
+#endif
+
+#define __BIG_ENDIAN 1234
+#define __LITTLE_ENDIAN 4321
+
+union ieee754_double
+ {
+ double d;
+
+ /* This is the IEEE 754 double-precision format. */
+ struct
+ {
+#if __BYTE_ORDER == __BIG_ENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:11;
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa0:20;
+ unsigned int mantissa1:32;
+#endif /* Big endian. */
+#if __BYTE_ORDER == __LITTLE_ENDIAN
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa1:32;
+ unsigned int mantissa0:20;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+#endif /* Little endian. */
+ } ieee;
+
+ /* This format makes it easier to see if a NaN is a signalling NaN. */
+ struct
+ {
+#if __BYTE_ORDER == __BIG_ENDIAN
+ unsigned int negative:1;
+ unsigned int exponent:11;
+ unsigned int quiet_nan:1;
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa0:19;
+ unsigned int mantissa1:32;
+#else
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa1:32;
+ unsigned int mantissa0:19;
+ unsigned int quiet_nan:1;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+#endif
+ } ieee_nan;
+ };
+
+#define IEEE754_DOUBLE_BIAS 0x3ff /* Added to exponent. */
diff --git a/LIBTOOLS/lib/COMPRESS/src/ieee_is_nan.c b/LIBTOOLS/lib/COMPRESS/src/ieee_is_nan.c
new file mode 100644
index 0000000000000000000000000000000000000000..f8682fbdba4e1ae2c55900c9127279a6de445fb9
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/src/ieee_is_nan.c
@@ -0,0 +1,11 @@
+#include <math.h>
+
+#ifdef NO_UNDERSCORE
+# define IEEE_IS_NAN ieee_is_nan
+#else
+# define IEEE_IS_NAN ieee_is_nan_
+#endif
+
+int IEEE_IS_NAN(double *x){
+ return isnan(*x);
+}
diff --git a/LIBTOOLS/lib/COMPRESS/src/nearestpow2.c b/LIBTOOLS/lib/COMPRESS/src/nearestpow2.c
new file mode 100644
index 0000000000000000000000000000000000000000..e07a0ecc3a00c45afcf6ab8e23ae5f5fe304354a
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/src/nearestpow2.c
@@ -0,0 +1,87 @@
+#include <stdio.h>
+#include "ieee754.h"
+#include <math.h>
+
+#ifdef NO_UNDERSCORE
+# define NEAREST_POW2 nearest_pow2
+# define MINBITS_IN_WORD minbits_in_word
+# define FMINBITS_IN_WORD fminbits_in_word
+#else
+# define NEAREST_POW2 nearest_pow2_
+# define MINBITS_IN_WORD minbits_in_word_
+# define FMINBITS_IN_WORD fminbits_in_word_
+#endif
+
+void NEAREST_POW2(union ieee754_double *xval, unsigned int *pow)
+{
+
+ if (xval->d != 0.0)
+ *pow = xval->ieee.exponent - IEEE754_DOUBLE_BIAS;
+ else {
+ printf("Warning : NEAREST_POW2 ne traite que des reels > 0.0\n");
+ *pow = 0;
+ }
+
+}
+
+void MINBITS_IN_WORD(int *nval, unsigned int *nbit)
+{
+ union ieee754_double xval;
+ int ival = *nval;
+
+ /* ne fonctionne qu'avec des entiers non signés */
+ if (ival-- < 0){
+ printf("Warning : MINBITS_IN_WORD ne traite que des entiers POSITIFS.\n");
+ *nbit = -1;
+ return;
+ } else
+ if (ival > 0){
+ xval.d = (double)ival;
+ NEAREST_POW2(&xval,nbit);
+ (*nbit)++;
+ } else
+ *nbit = 0 ;
+
+}
+
+int FMINBITS_IN_WORD(int *nval)
+{
+ union ieee754_double xval;
+ int ival = *nval;
+ unsigned int nbit;
+
+ /* ne fonctionne qu'avec des entiers non signés */
+ if (ival < 0){
+ printf("Warning : MINBITS_IN_WORD ne traite que des entiers POSITIFS.\n");
+ return -1;
+ } else {
+ if (ival > 0){
+ xval.d = (double)ival;
+ NEAREST_POW2(&xval,&nbit);
+ nbit++;
+ } else
+ nbit = 0 ;
+ return nbit;
+ }
+}
+
+/* int main(){ */
+
+/* double x; */
+/* int i,nbit; */
+/* int exp2; */
+
+/* printf("Reel : "); */
+/* scanf("%lf",&x); */
+
+/* nearest_pow2_((union ieee754_double*)&x,&exp2); */
+
+/* printf("2**%d = %lf est la puissance de 2 la plus proche et inferieure à %lf\n", */
+/* exp2,pow(2.,exp2),x); */
+/* printf("%lf <= %lf <= %lf\n",pow(2.,(double)exp2),x,pow(2.,(double)exp2+1.)); */
+
+/* printf("Entier positif : "); */
+/* scanf("%d",&i); */
+/* minbits_in_word_(&i,&nbit); */
+/* printf("%d valeurs : %d bits (2**%d = %d).\n",i,nbit,nbit,(1<<nbit)); */
+/* } */
diff --git a/LIBTOOLS/lib/COMPRESS/src/searchgrp.f90 b/LIBTOOLS/lib/COMPRESS/src/searchgrp.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5b7aed941c2c7a6386f8a13735f2c53932e8701d
--- /dev/null
+++ b/LIBTOOLS/lib/COMPRESS/src/searchgrp.f90
@@ -0,0 +1,197 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+MODULE MODE_SEARCHGRP
+IMPLICIT NONE
+TYPE SOP_t
+ INTEGER :: NBGRP
+ INTEGER,DIMENSION(:),POINTER :: IBEG
+ INTEGER,DIMENSION(:),POINTER :: IEND
+ INTEGER,DIMENSION(:),POINTER :: VALMIN
+ INTEGER,DIMENSION(:),POINTER :: VALMAX
+END TYPE SOP_t
+
+INTEGER,EXTERNAL :: FMINBITS_IN_WORD
+
+! Private variables
+INTEGER,SAVE, PRIVATE :: IGRP
+INTEGER,DIMENSION(:),ALLOCATABLE,TARGET,PRIVATE :: IBEG,IEND,VALMAX,VALMIN
+INTEGER,PARAMETER, PRIVATE :: MAINSEUIL=8
+INTEGER,SAVE, PRIVATE :: IGRPMAX
+INTEGER,SAVE, PRIVATE :: ICOUNT
+INTEGER,DIMENSION(16),PARAMETER, PRIVATE :: MINELT=(/4,4,4,4,5,5,6,6,7,8,9,11,13,17,26,51/)
+
+! Private routines
+PRIVATE :: RECSEARCH_GRP
+
+CONTAINS
+SUBROUTINE INI_SOPDATA(SOPDATA)
+TYPE(SOP_t), INTENT(OUT) :: SOPDATA
+
+SOPDATA%NBGRP = 0
+NULLIFY(SOPDATA%IBEG)
+NULLIFY(SOPDATA%IEND)
+NULLIFY(SOPDATA%VALMIN)
+NULLIFY(SOPDATA%VALMAX)
+
+END SUBROUTINE INI_SOPDATA
+
+SUBROUTINE RECSEARCH(KTAB,SOPDATA)
+INTEGER,DIMENSION(:) :: KTAB
+TYPE(SOP_t), INTENT(OUT) :: SOPDATA
+
+INTEGER :: NELT
+INTEGER :: GELT,BGELT
+
+IF (ALLOCATED(IBEG)) THEN
+ DEALLOCATE(IBEG,IEND,VALMAX,VALMIN)
+END IF
+
+NELT=SIZE(KTAB)
+ALLOCATE(IBEG(NELT),IEND(NELT),VALMAX(NELT),VALMIN(NELT))
+ICOUNT = 0
+IGRP = 0
+IGRPMAX = NELT
+CALL RECSEARCH_GRP(1,NELT,KTAB,MAINSEUIL)
+GELT = MAXVAL(IEND(1:IGRP)-IBEG(1:IGRP)+1)
+BGELT = FMINBITS_IN_WORD(GELT)
+
+#ifdef DEBUG
+PRINT *,'Routine RECSEARCH_GRP appelee',ICOUNT,'fois.'
+PRINT *,'Nbre de groupes =',IGRP
+PRINT *,'Nbre maxi d''elements dans groupes',GELT
+PRINT *,'Nbre de bits pour coder le nombre d''elements:',BGELT
+#endif
+
+SOPDATA%NBGRP=IGRP
+SOPDATA%IBEG=>IBEG
+SOPDATA%IEND=>IEND
+SOPDATA%VALMIN=>VALMIN
+SOPDATA%VALMAX=>VALMAX
+
+END SUBROUTINE RECSEARCH
+
+RECURSIVE SUBROUTINE RECSEARCH_GRP(IND1,IND2,ITAB,ISEUIL)
+INTEGER, INTENT(IN) :: IND1,IND2,ISEUIL
+INTEGER,DIMENSION(:),INTENT(IN) :: ITAB
+
+INTEGER :: II
+INTEGER :: IMAX,IMIN
+INTEGER :: IVAL
+INTEGER :: nbitcod
+INTEGER :: tmpidx1,tmpidx2
+
+ICOUNT=ICOUNT+1
+
+IF (IGRP == 0) THEN
+ IMIN = MINVAL(ITAB(IND1:IND2))
+ IMAX = MAXVAL(ITAB(IND1:IND2))
+ IGRP = 1
+ VALMIN(IGRP) = IMIN
+ VALMAX(IGRP) = IMAX
+ IBEG(IGRP) = IND1
+ IEND(IGRP) = IND2
+ELSE
+ IMIN = VALMIN(IGRP)
+ IMAX = VALMAX(IGRP)
+END IF
+
+IF (IMAX > IMIN) THEN
+
+ IBEG(IGRP) = IND1
+ IEND(IGRP) = IND1
+ VALMIN(IGRP) = ITAB(IND1)
+ VALMAX(IGRP) = ITAB(IND1)
+
+ DO II=IND1,IND2-1
+ IVAL = ITAB(II+1)
+ IMAX=MAX(VALMAX(IGRP),IVAL)
+ IMIN=MIN(VALMIN(IGRP),IVAL)
+ IF ((IMAX-IMIN)<(2**ISEUIL)) THEN
+ ! II+1 belong to group IGRP
+ IEND(IGRP) = II+1
+ VALMIN(IGRP) = IMIN
+ VALMAX(IGRP) = IMAX
+ ELSE
+ ! Search the created group
+ nbitcod=FMINBITS_IN_WORD(VALMAX(IGRP)-VALMIN(IGRP))
+#ifdef DEBUG
+ PRINT *,'F:(IGRP,IBEG,IEND,MAX,MIN,nbitcod)=',IGRP,',',IBEG(IGRP),',',IEND(IGRP),',',VALMAX(IGRP),',',VALMIN(IGRP),',',nbitcod
+#endif
+ IF (IEND(IGRP)-IBEG(IGRP)>MINELT(nbitcod+1)) THEN
+ IF (nbitcod > 0) THEN
+ tmpidx1=IBEG(IGRP)
+ tmpidx2=IEND(IGRP)
+#ifdef DEBUG
+ PRINT *,'Appel 1 RECSEARCH_GRP (first,last,seuil):',tmpidx1,tmpidx2,nbitcod/2
+#endif
+ CALL RECSEARCH_GRP(tmpidx1,tmpidx2,ITAB,nbitcod/2)
+ END IF
+ ELSE
+ IF (IGRP > 1) THEN
+ nbitcod=FMINBITS_IN_WORD(VALMAX(IGRP-1)-VALMIN(IGRP-1))
+ IMIN=MIN(VALMIN(IGRP-1),VALMIN(IGRP))
+ IMAX=MAX(VALMAX(IGRP-1),VALMAX(IGRP))
+ IF (IEND(IGRP-1)-IBEG(IGRP-1)<=MINELT(nbitcod+1)) THEN
+ IF ((IMAX-IMIN) < 2**15) THEN
+ ! concat IGRP-1 and IGRP
+ IEND(IGRP-1) = IEND(IGRP)
+ VALMIN(IGRP-1) = IMIN
+ VALMAX(IGRP-1) = IMAX
+ IGRP = IGRP-1
+ END IF
+ ELSE
+ IF (FMINBITS_IN_WORD(IMAX-IMIN) <= nbitcod) THEN
+ ! concat IGRP-1 and IGRP
+ IEND(IGRP-1) = IEND(IGRP)
+ VALMIN(IGRP-1) = IMIN
+ VALMAX(IGRP-1) = IMAX
+ IGRP = IGRP-1
+ END IF
+ END IF
+ END IF
+ END IF
+ ! New group is created
+ IGRP = IGRP+1
+ IF (IGRP>IGRPMAX) THEN
+ PRINT *,'ERROR max number of group exceeded !'
+ STOP
+ END IF
+ IBEG(IGRP) = II+1
+ IEND(IGRP) = II+1
+ VALMIN(IGRP) = IVAL
+ VALMAX(IGRP) = IVAL
+ END IF
+ END DO
+#ifdef DEBUG
+ PRINT *,'L:',IGRP,':',VALMAX(IGRP)-VALMIN(IGRP),FMINBITS_IN_WORD(VALMAX(IGRP)-VALMIN(IGRP))
+#endif
+ nbitcod = FMINBITS_IN_WORD(VALMAX(IGRP)-VALMIN(IGRP))
+ IF (IEND(IGRP)-IBEG(IGRP)>= MINELT(nbitcod+1)) THEN
+ IF (nbitcod > 0) THEN
+ tmpidx1=IBEG(IGRP)
+ tmpidx2=IEND(IGRP)
+#ifdef DEBUG
+ PRINT *,'Appel 2 RECSEARCH_GRP (first,last,seuil):',tmpidx1,tmpidx2,nbitcod/2
+#endif
+ CALL RECSEARCH_GRP(tmpidx1,tmpidx2,ITAB,nbitcod/2)
+ END IF
+ END IF
+END IF
+
+END SUBROUTINE RECSEARCH_GRP
+
+END MODULE MODE_SEARCHGRP
+
+SUBROUTINE INVERTCOL(ITAB,KX,KY)
+IMPLICIT NONE
+INTEGER, INTENT(IN) :: KX,KY
+INTEGER,DIMENSION(KX,KY), INTENT(INOUT)::ITAB
+
+ITAB(:,2:KY:2) = ITAB(KX:1:-1,2:KY:2)
+
+END SUBROUTINE INVERTCOL
+
diff --git a/LIBTOOLS/lib/Makefile b/LIBTOOLS/lib/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..8223eb6fd4edf21c26996bdb0e3d3f13de7f157d
--- /dev/null
+++ b/LIBTOOLS/lib/Makefile
@@ -0,0 +1,32 @@
+GRIB_DIR=$(wildcard gribex*)
+SUBDIRS = NEWLFI COMPRESS MPIvide RAD2 SURCOUCHE vis5d
+.PHONY: subdirs $(SUBDIRS) $(GRIB_DIR)
+
+ifndef ARCH
+VALID_ARCH=$(subst ../conf/config.,,$(wildcard ../conf/config.*))
+dummy %:
+ @echo "ERROR : ARCH variable is not set !";echo
+ @echo "Please, choose one of these statements then try again :";echo " "
+ @for i in $(VALID_ARCH); do echo export ARCH=$$i; done
+
+else
+subdirs: $(SUBDIRS) $(GRIB_DIR)
+
+$(SUBDIRS):
+ $(MAKE) -C $@
+
+$(GRIB_DIR):
+ @echo "==========================================================================="
+ @echo "GRIB library : please go into $@ directory and see README files"
+ @echo " in order to generate manually the GRIB library."
+ @echo "==========================================================================="
+
+clean distclean:
+ @for dir in $(SUBDIRS) $(GRIB_DIR); do \
+ $(MAKE) -C $$dir $@; \
+ done
+
+endif
+
+
+
diff --git a/LIBTOOLS/lib/NEWLFI/Rules.LXifort b/LIBTOOLS/lib/NEWLFI/Rules.LXifort
new file mode 100644
index 0000000000000000000000000000000000000000..08ab3a6b64af3bafe0a930100381b175c3b8daab
--- /dev/null
+++ b/LIBTOOLS/lib/NEWLFI/Rules.LXifort
@@ -0,0 +1,5 @@
+F77FLAGS += -O3 -assume byterecl
+CFLAGS += -O2
+CPPFLAGS += -DLINUX -DSWAPIO
+
+OBJS = NEWLFI_ALL.o poub.o fswap8buff.o
diff --git a/LIBTOOLS/lib/vis5d/Makefile b/LIBTOOLS/lib/vis5d/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..15f4d22fb0cf025025cbcaa2da96deefdfc02b26
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/Makefile
@@ -0,0 +1,33 @@
+DIR_OBJ = ./$(ARCH)
+
+VPATH = src:$(DIR_OBJ)
+DIR_CONF:=$(shell pwd|sed -e 's/lib\/.*/conf/')
+
+include $(DIR_CONF)/config.$(ARCH)
+include Rules.$(ARCH)
+
+
+OBJS = binio.o v5d.o
+
+# The following are dependencies generated by running makedepend:
+
+all : libv5d.a
+
+libv5d.a : $(DIR_OBJ)/.dummy $(OBJS)
+ cd $(DIR_OBJ) ; $(AR) crv $@ $(OBJS)
+
+binio.o: binio.c binio.h
+ $(CC) -c $(CFLAGS) $< -o $(DIR_OBJ)/$@
+v5d.o: v5d.c binio.h v5d.h vis5d.h
+ $(CC) -c $(CFLAGS) $< -o $(DIR_OBJ)/$@
+
+$(DIR_OBJ)/.dummy :
+ mkdir -p $(DIR_OBJ)
+ @touch $(DIR_OBJ)/.dummy
+tar :
+ tar cvf vis5d.tar Makefile Rules* binio.c binio.h v5d.c v5d.h vis5d.h
+clean :
+ (if [ -d $(DIR_OBJ) ] ; then cd $(DIR_OBJ) ; rm -f $(OBJS); fi)
+
+distclean:
+ rm -rf $(DIR_OBJ)
diff --git a/LIBTOOLS/lib/vis5d/Makefile.v5d b/LIBTOOLS/lib/vis5d/Makefile.v5d
new file mode 100644
index 0000000000000000000000000000000000000000..f32bae72c41e8e71f983cdcaff5e0ce7d02dcfba
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/Makefile.v5d
@@ -0,0 +1,23 @@
+CC = cc
+#CFLAGS = -c -O2 -DUNDERSCORE -DLITTLE
+CFLAGS = -c -O2 -DUNDERSCORE -DVPP
+
+OBJETS = binio.o v5d.o
+
+# The following are dependencies generated by running makedepend:
+
+all : libv5d.a
+
+libv5d.a : $(OBJETS)
+ ar crv $@ $?
+
+binio.o: binio.c binio.h
+ $(CC) $(CFLAGS) binio.c
+v5d.o: binio.h v5d.h vis5d.h v5d.c
+ $(CC) $(CFLAGS) v5d.c
+
+tar :
+ tar cvf libvis5d.tar Makefile binio.c binio.h v5d.c v5d.h vis5d.h
+clean :
+ rm -rf libv5d.a $(OBJETS)
+
diff --git a/LIBTOOLS/lib/vis5d/Rules.HPf90 b/LIBTOOLS/lib/vis5d/Rules.HPf90
new file mode 100644
index 0000000000000000000000000000000000000000..b13568dfe3d5e166dd955a3fd066f8fb770e50a5
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/Rules.HPf90
@@ -0,0 +1,3 @@
+#CFLAGS += -DUNDERSCORE -DVPP
+#CFLAGS += -DUNDERSCORE -DLITTLE
+CFLAGS += -DUNDERSCORE
diff --git a/LIBTOOLS/lib/vis5d/Rules.LXNAGf95 b/LIBTOOLS/lib/vis5d/Rules.LXNAGf95
new file mode 100644
index 0000000000000000000000000000000000000000..b13568dfe3d5e166dd955a3fd066f8fb770e50a5
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/Rules.LXNAGf95
@@ -0,0 +1,3 @@
+#CFLAGS += -DUNDERSCORE -DVPP
+#CFLAGS += -DUNDERSCORE -DLITTLE
+CFLAGS += -DUNDERSCORE
diff --git a/LIBTOOLS/lib/vis5d/Rules.LXg95 b/LIBTOOLS/lib/vis5d/Rules.LXg95
new file mode 100644
index 0000000000000000000000000000000000000000..ef46668526ad0a4265e8f53af7ccac3e52957677
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/Rules.LXg95
@@ -0,0 +1,7 @@
+#
+# Don't forget -DLITTLE flag for little-endian architecture
+#
+
+#CFLAGS += -DUNDERSCORE -DVPP
+CFLAGS += -DUNDERSCORE -DLITTLE
+
diff --git a/LIBTOOLS/lib/vis5d/Rules.LXgfortran b/LIBTOOLS/lib/vis5d/Rules.LXgfortran
new file mode 100644
index 0000000000000000000000000000000000000000..b13568dfe3d5e166dd955a3fd066f8fb770e50a5
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/Rules.LXgfortran
@@ -0,0 +1,3 @@
+#CFLAGS += -DUNDERSCORE -DVPP
+#CFLAGS += -DUNDERSCORE -DLITTLE
+CFLAGS += -DUNDERSCORE
diff --git a/LIBTOOLS/lib/vis5d/Rules.SGI32 b/LIBTOOLS/lib/vis5d/Rules.SGI32
new file mode 100644
index 0000000000000000000000000000000000000000..0efee43939541db4102f1c14c52a36891d366373
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/Rules.SGI32
@@ -0,0 +1 @@
+CFLAGS += -DUNDERSCORE
diff --git a/LIBTOOLS/lib/vis5d/Rules.VPP b/LIBTOOLS/lib/vis5d/Rules.VPP
new file mode 100644
index 0000000000000000000000000000000000000000..a06bddb6bab9f7b5d08ee666c8ed53facee644fb
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/Rules.VPP
@@ -0,0 +1 @@
+CFLAGS += -DUNDERSCORE -DVPP
diff --git a/LIBTOOLS/lib/vis5d/src/binio.c b/LIBTOOLS/lib/vis5d/src/binio.c
new file mode 100644
index 0000000000000000000000000000000000000000..ee48400550b98a29778f35b8848f516d78582707
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/src/binio.c
@@ -0,0 +1,804 @@
+/* Vis5D version 5.1 */
+
+/*
+Vis5D system for visualizing five dimensional gridded data sets
+Copyright (C) 1990 - 1997 Bill Hibbard, Johan Kellum, Brian Paul,
+Dave Santek, and Andre Battaiola.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+This program 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
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+*/
+
+/*
+ * Functions to do binary I/O of floats, ints.
+ *
+ * >>>> These functions are built on top of Unix I/O functions, not stdio! <<<<
+ *
+ * The file format is assumed to be BIG-ENDIAN.
+ * If this code is compiled with -DLITTLE and executes on a little endian
+ * CPU then byte-swapping will be done.
+ *
+ * If an ANSI compiler is used prototypes and ANSI function declarations
+ * are used. Otherwise use K&R conventions.
+ *
+ * If we're running on a CRAY (8-byte ints and floats), conversions will
+ * be done as needed.
+ */
+
+
+/*
+ * Updates:
+ *
+ * April 13, 1995, brianp
+ * added cray_to_ieee and iee_to_cray array conversion functions.
+ * fixed potential cray bug in write_float4_array function.
+ *
+ */
+
+
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#ifdef _CRAY
+# include <string.h>
+#endif
+#include "binio.h"
+
+
+
+
+/**********************************************************************/
+/****** Byte Flipping *****/
+/**********************************************************************/
+
+
+#define FLIP4( n ) ( (n & 0xff000000) >> 24 \
+ | (n & 0x00ff0000) >> 8 \
+ | (n & 0x0000ff00) << 8 \
+ | (n & 0x000000ff) << 24 )
+
+
+#define FLIP2( n ) (((unsigned short) (n & 0xff00)) >> 8 | (n & 0x00ff) << 8)
+
+
+
+/*
+ * Flip the order of the 4 bytes in an array of 4-byte words.
+ */
+void flip4( const unsigned int *src, unsigned int *dest, int n )
+{
+ int i;
+
+ for (i=0;i<n;i++) {
+ unsigned int tmp = src[i];
+ dest[i] = FLIP4( tmp );
+ }
+}
+
+
+
+/*
+ * Flip the order of the 2 bytes in an array of 2-byte words.
+ */
+void flip2( const unsigned short *src, unsigned short *dest, int n )
+{
+ int i;
+
+ for (i=0;i<n;i++) {
+ unsigned short tmp = src[i];
+ dest[i] = FLIP2( tmp );
+ }
+}
+
+
+#ifdef _CRAY
+/*****************************************************************************
+*
+* The following source code is in the public domain.
+* Specifically, we give to the public domain all rights for future licensing
+* of the source code, all resale rights, and all publishing rights.
+*
+* We ask, but do not require, that the following message be included in all
+* derived works:
+*
+* Portions developed at the National Center for Supercomputing Applications at
+* the University of Illinois at Urbana-Champaign.
+*
+* THE UNIVERSITY OF ILLINOIS GIVES NO WARRANTY, EXPRESSED OR IMPLIED, FOR THE
+* SOFTWARE AND/OR DOCUMENTATION PROVIDED, INCLUDING, WITHOUT LIMITATION,
+* WARRANTY OF MERCHANTABILITY AND WARRANTY OF FITNESS FOR A PARTICULAR PURPOSE
+*
+****************************************************************************/
+
+/** THESE ROUTINES MUST BE COMPILED ON THE CRAY ONLY SINCE THEY **/
+/** REQUIRE 8-BYTES PER C-TYPE LONG **/
+
+/* Cray to IEEE single precision */
+static void c_to_if( long *t, const long *f)
+{
+ if (*f != 0){
+ *t = (((*f & 0x8000000000000000) | /* sign bit */
+ ((((*f & 0x7fff000000000000) >> 48)-16258) << 55)) + /* exp */
+ (((*f & 0x00007fffff000000) +
+ ((*f & 0x0000000000800000) << 1)) << 8)); /* mantissa */
+ }
+ else *t = *f;
+}
+
+
+#define C_TO_IF( T, F ) \
+ if (F != 0) { \
+ T = (((F & 0x8000000000000000) | \
+ ((((F & 0x7fff000000000000) >> 48)-16258) << 55)) + \
+ (((F & 0x00007fffff000000) + \
+ ((F & 0x0000000000800000) << 1)) << 8)); \
+ } \
+ else { \
+ T = F; \
+ }
+
+
+
+/* IEEE single precison to Cray */
+static void if_to_c( long *t, const long *f)
+{
+ if (*f != 0) {
+ *t = (((*f & 0x8000000000000000) |
+ ((*f & 0x7f80000000000000) >> 7) +
+ (16258 << 48)) |
+ (((*f & 0x007fffff00000000) >> 8) | (0x0000800000000000)));
+ if ((*f << 1) == 0) *t = 0;
+ }
+ else *t = *f;
+}
+
+/* T and F must be longs! */
+#define IF_TO_C( T, F ) \
+ if (F != 0) { \
+ T = (((F & 0x8000000000000000) | \
+ ((F & 0x7f80000000000000) >> 7) + \
+ (16258 << 48)) | \
+ (((F & 0x007fffff00000000) >> 8) | (0x0000800000000000))); \
+ if ((F << 1) == 0) T = 0; \
+ } \
+ else { \
+ T = F; \
+ }
+
+
+
+
+/*
+ * Convert an array of Cray 8-byte floats to an array of IEEE 4-byte floats.
+ */
+void cray_to_ieee_array( long *dest, const float *source, int n )
+{
+ long *dst;
+ const long *src;
+ long tmp1, tmp2;
+ int i;
+
+ dst = dest;
+ src = (const long *) source;
+
+ for (i=0;i<n;i+=2) { /* add 1 in case n is odd */
+ c_to_if( &tmp1, &src[i] );
+ c_to_if( &tmp2, &src[i+1] );
+ *dst = (tmp1 & 0xffffffff00000000) | (tmp2 >> 32);
+ dst++;
+ }
+}
+
+
+
+/*
+ * Convert an array of IEEE 4-byte floats to an array of 8-byte Cray floats.
+ */
+void ieee_to_cray_array( float *dest, const long *source, int n )
+{
+ long *dst;
+ const long *src;
+ int i;
+ long ieee;
+
+ src = source;
+ dst = (long *) dest;
+
+ for (i=0;i<n;i++) {
+ /* most significant 4-bytes of ieee contain bit pattern to convert */
+ if ((i&1)==0) {
+ /* get upper half */
+ ieee = src[i/2] & 0xffffffff00000000;
+ }
+ else {
+ /* get lower half */
+ ieee = src[i/2] << 32;
+ }
+ if_to_c( dst, &ieee );
+ dst++;
+ }
+}
+
+
+#endif /*_CRAY*/
+
+
+
+/**********************************************************************/
+/***** Read Functions *****/
+/**********************************************************************/
+
+
+/*
+ * Read a block of bytes.
+ * Input: f - the file descriptor to read from.
+ * b - address of buffer to read into.
+ * n - number of bytes to read.
+ * Return: number of bytes read, 0 if error.
+ */
+int read_bytes( int f, void *b, int n )
+{
+ return read( f, b, n );
+}
+
+
+
+/*
+ * Read an array of 2-byte integers.
+ * Input: f - file descriptor
+ * iarray - address to put integers
+ * n - number of integers to read.
+ * Return: number of integers read.
+ */
+int read_int2_array( int f, short *iarray, int n )
+{
+#ifdef _CRAY
+ int i;
+ signed char *buffer;
+ int nread;
+ buffer = (signed char *) malloc( n * 2 );
+ if (!buffer) return 0;
+ nread = read( f, buffer, n*2 );
+ if (nread<=0) return 0;
+ nread /= 2;
+ for (i=0;i<nread;i++) {
+ /* don't forget about sign extension! */
+ iarray[i] = (buffer[i*2] * 256) | buffer[i*2+1];
+ }
+ free( buffer );
+ return nread;
+#else
+ int nread = read( f, iarray, n*2 );
+ if (nread<=0)
+ return 0;
+#ifdef LITTLE
+ flip2( (const unsigned short *) iarray, (unsigned short *) iarray, nread/2);
+#endif
+ return nread/2;
+#endif
+}
+
+
+
+/*
+ * Read an array of unsigned 2-byte integers.
+ * Input: f - file descriptor
+ * iarray - address to put integers
+ * n - number of integers to read.
+ * Return: number of integers read.
+ */
+int read_uint2_array( int f, unsigned short *iarray, int n )
+{
+#ifdef _CRAY
+ int i;
+ unsigned char *buffer;
+ int nread;
+ buffer = (unsigned char *) malloc( n * 2 );
+ if (!buffer) return 0;
+ nread = read( f, buffer, n*2 );
+ if (nread<=0) return 0;
+ nread /= 2;
+ for (i=0;i<nread;i++) {
+ iarray[i] = (buffer[i*2] << 8) | buffer[i*2+1];
+ }
+ free( buffer );
+ return nread;
+#else
+ int nread = read( f, iarray, n*2 );
+ if (nread<=0)
+ return 0;
+#ifdef LITTLE
+ flip2( iarray, iarray, nread/2 );
+#endif
+ return nread/2;
+#endif
+}
+
+
+
+/*
+ * Read a 4-byte integer.
+ * Input: f - the file descriptor to read from
+ * i - pointer to integer to put result into.
+ * Return: 1 = ok, 0 = error
+ */
+int read_int4( int f, int *i )
+{
+#ifdef LITTLE
+ /* read big endian and convert to little endian */
+ unsigned int n;
+ if (read( f, &n, 4 )==4) {
+ *i = FLIP4( n );
+ return 1;
+ }
+ else {
+ return 0;
+ }
+#else
+ if (read( f, i, 4 )==4) {
+# ifdef _CRAY
+ *i = *i >> 32;
+# endif
+ return 1;
+ }
+ else {
+ return 0;
+ }
+#endif
+}
+
+
+
+/*
+ * Read an array of 4-byte integers.
+ * Input: f - file descriptor
+ * iarray - address to put integers
+ * n - number of integers to read.
+ * Return: number of integers read.
+ */
+int read_int4_array( int f, int *iarray, int n )
+{
+#ifdef _CRAY
+ int j, nread;
+ int *buffer;
+
+ buffer = (int *) malloc( (n+1)*4 );
+ if (!buffer)
+ return 0;
+ nread = read( f, buffer, 4*n );
+ if (nread<=0) {
+ return 0;
+ }
+ nread /= 4;
+
+ for (j=0;j<nread;j++) {
+ if ((j&1)==0) {
+ iarray[j] = buffer[j/2] >> 32;
+ }
+ else {
+ iarray[j] = buffer[j/2] & 0xffffffff;
+ }
+ }
+ free( buffer );
+ return nread;
+#else
+ int nread = read( f, iarray, 4*n );
+ if (nread<=0)
+ return 0;
+# ifdef LITTLE
+ flip4( (const unsigned int *) iarray, (unsigned int *) iarray, nread/4 );
+# endif
+ return nread/4;
+#endif
+}
+
+
+
+/*
+ * Read a 4-byte IEEE float.
+ * Input: f - the file descriptor to read from.
+ * x - pointer to float to put result into.
+ * Return: 1 = ok, 0 = error
+ */
+int read_float4( int f, float *x )
+{
+#ifdef _CRAY
+ long buffer = 0;
+
+ if ( read( f, &buffer, 4 )==4 ) {
+ /* convert IEEE float (buffer) to Cray float (x) */
+ if_to_c( (long *) x, &buffer );
+ return 1;
+ }
+ return 0;
+#else
+# ifdef LITTLE
+ unsigned int n, *iptr;
+ if (read( f, &n, 4 )==4) {
+ iptr = (unsigned int *) x;
+ *iptr = FLIP4( n );
+ return 1;
+ }
+ else {
+ return 0;
+ }
+# else
+ if (read( f, x, 4 )==4) {
+ return 1;
+ }
+ else {
+ return 0;
+ }
+# endif
+#endif
+}
+
+
+
+/*
+ * Read an array of 4-byte IEEE floats.
+ * Input: f - file descriptor
+ * x - address to put floats
+ * n - number of floats to read.
+ * Return: number of floats read.
+ */
+int read_float4_array( int f, float *x, int n )
+{
+#ifdef _CRAY
+ /* read IEEE floats into buffer, then convert to Cray format */
+ long *buffer;
+ int i, nread;
+
+ buffer = (long *) malloc( (n+1) * 4 );
+ if (!buffer) return 0;
+ nread = read( f, buffer, n*4 );
+ if (nread<=0) return 0;
+ nread /= 4;
+ ieee_to_cray_array( x, buffer, nread );
+ free( buffer );
+ return nread;
+#else
+ int nread = read( f, x, 4*n );
+ if (nread<=0)
+ return 0;
+#ifdef LITTLE
+ flip4( (const unsigned int *) x, (unsigned int*) x, nread/4 );
+#endif
+ return nread/4;
+#endif
+}
+
+
+
+/*
+ * Read a block of memory.
+ * Input: f - file descriptor
+ * data - address of first byte
+ * elements - number of elements to read
+ * elsize - size of each element to read (1, 2 or 4)
+ * Return: number of elements written
+ */
+int read_block( int f, void *data, int elements, int elsize )
+{
+ if (elsize==1) {
+ return read( f, data, elements );
+ }
+ else if (elsize==2) {
+#ifdef LITTLE
+ int n;
+ n = read( f, data, elements*2 ) / 2;
+ if (n==elements) {
+ flip2( (const unsigned short *) data, (unsigned short *) data,
+ elements );
+ }
+ return n;
+#else
+ return read( f, data, elements*2 ) / 2;
+#endif
+ }
+ else if (elsize==4) {
+#ifdef LITTLE
+ int n;
+ n = read( f, data, elements*4 ) / 4;
+ if (n==elements) {
+ flip4( (const unsigned int *) data, (unsigned int *) data, elements );
+ }
+ return n;
+#else
+ return read( f, data, elements*4 ) / 4;
+#endif
+ }
+ else {
+ printf("Fatal error in read_block(): bad elsize (%d)\n", elsize );
+ abort();
+ }
+ return 0;
+}
+
+
+
+
+/**********************************************************************/
+/***** Write Functions *****/
+/**********************************************************************/
+
+
+
+/*
+ * Write a block of bytes.
+ * Input: f - the file descriptor to write to.
+ * b - address of buffer to write.
+ * n - number of bytes to write.
+ * Return: number of bytes written, 0 if error.
+ */
+int write_bytes( int f, const void *b, int n )
+{
+ return write( f, b, n );
+}
+
+
+
+
+/*
+ * Write an array of 2-byte integers.
+ * Input: f - file descriptor
+ * iarray - address to put integers
+ * n - number of integers to write.
+ * Return: number of integers written
+ */
+int write_int2_array( int f, const short *iarray, int n )
+{
+#ifdef _CRAY
+ printf("write_int2_array not implemented!\n");
+ exit(1);
+#else
+ int nwritten;
+#ifdef LITTLE
+ flip2( (const unsigned short *) iarray, (unsigned short *) iarray, n );
+#endif
+ nwritten = write( f, iarray, 2*n );
+#ifdef LITTLE
+ flip2( (const unsigned short *) iarray, (unsigned short *) iarray, n );
+#endif
+ if (nwritten<=0)
+ return 0;
+ return nwritten/2;
+#endif
+}
+
+
+
+/*
+ * Write an array of 2-byte unsigned integers.
+ * Input: f - file descriptor
+ * iarray - address to put integers
+ * n - number of integers to write.
+ * Return: number of integers written
+ */
+int write_uint2_array( int f, const unsigned short *iarray, int n )
+{
+#ifdef _CRAY
+ int i, nwritten;
+ unsigned char *buffer;
+ buffer = (unsigned char *) malloc( 2*n );
+ if (!buffer) return 0;
+ for (i=0;i<n;i++) {
+ buffer[i*2] = (iarray[i] >> 8) & 0xff;
+ buffer[i*2+1] = iarray[i] & 0xff;
+ }
+ nwritten = write( f, buffer, 2*n );
+ free( buffer );
+ if (nwritten<=0)
+ return 0;
+ else
+ return nwritten/2;
+#else
+ int nwritten;
+#ifdef LITTLE
+ flip2( iarray, (unsigned short *) iarray, n );
+#endif
+ nwritten = write( f, iarray, 2*n );
+#ifdef LITTLE
+ flip2( iarray, (unsigned short *) iarray, n );
+#endif
+ if (nwritten<=0)
+ return 0;
+ else
+ return nwritten/2;
+#endif
+}
+
+
+
+/*
+ * Write a 4-byte integer.
+ *Input: f - the file descriptor
+ * i - the integer
+ * Return: 1 = ok, 0 = error
+ */
+int write_int4( int f, int i )
+{
+#ifdef _CRAY
+ i = i << 32;
+ return write( f, &i, 4 ) > 0;
+#else
+# ifdef LITTLE
+ i = FLIP4( i );
+# endif
+ return write( f, &i, 4 ) > 0;
+#endif
+}
+
+
+
+/*
+ * Write an array of 4-byte integers.
+ * Input: f - the file descriptor
+ * i - the array of ints
+ * n - the number of ints in array
+ * Return: number of integers written.
+ */
+int write_int4_array( int f, const int *i, int n )
+{
+#ifdef _CRAY
+ int j, nwritten;
+ char *buf, *b, *ptr;
+
+ b = buf = (char *) malloc( n*4 + 8 );
+ if (!b)
+ return 0;
+ ptr = (char *) i;
+ for (j=0;j<n;j++) {
+ ptr += 4; /* skip upper 4 bytes */
+ *b++ = *ptr++;
+ *b++ = *ptr++;
+ *b++ = *ptr++;
+ *b++ = *ptr++;
+ }
+ nwritten = write( f, buf, 4*n );
+ free( buf );
+ if (nwritten<=0)
+ return 0;
+ else
+ return nwritten / 4;
+#else
+# ifdef LITTLE
+ int nwritten;
+ flip4( (const unsigned int *) i, (unsigned int *) i, n );
+ nwritten = write( f, i, 4*n );
+ flip4( (const unsigned int *) i, (unsigned int *) i, n );
+ if (nwritten<=0)
+ return 0;
+ else
+ return nwritten / 4;
+# else
+ return write( f, i, 4*n ) / 4;
+# endif
+#endif
+}
+
+
+
+/*
+ * Write a 4-byte IEEE float.
+ * Input: f - the file descriptor
+ * x - the float
+ * Return: 1 = ok, 0 = error
+ */
+int write_float4( int f, float x )
+{
+#ifdef _CRAY
+ char buffer[8];
+ c_to_if( (long *) buffer, (const long *) &x );
+ return write( f, buffer, 4 ) > 0;
+#else
+# ifdef LITTLE
+ float y;
+ unsigned int *iptr = (unsigned int *) &y, temp;
+ y = (float) x;
+ temp = FLIP4( *iptr );
+ return write( f, &temp, 4 ) > 0;
+# else
+ float y;
+ y = (float) x;
+ return write( f, &y, 4 ) > 0;
+# endif
+#endif
+}
+
+
+
+/*
+ * Write an array of 4-byte IEEE floating point numbers.
+ * Input: f - the file descriptor
+ * x - the array of floats
+ * n - number of floats in array
+ * Return: number of float written.
+ */
+int write_float4_array( int f, const float *x, int n )
+{
+#ifdef _CRAY
+ /* convert cray floats to IEEE and put into buffer */
+ int nwritten;
+ long *buffer;
+ buffer = (long *) malloc( n*4 + 8 );
+ if (!buffer)
+ return 0;
+ cray_to_ieee_array( buffer, x, n );
+ nwritten = write( f, buffer, 4*n );
+ free( buffer );
+ if (nwritten<=0)
+ return 0;
+ else
+ return nwritten / 4;
+#else
+# ifdef LITTLE
+ int nwritten;
+ flip4( (const unsigned int *) x, (unsigned int *) x, n );
+ nwritten = write( f, x, 4*n );
+ flip4( (const unsigned int *) x, (unsigned int *) x, n );
+ if (nwritten<=0)
+ return 0;
+ else
+ return nwritten / 4;
+# else
+ return write( f, x, 4*n ) / 4;
+# endif
+#endif
+}
+
+
+
+/*
+ * Write a block of memory.
+ * Input: f - file descriptor
+ * data - address of first byte
+ * elements - number of elements to write
+ * elsize - size of each element to write (1, 2 or 4)
+ * Return: number of elements written
+ */
+int write_block( int f, const void *data, int elements, int elsize )
+{
+ if (elsize==1) {
+ return write( f, data, elements );
+ }
+ else if (elsize==2) {
+#ifdef LITTLE
+ int n;
+ flip2( (const unsigned short *) data, (unsigned short *) data, elements);
+ n = write( f, data, elements*2 ) / 2;
+ flip2( (const unsigned short *) data, (unsigned short *) data, elements);
+ return n;
+#else
+ return write( f, data, elements*2 ) / 2;
+#endif
+ }
+ else if (elsize==4) {
+#ifdef LITTLE
+ int n;
+ flip4( (const unsigned int *) data, (unsigned int *) data, elements );
+ n = write( f, data, elements*4 ) / 4;
+ flip4( (const unsigned int *) data, (unsigned int *) data, elements );
+ return n;
+#else
+ return write( f, data, elements*4 ) / 4;
+#endif
+ }
+ else {
+ printf("Fatal error in write_block(): bad elsize (%d)\n", elsize );
+ abort();
+ }
+ return 0;
+}
diff --git a/LIBTOOLS/lib/vis5d/src/binio.h b/LIBTOOLS/lib/vis5d/src/binio.h
new file mode 100644
index 0000000000000000000000000000000000000000..ce74f7cb09f0ab42c526271ab26e38ed835f95d6
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/src/binio.h
@@ -0,0 +1,107 @@
+/* Vis5D version 5.1 */
+
+/*
+Vis5D system for visualizing five dimensional gridded data sets
+Copyright (C) 1990 - 1997 Bill Hibbard, Brian Paul, Dave Santek,
+and Andre Battaiola.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+This program 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
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+*/
+
+
+/*
+ * Functions to do binary I/O of floats, ints, etc. with byte swapping
+ * as needed.
+ */
+
+
+#ifndef BINIO_H
+#define BINIO_H
+
+
+/* Include files which define SEEK_SET, O_RD_ONLY, etc. */
+/* and prototype open(), close(), lseek(), etc. */
+#include <unistd.h>
+#include <fcntl.h>
+
+
+
+extern void flip4( const unsigned int *src, unsigned int *dest, int n );
+
+extern void flip2( const unsigned short *src, unsigned short *dest, int n );
+
+
+/* Modif pour prendre en compte la FUJI avec des entiers 32 bits
+ et des reels 64 bits. Or on a :
+
+ sizeof(int) = 4
+ sizeof(long) = 4
+ sizeof(long long) = 8
+ sizeof(float) = 4
+ sizeof(double) = 8
+*/
+
+
+#ifdef _CRAY
+ extern void cray_to_ieee_array( long *dest, const float *source, int n );
+ extern void ieee_to_cray_array( float *dest, const long *source, int n );
+#endif
+
+
+/**********************************************************************/
+/***** Read Functions *****/
+/**********************************************************************/
+
+
+extern int read_bytes( int f, void *b, int n );
+
+extern int read_int2_array( int f, short *iarray, int n );
+
+extern int read_uint2_array( int f, unsigned short *iarray, int n );
+
+extern int read_int4( int f, int *i );
+
+extern int read_int4_array( int f, int *iarray, int n );
+
+extern int read_float4( int f, float *x );
+
+extern int read_float4_array( int f, float *x, int n );
+
+extern int read_block( int f, void *data, int elements, int elsize );
+
+
+
+/**********************************************************************/
+/***** Write Functions *****/
+/**********************************************************************/
+
+
+extern int write_bytes( int f, const void *b, int n );
+
+extern int write_int2_array( int f, const short *iarray, int n );
+
+extern int write_uint2_array( int f, const unsigned short *iarray, int n );
+
+extern int write_int4( int f, int i );
+
+extern int write_int4_array( int f, const int *iarray, int n );
+
+extern int write_float4( int f, float x );
+
+extern int write_float4_array( int f, const float *x, int n );
+
+extern int write_block( int f, const void *data, int elements, int elsize );
+
+#endif
diff --git a/LIBTOOLS/lib/vis5d/src/v5d.c b/LIBTOOLS/lib/vis5d/src/v5d.c
new file mode 100644
index 0000000000000000000000000000000000000000..814a680ef25ae99ecf5a1135fb5a1cbc78bc9562
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/src/v5d.c
@@ -0,0 +1,3150 @@
+/* v5d.c */
+
+/* Vis5D version 5.1 */
+
+/*
+Vis5D system for visualizing five dimensional gridded data sets
+Copyright (C) 1990 - 1997 Bill Hibbard, Johan Kellum, Brian Paul,
+Dave Santek, and Andre Battaiola.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+This program 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
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+*/
+
+
+/* this should be updated when the file version changes */
+#define FILE_VERSION "4.3"
+
+
+
+/*
+ * New grid file format for VIS-5D:
+ *
+ * The header is a list of tagged items. Each item has 3 parts:
+ * 1. A tag which is a 4-byte integer identifying the type of item.
+ * 2. A 4-byte integer indicating how many bytes of data follow.
+ * 3. The binary data.
+ *
+ * If we need to add new information to a file header we just create a
+ * new tag and add the code to read/write the information.
+ *
+ * If we're reading a header and find an unknown tag, we can use the
+ * length field to skip ahead to the next tag. Therefore, the file
+ * format is forward (and backward) compatible.
+ *
+ * Grid data is stored as either:
+ * 1-byte unsigned integers (255=missing)
+ * 2-byte unsigned integers (65535=missing)
+ * 4-byte IEEE floats ( >1.0e30 = missing)
+ *
+ * All numeric values are stored in big endian order. All floating point
+ * values are in IEEE format.
+ */
+
+
+
+/*
+ * Updates:
+ *
+ * April 13, 1995, brianp
+ * finished Cray support for 2-byte and 4-byte compress modes
+ */
+
+
+
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include "binio.h"
+#include "v5d.h"
+#include "vis5d.h"
+#ifndef SEEK_SET
+# define SEEK_SET 0
+#endif
+#ifndef SEEK_CUR
+# define SEEK_CUR 1
+#endif
+#ifndef SEEK_END
+# define SEEK_END 2
+#endif
+
+
+
+/*
+ * Currently defined tags:
+ * Note: the notation a[i] doesn't mean a is an array of i elements,
+ * rather it just refers to the ith element of a[].
+ *
+ * Tags marked as PHASED OUT should be readable but are no longer written.
+ * Old tag numbers can't be reused!
+ *
+ */
+
+
+/* TAG NAME VALUE DATA (comments) */
+/*----------------------------------------------------------------------*/
+#define TAG_ID 0x5635440a /* hex encoding of "V5D\n" */
+
+/* general stuff 1000+ */
+#define TAG_VERSION 1000 /* char*10 FileVersion */
+#define TAG_NUMTIMES 1001 /* int*4 NumTimes */
+#define TAG_NUMVARS 1002 /* int*4 NumVars */
+#define TAG_VARNAME 1003 /* int*4 var; char*10 VarName[var] */
+
+#define TAG_NR 1004 /* int*4 Nr */
+#define TAG_NC 1005 /* int*4 Nc */
+#define TAG_NL 1006 /* int*4 Nl (Nl for all vars) */
+#define TAG_NL_VAR 1007 /* int*4 var; int*4 Nl[var] */
+#define TAG_LOWLEV_VAR 1008 /* int*4 var; int*4 LowLev[var] */
+
+#define TAG_TIME 1010 /* int*4 t; int*4 TimeStamp[t] */
+#define TAG_DATE 1011 /* int*4 t; int*4 DateStamp[t] */
+
+#define TAG_MINVAL 1012 /* int*4 var; real*4 MinVal[var] */
+#define TAG_MAXVAL 1013 /* int*4 var; real*4 MaxVal[var] */
+
+#define TAG_COMPRESS 1014 /* int*4 CompressMode; (#bytes/grid)*/
+
+#define TAG_UNITS 1015 /* int *4 var; char*20 Units[var] */
+
+/* vertical coordinate system 2000+ */
+#define TAG_VERTICAL_SYSTEM 2000 /* int*4 VerticalSystem */
+#define TAG_VERT_ARGS 2100 /* int*4 n; real*4 VertArgs[0..n-1]*/
+
+#define TAG_BOTTOMBOUND 2001 /* real*4 BottomBound (PHASED OUT) */
+#define TAG_LEVINC 2002 /* real*4 LevInc (PHASED OUT) */
+#define TAG_HEIGHT 2003 /* int*4 l; real*4 Height[l] (PHASED OUT) */
+
+
+/* projection 3000+ */
+#define TAG_PROJECTION 3000 /* int*4 projection: */
+ /* 0 = generic linear */
+ /* 1 = cylindrical equidistant */
+ /* 2 = Lambert conformal/Polar Stereo */
+ /* 3 = rotated equidistant */
+#define TAG_PROJ_ARGS 3100 /* int *4 n; real*4 ProjArgs[0..n-1] */
+
+#define TAG_NORTHBOUND 3001 /* real*4 NorthBound (PHASED OUT) */
+#define TAG_WESTBOUND 3002 /* real*4 WestBound (PHASED OUT) */
+#define TAG_ROWINC 3003 /* real*4 RowInc (PHASED OUT) */
+#define TAG_COLINC 3004 /* real*4 ColInc (PHASED OUT) */
+#define TAG_LAT1 3005 /* real*4 Lat1 (PHASED OUT) */
+#define TAG_LAT2 3006 /* real*4 Lat2 (PHASED OUT) */
+#define TAG_POLE_ROW 3007 /* real*4 PoleRow (PHASED OUT) */
+#define TAG_POLE_COL 3008 /* real*4 PoleCol (PHASED OUT) */
+#define TAG_CENTLON 3009 /* real*4 CentralLon (PHASED OUT) */
+#define TAG_CENTLAT 3010 /* real*4 CentralLat (PHASED OUT) */
+#define TAG_CENTROW 3011 /* real*4 CentralRow (PHASED OUT) */
+#define TAG_CENTCOL 3012 /* real*4 CentralCol (PHASED OUT) */
+#define TAG_ROTATION 3013 /* real*4 Rotation (PHASED OUT) */
+
+
+#define TAG_END 9999
+
+
+
+
+
+
+/**********************************************************************/
+/***** Miscellaneous Functions *****/
+/**********************************************************************/
+
+
+float pressure_to_height(float pressure)
+{
+ return (float) DEFAULT_LOG_EXP * log((double) pressure / DEFAULT_LOG_SCALE);
+}
+
+float height_to_pressure(float height)
+{
+ return (float) DEFAULT_LOG_SCALE * exp((double) height / DEFAULT_LOG_EXP);
+}
+
+
+/*
+ * Return current file position.
+ * Input: f - file descriptor
+ */
+static off_t ltell( int f )
+{
+ return lseek( f, 0, SEEK_CUR );
+}
+
+
+/*
+ * Copy up to maxlen characters from src to dst stopping upon whitespace
+ * in src. Terminate dst with null character.
+ * Return: length of dst.
+ */
+static int copy_string2( char *dst, const char *src, int maxlen )
+{
+ int i;
+
+ for (i=0;i<maxlen;i++) dst[i] = src[i];
+ for (i=maxlen-1; i>=0; i--) {
+ if (dst[i]==' ' || i==maxlen-1) dst[i] = 0;
+ else break;
+ }
+ return strlen(dst);
+}
+
+
+
+/*
+ * Copy up to maxlen characters from src to dst stopping upon whitespace
+ * in src. Terminate dst with null character.
+ * Return: length of dst.
+ */
+static int copy_string( char *dst, const char *src, int maxlen )
+{
+ int i;
+
+ for (i=0;i<maxlen;i++) {
+ if (src[i]==' ' || i==maxlen-1) {
+ dst[i] = 0;
+ break;
+ }
+ else {
+ dst[i] = src[i];
+ }
+ }
+ return i;
+}
+
+
+
+/*
+ * Convert a date from YYDDD format to days since Jan 1, 1900.
+ */
+int v5dYYDDDtoDays( int yyddd )
+{
+ int iy, id, idays;
+
+ iy = yyddd / 1000;
+ id = yyddd - 1000*iy;
+ if (iy < 50) iy += 100; /* WLH 31 July 96 << 31 Dec 99 */
+ idays = 365*iy + (iy-1)/4 + id;
+
+ return idays;
+}
+
+
+/*
+ * Convert a time from HHMMSS format to seconds since midnight.
+ */
+int v5dHHMMSStoSeconds( int hhmmss )
+{
+ int h, m, s;
+
+ h = hhmmss / 10000;
+ m = (hhmmss / 100) % 100;
+ s = hhmmss % 100;
+
+ return s + m*60 + h*60*60;
+}
+
+
+
+/*
+ * Convert a day since Jan 1, 1900 to YYDDD format.
+ */
+int v5dDaysToYYDDD( int days )
+{
+ int iy, id, iyyddd;
+
+ iy = (4*days)/1461;
+ id = days-(365*iy+(iy-1)/4);
+ if (iy > 99) iy = iy - 100; /* WLH 31 July 96 << 31 Dec 99 */
+ /* iy = iy + 1900; is the right way to fix this, but requires
+ changing all places where dates are printed - procrastinate */
+ iyyddd = iy*1000+id;
+
+ return iyyddd;
+}
+
+
+/*
+ * Convert a time in seconds since midnight to HHMMSS format.
+ */
+int v5dSecondsToHHMMSS( int seconds )
+{
+ int hh, mm, ss;
+
+ hh = seconds / (60*60);
+ mm = (seconds / 60) % 60;
+ ss = seconds % 60;
+ return hh*10000 + mm * 100 + ss;
+}
+
+
+
+
+void v5dPrintStruct( const v5dstruct *v )
+{
+ static char day[7][10] = { "Sunday", "Monday", "Tuesday", "Wednesday",
+ "Thursday", "Friday", "Saturday" };
+ int time, var, i;
+ int maxnl;
+
+ maxnl = 0;
+ for (var=0;var<v->NumVars;var++) {
+ if (v->Nl[var]+v->LowLev[var]>maxnl) {
+ maxnl = v->Nl[var]+v->LowLev[var];
+ }
+ }
+
+ if (v->FileFormat==0) {
+ if (v->FileVersion[0] == 0) {
+ printf("File format: v5d version: (4.0 or 4.1)\n");
+ }
+ else {
+ printf("File format: v5d version: %s\n", v->FileVersion);
+ }
+ }
+ else {
+ printf("File format: comp5d (VIS-5D 3.3 or older)\n");
+ }
+
+ if (v->CompressMode==1) {
+ printf("Compression: 1 byte per gridpoint.\n");
+ }
+ else {
+ printf("Compression: %d bytes per gridpoint.\n", v->CompressMode);
+ }
+ printf("header size=%d\n", v->FirstGridPos);
+ printf("sizeof(v5dstruct)=%d\n", sizeof(v5dstruct) );
+ printf("\n");
+
+ printf("NumVars = %d\n", v->NumVars );
+
+ printf("Var Name Units Rows Cols Levels LowLev MinVal MaxVal\n");
+ for (var=0;var<v->NumVars;var++) {
+ printf("%3d %-10s %-10s %3d %3d %3d %3d",
+ var+1, v->VarName[var], v->Units[var],
+ v->Nr, v->Nc, v->Nl[var], v->LowLev[var] );
+ if (v->MinVal[var] > v->MaxVal[var]) {
+ printf(" MISSING MISSING\n");
+ }
+ else {
+ printf(" %-12g %-12g\n", v->MinVal[var], v->MaxVal[var] );
+ }
+ }
+
+ printf("\n");
+
+ printf("NumTimes = %d\n", v->NumTimes );
+ printf("Step Date(YYDDD) Time(HH:MM:SS) Day\n");
+ for (time=0;time<v->NumTimes;time++) {
+ int i = v->TimeStamp[time];
+ printf("%3d %05d %5d:%02d:%02d %s\n",
+ time+1,
+ v->DateStamp[time],
+ i/10000, (i/100)%100, i%100,
+ day[ v5dYYDDDtoDays(v->DateStamp[time]) % 7 ]);
+ }
+ printf("\n");
+
+ switch (v->VerticalSystem) {
+ case 0:
+ printf("Generic linear vertical coordinate system:\n");
+ printf("\tBottom Bound: %f\n", v->VertArgs[0] );
+ printf("\tIncrement between levels: %f\n", v->VertArgs[1] );
+ break;
+ case 1:
+ printf("Equally spaced levels in km:\n");
+ printf("\tBottom Bound: %f\n", v->VertArgs[0] );
+ printf("\tIncrement: %f\n", v->VertArgs[1] );
+ break;
+ case 2:
+ printf("Unequally spaced levels in km:\n");
+ printf("Level\tHeight(km)\n");
+ for (i=0;i<maxnl;i++) {
+ printf("%3d %10.3f\n", i+1, v->VertArgs[i] );
+ }
+ break;
+ case 3:
+ printf("Unequally spaced levels in mb:\n");
+ printf("Level\tPressure(mb)\n");
+ for (i=0;i<maxnl;i++) {
+ printf("%3d %10.3f\n", i+1, height_to_pressure(v->VertArgs[i]) );
+ }
+ break;
+ default:
+ printf("Bad VerticalSystem value: %d\n", v->VerticalSystem );
+ }
+ printf("\n");
+
+ switch (v->Projection) {
+ case 0:
+ printf("Generic linear projection:\n");
+ printf("\tNorth Boundary: %f\n", v->ProjArgs[0] );
+ printf("\tWest Boundary: %f\n", v->ProjArgs[1] );
+ printf("\tRow Increment: %f\n", v->ProjArgs[2] );
+ printf("\tColumn Increment: %f\n", v->ProjArgs[3] );
+ break;
+ case 1:
+ printf("Cylindrical Equidistant projection:\n");
+ printf("\tNorth Boundary: %f degrees\n", v->ProjArgs[0] );
+ printf("\tWest Boundary: %f degrees\n", v->ProjArgs[1] );
+ printf("\tRow Increment: %f degrees\n", v->ProjArgs[2] );
+ printf("\tColumn Increment: %f degrees\n", v->ProjArgs[3] );
+/*
+ printf("\tSouth Boundary: %f degrees\n",
+ v->NorthBound - v->RowInc * (v->Nr-1) );
+ printf("\tEast Boundary: %f degrees\n",
+ v->WestBound - v->ColInc * (v->Nc-1) );
+*/
+ break;
+ case 2:
+ printf("Lambert Conformal projection:\n");
+ printf("\tStandard Latitude 1: %f\n", v->ProjArgs[0] );
+ printf("\tStandard Latitude 2: %f\n", v->ProjArgs[1] );
+ printf("\tNorth/South Pole Row: %f\n", v->ProjArgs[2] );
+ printf("\tNorth/South Pole Column: %f\n", v->ProjArgs[3] );
+ printf("\tCentral Longitude: %f\n", v->ProjArgs[4] );
+ printf("\tColumn Increment: %f km\n", v->ProjArgs[5] );
+ break;
+ case 3:
+ printf("Stereographic:\n");
+ printf("\tCenter Latitude: %f\n", v->ProjArgs[0] );
+ printf("\tCenter Longitude: %f\n", v->ProjArgs[1] );
+ printf("\tCenter Row: %f\n", v->ProjArgs[2] );
+ printf("\tCenter Column: %f\n", v->ProjArgs[3] );
+ printf("\tColumn Spacing: %f\n", v->ProjArgs[4] );
+ break;
+ case 4:
+ /* WLH 4-21-95 */
+ printf("Rotated equidistant projection:\n");
+ printf("\tLatitude of grid(0,0): %f\n", v->ProjArgs[0] );
+ printf("\tLongitude of grid(0,0): %f\n", v->ProjArgs[1] );
+ printf("\tRow Increment: %f degress\n", v->ProjArgs[2] );
+ printf("\tColumn Increment: %f degrees\n", v->ProjArgs[3] );
+ printf("\tCenter Latitude: %f\n", v->ProjArgs[4] );
+ printf("\tCenter Longitude: %f\n", v->ProjArgs[5] );
+ printf("\tRotation: %f degrees\n", v->ProjArgs[6] );
+ break;
+ default:
+ printf("Bad projection number: %d\n", v->Projection );
+ }
+}
+
+
+
+/*
+ * Compute the location of a compressed grid within a file.
+ * Input: v - pointer to v5dstruct describing the file header.
+ * time, var - which timestep and variable.
+ * Return: file offset in bytes
+ */
+static int grid_position( const v5dstruct *v, int time, int var )
+{
+ int pos, i;
+
+ assert( time >= 0 );
+ assert( var >= 0 );
+ assert( time < v->NumTimes );
+ assert( var < v->NumVars );
+
+ pos = v->FirstGridPos + time * v->SumGridSizes;
+ for (i=0;i<var;i++) {
+ pos += v->GridSize[i];
+ }
+
+ return pos;
+}
+
+
+
+/*
+ * Compute the ga and gb (de)compression values for a grid.
+ * Input: nr, nc, nl - size of grid
+ * data - the grid data
+ * ga, gb - arrays to store results.
+ * minval, maxval - pointer to floats to return min, max values
+ * compressmode - 1, 2 or 4 bytes per grid point
+ * Output: ga, gb - the (de)compression values
+ * minval, maxval - the min and max grid values
+ * Side effect: the MinVal[var] and MaxVal[var] fields in g may be
+ * updated with new values.
+ */
+static void compute_ga_gb( int nr, int nc, int nl,
+ const float data[], int compressmode,
+ float ga[], float gb[],
+ float *minval, float *maxval )
+{
+#ifdef SIMPLE_COMPRESSION
+ /*
+ * Compute ga, gb values for whole grid.
+ */
+ int i, lev, allmissing, num;
+ float min, max, a, b;
+
+ min = 1.0e30;
+ max = -1.0e30;
+ num = nr * nc * nl;
+ allmissing = 1;
+ for (i=0;i<num;i++) {
+ if (!IS_MISSING(data[i])) {
+ if (data[i]<min) min = data[i];
+ if (data[i]>max) max = data[i];
+ allmissing = 0;
+ }
+ }
+ if (allmissing) {
+ a = 1.0;
+ b = 0.0;
+ }
+ else {
+ a = (max-min) / 254.0;
+ b = min;
+ }
+
+ /* return results */
+ for (i=0;i<nl;i++) {
+ ga[i] = a;
+ gb[i] = b;
+ }
+
+ *minval = min;
+ *maxval = max;
+#else
+ /*
+ * Compress grid on level-by-level basis.
+ */
+# define SMALLVALUE -1.0e30
+# define BIGVALUE 1.0e30
+# define ABS(x) ( ((x) < 0.0) ? -(x) : (x) )
+ float gridmin, gridmax;
+ float levmin[MAXLEVELS], levmax[MAXLEVELS];
+ float d[MAXLEVELS], dmax;
+ float ival, mval;
+ int j, k, lev, nrnc;
+
+ nrnc = nr * nc;
+
+ /* find min and max for each layer and the whole grid */
+ gridmin = BIGVALUE;
+ gridmax = SMALLVALUE;
+ j = 0;
+
+
+ for (lev=0;lev<nl;lev++) {
+ float ave, var;
+ float min, max;
+ min = BIGVALUE;
+ max = SMALLVALUE;
+ ave = 0.0;
+ var = 0.0;
+ for (k=0;k<nrnc;k++) {
+ if (!IS_MISSING(data[j]) && data[j]<min)
+ min = data[j];
+ if (!IS_MISSING(data[j]) && data[j]>max)
+ max = data[j];
+ j++;
+ }
+
+ if (min<gridmin)
+ gridmin = min;
+ if (max>gridmax)
+ gridmax = max;
+ levmin[lev] = min;
+ levmax[lev] = max;
+ }
+
+/* WLH 2-2-95 */
+#ifdef KLUDGE
+ /* if the grid minimum is within delt of 0.0, fudge all values */
+ /* within delt of 0.0 to delt, and recalculate mins and maxes */
+ {
+ float delt;
+ int nrncnl = nrnc * nl;
+
+ delt = (gridmax - gridmin)/100000.0;
+ if ( ABS(gridmin) < delt && gridmin!=0.0 && compressmode != 4 ) {
+ float min, max;
+ for (j=0; j<nrncnl; j++) {
+ if (!IS_MISSING(data[j]) && data[j]<delt)
+ data[j] = delt;
+ }
+ /* re-calculate min and max for each layer and the whole grid */
+ gridmin = delt;
+ for (lev=0;lev<nl;lev++) {
+ if (ABS(levmin[lev]) < delt)
+ levmin[lev] = delt;
+ if (ABS(levmax[lev]) < delt)
+ levmax[lev] = delt;
+ }
+ }
+ }
+#endif
+
+ /* find d[lev] and dmax = MAX( d[0], d[1], ... d[nl-1] ) */
+ dmax = 0.0;
+ for (lev=0;lev<nl;lev++) {
+ if (levmin[lev]>=BIGVALUE && levmax[lev]<=SMALLVALUE) {
+ /* all values in the layer are MISSING */
+ d[lev] = 0.0;
+ }
+ else {
+ d[lev] = levmax[lev]-levmin[lev];
+ }
+ if (d[lev]>dmax)
+ dmax = d[lev];
+ }
+
+ /*** Compute ga (scale) and gb (bias) for each grid level */
+ if (dmax==0.0) {
+ /*** Special cases ***/
+ if (gridmin==gridmax) {
+ /*** whole grid is of same value ***/
+ for (lev=0; lev<nl; lev++) {
+ ga[lev] = gridmin;
+ gb[lev] = 0.0;
+ }
+ }
+ else {
+ /*** every layer is of a single value ***/
+ for (lev=0; lev<nl; lev++) {
+ ga[lev] = levmin[lev];
+ gb[lev] = 0.0;
+ }
+ }
+ }
+ else {
+ /*** Normal cases ***/
+ if (compressmode == 1) {
+#define ORIGINAL
+#ifdef ORIGINAL
+ ival = dmax / 254.0;
+ mval = gridmin;
+
+ for (lev=0; lev<nl; lev++) {
+ ga[lev] = ival;
+ gb[lev] = mval + ival * (int) ( (levmin[lev]-mval) / ival );
+ }
+#else
+ for (lev=0; lev<nl; lev++) {
+ if (d[lev]==0.0) {
+ ival = 1.0;
+ }
+ else {
+ ival = d[lev] / 254.0;
+ }
+ ga[lev] = ival;
+ gb[lev] = levmin[lev];
+ }
+#endif
+ }
+ else if (compressmode == 2) {
+ ival = dmax / 65534.0;
+ mval = gridmin;
+
+ for (lev=0; lev<nl; lev++) {
+ ga[lev] = ival;
+ gb[lev] = mval + ival * (int) ( (levmin[lev]-mval) / ival );
+ }
+ }
+ else {
+ assert( compressmode==4 );
+ for (lev=0; lev<nl; lev++) {
+ ga[lev] = 1.0;
+ gb[lev] = 0.0;
+ }
+ }
+ }
+
+ /* update min, max values */
+ *minval = gridmin;
+ *maxval = gridmax;
+#endif
+}
+
+
+
+
+/*
+ * Compress a 3-D grid from floats to 1-byte unsigned integers.
+ * Input: nr, nc, nl - size of grid
+ * compressmode - 1, 2 or 4 bytes per grid point
+ * data - array of [nr*nc*nl] floats
+ * compdata - pointer to array of [nr*nc*nl*compressmode] bytes
+ * to put results into.
+ * ga, gb - pointer to arrays to put ga and gb decompression values
+ * minval, maxval - pointers to float to return min & max values
+ * Output: compdata - the compressed grid data
+ * ga, gb - the decompression values
+ * minval, maxval - the min and max grid values
+ */
+void v5dCompressGrid( int nr, int nc, int nl, int compressmode,
+ const float data[],
+ void *compdata, float ga[], float gb[],
+ float *minval, float *maxval )
+{
+ int nrnc = nr * nc;
+ int nrncnl = nr * nc * nl;
+ V5Dubyte *compdata1 = (V5Dubyte *) compdata;
+ V5Dushort *compdata2 = (V5Dushort *) compdata;
+
+ /* compute ga, gb values */
+ compute_ga_gb( nr, nc, nl, data, compressmode, ga, gb, minval, maxval );
+
+ /* compress the data */
+ if (compressmode==1) {
+ int i, lev, p;
+ p = 0;
+ for (lev=0;lev<nl;lev++) {
+ float one_over_a, b;
+/* WLH 5 Nov 98
+ b = gb[lev] - 0.0001;
+*/
+ /* WLH 5 Nov 98 */
+ b = gb[lev];
+ /* subtract an epsilon so the int((d-b)/a) */
+ /* expr below doesn't get mis-truncated. */
+ if (ga[lev]==0.0) {
+ one_over_a = 1.0;
+ }
+ else {
+ one_over_a = 1.0 / ga[lev];
+ }
+ for (i=0;i<nrnc;i++,p++) {
+ if (IS_MISSING(data[p])) {
+ compdata1[p] = 255;
+ }
+ else {
+/* MJK 1.19.99
+ compdata1[p] = (V5Dubyte) (int) ((data[p]-b) * one_over_a);
+*/
+ compdata1[p] = (V5Dubyte) rint((data[p]-b) * one_over_a);
+ if (compdata1[p] >= 255){
+ compdata1[p] = (V5Dubyte) (int) (255.0 - .0001);
+ }
+ }
+ }
+ }
+ }
+
+ else if (compressmode == 2) {
+ int i, lev, p;
+ p = 0;
+ for (lev=0;lev<nl;lev++) {
+ float one_over_a, b;
+/* WLH 5 Nov 98
+ b = gb[lev] - 0.0001;
+*/
+ /* WLH 5 Nov 98 */
+ b = gb[lev];
+
+ if (ga[lev]==0.0) {
+ one_over_a = 1.0;
+ }
+ else {
+ one_over_a = 1.0 / ga[lev];
+ }
+#ifdef _CRAY
+ /* this is tricky because sizeof(V5Dushort)==8, not 2 */
+ for (i=0;i<nrnc;i++,p++) {
+ V5Dushort compvalue;
+ if (IS_MISSING(data[p])) {
+ compvalue = 65535;
+ }
+ else {
+/* MJK 3.2.99
+ compvalue = (V5Dushort) (int) ((data[p]-b) * one_over_a);
+*/
+ compvalue = (V5Dushort) rint((data[p]-b) * one_over_a);
+ }
+ compdata1[p*2+0] = compvalue >> 8; /* upper byte */
+ compdata1[p*2+1] = compvalue & 0xffu; /* lower byte */
+ }
+#else
+ for (i=0;i<nrnc;i++,p++) {
+ if (IS_MISSING(data[p])) {
+ compdata2[p] = 65535;
+ }
+ else {
+ compdata2[p] = (V5Dushort) rint((data[p]-b) * one_over_a);
+
+/*
+ compdata2[p] = (V5Dushort) (int) ((data[p]-b) * one_over_a);
+*/
+/* MJK 3.24.99 I put this here so if the value is close
+ to the missing value and get's rounded up it won't come out
+ as missing data */
+ if (compdata2[p] == 65535){
+ compdata2[p] = 65534;
+ }
+ }
+ }
+ /* TODO: byte-swapping on little endian??? */
+#endif
+ }
+ }
+
+ else {
+ /* compressmode==4 */
+#ifdef _CRAY
+ cray_to_ieee_array( compdata, data, nrncnl );
+#else
+ /* other machines: just copy 4-byte IEEE floats */
+ assert( sizeof(float)==4 );
+ memcpy( compdata, data, nrncnl*4 );
+ /* TODO: byte-swapping on little endian??? */
+#endif
+ }
+}
+
+
+
+/*
+ * Decompress a 3-D grid from 1-byte integers to 4-byte floats.
+ * Input: nr, nc, nl - size of grid
+ * compdata - array of [nr*nr*nl*compressmode] bytes
+ * ga, gb - arrays of decompression factors
+ * compressmode - 1, 2 or 4 bytes per grid point
+ * data - address to put decompressed values
+ * Output: data - uncompressed floating point data values
+ */
+void v5dDecompressGrid( int nr, int nc, int nl, int compressmode,
+ void *compdata, float ga[], float gb[],
+ float data[] )
+{
+ int nrnc = nr * nc;
+ int nrncnl = nr * nc * nl;
+ V5Dubyte *compdata1 = (V5Dubyte *) compdata;
+ V5Dushort *compdata2 = (V5Dushort *) compdata;
+
+ if (compressmode == 1) {
+ int p, i, lev;
+ p = 0;
+ for (lev=0;lev<nl;lev++) {
+ float a = ga[lev];
+ float b = gb[lev];
+
+ /* WLH 2-2-95 */
+ float d, aa;
+ int id;
+ if (a > 0.0000000001) {
+ d = b / a;
+ id = floor(d);
+ d = d - id;
+ aa = a * 0.000001;
+ }
+ else {
+ id = 1;
+ }
+ if (-254 <= id && id <= 0 && d < aa) {
+ for (i=0;i<nrnc;i++,p++) {
+ if (compdata1[p]==255) {
+ data[p] = MISSING;
+ }
+ else {
+ data[p] = (float) (int) compdata1[p] * a + b;
+ if (fabs(data[p]) < aa) data[p] = aa;
+ }
+ }
+ }
+ else {
+ for (i=0;i<nrnc;i++,p++) {
+ if (compdata1[p]==255) {
+ data[p] = MISSING;
+ }
+ else {
+ data[p] = (float) (int) compdata1[p] * a + b;
+ }
+ }
+ }
+ /* end of WLH 2-2-95 */
+ }
+ }
+
+ else if (compressmode == 2) {
+ int p, i, lev;
+ p = 0;
+ for (lev=0;lev<nl;lev++) {
+ float a = ga[lev];
+ float b = gb[lev];
+#ifdef _CRAY
+ /* this is tricky because sizeof(V5Dushort)==8, not 2 */
+ for (i=0;i<nrnc;i++,p++) {
+ int compvalue;
+ compvalue = (compdata1[p*2] << 8) | compdata1[p*2+1];
+ if (compvalue==65535) {
+ data[p] = MISSING;
+ }
+ else {
+ data[p] = (float) compvalue * a + b;
+ }
+ }
+#else
+ /* sizeof(V5Dushort)==2! */
+ for (i=0;i<nrnc;i++,p++) {
+ if (compdata2[p]==65535) {
+ data[p] = MISSING;
+ }
+ else {
+ data[p] = (float) (int) compdata2[p] * a + b;
+ }
+ }
+#endif
+ }
+ }
+
+ else {
+ /* compressmode==4 */
+#ifdef _CRAY
+ ieee_to_cray_array( data, compdata, nrncnl );
+#else
+ /* other machines: just copy 4-byte IEEE floats */
+ assert( sizeof(float)==4 );
+ memcpy( data, compdata, nrncnl*4 );
+#endif
+ }
+}
+
+
+
+
+/*
+ * Return the size (in bytes) of the 3-D grid specified by time and var.
+ * Input: v - pointer to v5dstruct describing the file
+ * time, var - which timestep and variable
+ * Return: number of data points.
+ */
+int v5dSizeofGrid( const v5dstruct *v, int time, int var )
+{
+ return v->Nr * v->Nc * v->Nl[var] * v->CompressMode;
+}
+
+
+
+/*
+ * Initialize a v5dstructure to reasonable initial values.
+ * Input: v - pointer to v5dstruct.
+ */
+void v5dInitStruct( v5dstruct *v )
+{
+ int i;
+
+ /* set everything to zero */
+ memset( v, 0, sizeof(v5dstruct) );
+
+ /* special cases */
+ v->Projection = -1;
+ v->VerticalSystem = -1;
+
+ for (i=0;i<MAXVARS;i++) {
+ v->MinVal[i] = MISSING;
+ v->MaxVal[i] = -MISSING;
+ v->LowLev[i] = 0;
+ }
+
+ /* set file version */
+ strcpy(v->FileVersion, FILE_VERSION);
+
+ v->CompressMode = 1;
+ v->FileDesc = -1;
+}
+
+
+
+/*
+ * Return a pointer to a new, initialized v5dstruct.
+ */
+v5dstruct *v5dNewStruct( void )
+{
+ v5dstruct *v;
+
+ v = (v5dstruct *) malloc( sizeof(v5dstruct) );
+ if (v) {
+ v5dInitStruct(v);
+ }
+ return v;
+}
+
+
+
+/*
+ * Free an initialized v5dstruct. (Todd Plessel)
+ */
+void v5dFreeStruct( v5dstruct* v )
+{
+ /*assert( v5dVerifyStruct( v ) );*/
+ free( v );
+ v = 0;
+}
+
+
+
+/*
+ * Do some checking that the information in a v5dstruct is valid.
+ * Input: v - pointer to v5dstruct
+ * Return: 1 = g is ok, 0 = g is invalid
+ */
+int v5dVerifyStruct( const v5dstruct *v )
+{
+ int var, i, invalid, maxnl;
+
+ invalid = 0;
+
+ if (!v)
+ return 0;
+
+ /* Number of variables */
+ if (v->NumVars<0) {
+ printf("Invalid number of variables: %d\n", v->NumVars );
+ invalid = 1;
+ }
+ else if (v->NumVars>MAXVARS) {
+ printf("Too many variables: %d (Maximum is %d)\n",
+ v->NumVars, MAXVARS);
+ invalid = 1;
+ }
+
+ /* Variable Names */
+ for (i=0;i<v->NumVars;i++) {
+ if (v->VarName[i][0]==0) {
+ printf("Missing variable name: VarName[%d]=\"\"\n", i );
+ invalid = 1;
+ }
+ }
+
+ /* Number of timesteps */
+ if (v->NumTimes<0) {
+ printf("Invalid number of timesteps: %d\n", v->NumTimes );
+ invalid = 1;
+ }
+ else if (v->NumTimes>MAXTIMES) {
+ printf("Too many timesteps: %d (Maximum is %d)\n",
+ v->NumTimes, MAXTIMES );
+ invalid = 1;
+ }
+
+ /* Make sure timestamps are increasing */
+ for (i=1;i<v->NumTimes;i++) {
+ int date0 = v5dYYDDDtoDays( v->DateStamp[i-1] );
+ int date1 = v5dYYDDDtoDays( v->DateStamp[i] );
+ int time0 = v5dHHMMSStoSeconds( v->TimeStamp[i-1] );
+ int time1 = v5dHHMMSStoSeconds( v->TimeStamp[i] );
+ if (time1<=time0 && date1<=date0) {
+ printf("Timestamp for step %d must be later than step %d\n", i, i-1);
+ invalid = 1;
+ }
+ }
+
+ /* Rows */
+ if (v->Nr<2) {
+ printf("Too few rows: %d (2 is minimum)\n", v->Nr );
+ invalid = 1;
+ }
+ else if (v->Nr>MAXROWS) {
+ printf("Too many rows: %d (%d is maximum)\n", v->Nr, MAXROWS );
+ invalid = 1;
+ }
+
+ /* Columns */
+ if (v->Nc<2) {
+ printf("Too few columns: %d (2 is minimum)\n", v->Nc );
+ invalid = 1;
+ }
+ else if (v->Nc>MAXCOLUMNS) {
+ printf("Too many columns: %d (%d is maximum)\n", v->Nc, MAXCOLUMNS );
+ invalid = 1;
+ }
+
+ /* Levels */
+ maxnl = 0;
+ for (var=0;var<v->NumVars;var++) {
+ if (v->LowLev[var] < 0) {
+ printf("Low level cannot be negative for var %s: %d\n",
+ v->VarName[var], v->LowLev[var] );
+ invalid = 1;
+ }
+ if (v->Nl[var]<1) {
+ printf("Too few levels for var %s: %d (1 is minimum)\n",
+ v->VarName[var], v->Nl[var] );
+ invalid = 1;
+ }
+ if (v->Nl[var]+v->LowLev[var]>MAXLEVELS) {
+ printf("Too many levels for var %s: %d (%d is maximum)\n",
+ v->VarName[var], v->Nl[var]+v->LowLev[var], MAXLEVELS );
+ invalid = 1;
+ }
+ if (v->Nl[var]+v->LowLev[var]>maxnl) {
+ maxnl = v->Nl[var]+v->LowLev[var];
+ }
+ }
+
+ if (v->CompressMode != 1 && v->CompressMode != 2 && v->CompressMode != 4) {
+ printf("Bad CompressMode: %d (must be 1, 2 or 4)\n", v->CompressMode );
+ invalid = 1;
+ }
+
+ switch (v->VerticalSystem) {
+ case 0:
+ case 1:
+ if (v->VertArgs[1]==0.0) {
+ printf("Vertical level increment is zero, must be non-zero\n");
+ invalid = 1;
+ }
+ break;
+ case 2:
+ /* Check that Height values increase upward */
+ for (i=1;i<maxnl;i++) {
+ if (v->VertArgs[i] <= v->VertArgs[i-1]) {
+ printf("Height[%d]=%f <= Height[%d]=%f, level heights must increase\n",
+ i, v->VertArgs[i], i-1, v->VertArgs[i-1] );
+ invalid = 1;
+ break;
+ }
+ }
+ break;
+ case 3:
+ /* Check that Pressure values decrease upward */
+ for (i=1;i<maxnl;i++) {
+ if (v->VertArgs[i] <= v->VertArgs[i-1]) {
+ printf("Pressure[%d]=%f >= Pressure[%d]=%f, level pressures must decrease\n",
+ i, height_to_pressure(v->VertArgs[i]),
+ i-1, height_to_pressure(v->VertArgs[i-1]) );
+ invalid = 1;
+ break;
+ }
+ }
+ break;
+ default:
+ printf("VerticalSystem = %d, must be in 0..3\n", v->VerticalSystem );
+ invalid = 1;
+ }
+
+
+ switch (v->Projection) {
+ case 0: /* Generic */
+ if (v->ProjArgs[2]==0.0) {
+ printf("Row Increment (ProjArgs[2]) can't be zero\n");
+ invalid = 1;
+ }
+ if (v->ProjArgs[3]==0.0) {
+ printf("Column increment (ProjArgs[3]) can't be zero\n");
+ invalid = 1;
+ }
+ break;
+ case 1: /* Cylindrical equidistant */
+ if (v->ProjArgs[2]<0.0) {
+ printf("Row Increment (ProjArgs[2]) = %g (must be >=0.0)\n",
+ v->ProjArgs[2] );
+ invalid = 1;
+ }
+ if (v->ProjArgs[3]<=0.0) {
+ printf("Column Increment (ProjArgs[3]) = %g (must be >=0.0)\n",
+ v->ProjArgs[3] );
+ invalid = 1;
+ }
+ break;
+ case 2: /* Lambert Conformal */
+ if (v->ProjArgs[0]<-90.0 || v->ProjArgs[0]>90.0) {
+ printf("Lat1 (ProjArgs[0]) out of range: %g\n", v->ProjArgs[0] );
+ invalid = 1;
+ }
+ if (v->ProjArgs[1]<-90.0 || v->ProjArgs[1]>90.0) {
+ printf("Lat2 (ProjArgs[1] out of range: %g\n", v->ProjArgs[1] );
+ invalid = 1;
+ }
+ if (v->ProjArgs[5]<=0.0) {
+ printf("ColInc (ProjArgs[5]) = %g (must be >=0.0)\n",
+ v->ProjArgs[5] );
+ invalid = 1;
+ }
+ break;
+ case 3: /* Stereographic */
+ if (v->ProjArgs[0]<-90.0 || v->ProjArgs[0]>90.0) {
+ printf("Central Latitude (ProjArgs[0]) out of range: ");
+ printf("%g (must be in +/-90)\n", v->ProjArgs[0] );
+ invalid = 1;
+ }
+ if (v->ProjArgs[1]<-180.0 || v->ProjArgs[1]>180.0) {
+ printf("Central Longitude (ProjArgs[1]) out of range: ");
+ printf("%g (must be in +/-180)\n", v->ProjArgs[1] );
+ invalid = 1;
+ }
+ if (v->ProjArgs[4]<0) {
+ printf("Column spacing (ProjArgs[4]) = %g (must be positive)\n",
+ v->ProjArgs[4]);
+ invalid = 1;
+ }
+ break;
+ case 4: /* Rotated */
+ /* WLH 4-21-95 */
+ if (v->ProjArgs[2]<=0.0) {
+ printf("Row Increment (ProjArgs[2]) = %g (must be >=0.0)\n",
+ v->ProjArgs[2] );
+ invalid = 1;
+ }
+ if (v->ProjArgs[3]<=0.0) {
+ printf("Column Increment = (ProjArgs[3]) %g (must be >=0.0)\n",
+ v->ProjArgs[3] );
+ invalid = 1;
+ }
+ if (v->ProjArgs[4]<-90.0 || v->ProjArgs[4]>90.0) {
+ printf("Central Latitude (ProjArgs[4]) out of range: ");
+ printf("%g (must be in +/-90)\n", v->ProjArgs[4] );
+ invalid = 1;
+ }
+ if (v->ProjArgs[5]<-180.0 || v->ProjArgs[5]>180.0) {
+ printf("Central Longitude (ProjArgs[5]) out of range: ");
+ printf("%g (must be in +/-180)\n", v->ProjArgs[5] );
+ invalid = 1;
+ }
+ if (v->ProjArgs[6]<-180.0 || v->ProjArgs[6]>180.0) {
+ printf("Central Longitude (ProjArgs[6]) out of range: ");
+ printf("%g (must be in +/-180)\n", v->ProjArgs[6] );
+ invalid = 1;
+ }
+ break;
+ default:
+ printf("Projection = %d, must be in 0..4\n", v->Projection );
+ invalid = 1;
+ }
+
+ return !invalid;
+}
+
+
+
+/*
+ * Get the McIDAS file number and grid number associated with the grid
+ * identified by time and var.
+ * Input: v - v5d grid struct
+ * time, var - timestep and variable of grid
+ * Output: mcfile, mcgrid - McIDAS grid file number and grid number
+ */
+int v5dGetMcIDASgrid( v5dstruct *v, int time, int var,
+ int *mcfile, int *mcgrid )
+{
+ if (time<0 || time>=v->NumTimes) {
+ printf("Bad time argument to v5dGetMcIDASgrid: %d\n", time );
+ return 0;
+ }
+ if (var<0 || var>=v->NumVars) {
+ printf("Bad var argument to v5dGetMcIDASgrid: %d\n", var );
+ return 0;
+ }
+
+ *mcfile = (int) v->McFile[time][var];
+ *mcgrid = (int) v->McGrid[time][var];
+ return 1;
+}
+
+
+
+/*
+ * Set the McIDAS file number and grid number associated with the grid
+ * identified by time and var.
+ * Input: v - v5d grid struct
+ * time, var - timestep and variable of grid
+ * mcfile, mcgrid - McIDAS grid file number and grid number
+ * Return: 1 = ok, 0 = error (bad time or var)
+ */
+int v5dSetMcIDASgrid( v5dstruct *v, int time, int var,
+ int mcfile, int mcgrid )
+{
+ if (time<0 || time>=v->NumTimes) {
+ printf("Bad time argument to v5dSetMcIDASgrid: %d\n", time );
+ return 0;
+ }
+ if (var<0 || var>=v->NumVars) {
+ printf("Bad var argument to v5dSetMcIDASgrid: %d\n", var );
+ return 0;
+ }
+
+ v->McFile[time][var] = (short) mcfile;
+ v->McGrid[time][var] = (short) mcgrid;
+ return 1;
+}
+
+
+
+/**********************************************************************/
+/***** Input Functions *****/
+/**********************************************************************/
+
+
+
+/*
+ * Read the header from a COMP* file and return results in the v5dstruct.
+ * Input: f - the file descriptor
+ * v - pointer to a v5dstruct.
+ * Return: 1 = ok, 0 = error.
+ */
+static int read_comp_header( int f, v5dstruct *v )
+{
+ unsigned int id;
+
+ /* reset file position to start of file */
+ lseek( f, 0, SEEK_SET );
+
+ /* read file ID */
+ read_int4( f, (int *) &id );
+
+ if (id==0x80808080 || id==0x80808081) {
+ /* Older COMP5D format */
+ int gridtimes, gridparms;
+ int i, j, it, iv, nl;
+ int gridsize;
+ float hgttop, hgtinc;
+ /*char *compgrid;*/
+
+ if (id==0x80808080) {
+ /* 20 vars, 300 times */
+ gridtimes = 300;
+ gridparms = 20;
+ }
+ else {
+ /* 30 vars, 400 times */
+ gridtimes = 400;
+ gridparms = 30;
+ }
+
+ v->FirstGridPos = 12*4 + 8*gridtimes + 4*gridparms;
+
+ read_int4( f, &v->NumTimes );
+ read_int4( f, &v->NumVars );
+ read_int4( f, &v->Nr );
+ read_int4( f, &v->Nc );
+ read_int4( f, &nl );
+ for (i=0;i<v->NumVars;i++) {
+ v->Nl[i] = nl;
+ v->LowLev[i] = 0;
+ }
+ read_float4( f, &v->ProjArgs[0] );
+ read_float4( f, &v->ProjArgs[1] );
+ read_float4( f, &hgttop );
+ read_float4( f, &v->ProjArgs[2] );
+ read_float4( f, &v->ProjArgs[3] );
+ read_float4( f, &hgtinc );
+/*
+ for (i=0;i<nl;i++) {
+ v->Height[nl-i-1] = hgttop - i * hgtinc;
+ }
+*/
+ v->VerticalSystem = 1;
+ v->VertArgs[0] = hgttop - hgtinc * (nl-1);
+ v->VertArgs[1] = hgtinc;
+
+ /* read dates and times */
+ for (i=0;i<gridtimes;i++) {
+ read_int4( f, &j );
+ v->DateStamp[i] = v5dDaysToYYDDD( j );
+ }
+ for (i=0;i<gridtimes;i++) {
+ read_int4( f, &j );
+ v->TimeStamp[i] = v5dSecondsToHHMMSS( j );
+ }
+
+ /* read variable names */
+ for (i=0;i<gridparms;i++) {
+ char name[4];
+ read_bytes( f, name, 4 );
+ /* remove trailing spaces, if any */
+ for (j=3;j>0;j--) {
+ if (name[j]==' ' || name[j]==0)
+ name[j] = 0;
+ else
+ break;
+ }
+ strncpy( v->VarName[i], name, 4 );
+ v->VarName[i][4] = 0;
+ }
+
+ gridsize = ( (v->Nr * v->Nc * nl + 3) / 4) * 4;
+ for (i=0;i<v->NumVars;i++) {
+ v->GridSize[i] = 8 + gridsize;
+ }
+ v->SumGridSizes = (8+gridsize) * v->NumVars;
+
+ /* read the grids and their ga,gb values to find min and max values */
+
+ for (i=0;i<v->NumVars;i++) {
+ v->MinVal[i] = 999999.9;
+ v->MaxVal[i] = -999999.9;
+ }
+
+ /*compgrid = (char *) malloc( gridsize );*/
+
+ for (it=0; it<v->NumTimes; it++) {
+ for (iv=0; iv<v->NumVars; iv++) {
+ float ga, gb;
+ float min, max;
+
+ read_float4( f, &ga );
+ read_float4( f, &gb );
+
+ /* skip ahead by 'gridsize' bytes */
+ if (lseek( f, gridsize, SEEK_CUR )==-1) {
+ printf("Error: Unexpected end of file, ");
+ printf("file may be corrupted.\n");
+ return 0;
+ }
+ min = -(125.0+gb)/ga;
+ max = (125.0-gb)/ga;
+ if (min<v->MinVal[iv]) v->MinVal[iv] = min;
+ if (max>v->MaxVal[iv]) v->MaxVal[iv] = max;
+ }
+ }
+
+ /*free( compgrid );*/
+
+ /* done */
+ }
+ else if (id==0x80808082 || id==0x80808083) {
+ /* Newer COMP5D format */
+ int gridtimes, gridsize;
+ int it, iv, nl, i, j;
+ float delta;
+
+ read_int4( f, &gridtimes );
+ read_int4( f, &v->NumVars );
+ read_int4( f, &v->NumTimes );
+ read_int4( f, &v->Nr );
+ read_int4( f, &v->Nc );
+ read_int4( f, &nl );
+ for (i=0;i<v->NumVars;i++) {
+ v->Nl[i] = nl;
+ }
+
+ read_float4( f, &v->ProjArgs[2] );
+ read_float4( f, &v->ProjArgs[3] );
+
+ /* Read height and determine if equal spacing */
+ v->VerticalSystem = 1;
+ for (i=0;i<nl;i++) {
+ read_float4( f, &v->VertArgs[i] );
+ if (i==1) {
+ delta = v->VertArgs[1] - v->VertArgs[0];
+ }
+ else if (i>1) {
+ if (delta != (v->VertArgs[i] - v->VertArgs[i-1])) {
+ v->VerticalSystem = 2;
+ }
+ }
+ }
+ if (v->VerticalSystem==1) {
+ v->VertArgs[1] = delta;
+ }
+
+ /* read variable names */
+ for (iv=0; iv<v->NumVars; iv++) {
+ char name[8];
+
+ read_bytes( f, name, 8 );
+
+ /* remove trailing spaces, if any */
+ for (j=7;j>0;j--) {
+ if (name[j]==' ' || name[j]==0)
+ name[j] = 0;
+ else
+ break;
+ }
+ strncpy( v->VarName[iv], name, 8 );
+ v->VarName[iv][8] = 0;
+ }
+
+ for (iv=0;iv<v->NumVars;iv++) {
+ read_float4( f, &v->MinVal[iv] );
+ }
+ for (iv=0;iv<v->NumVars;iv++) {
+ read_float4( f, &v->MaxVal[iv] );
+ }
+ for (it=0;it<gridtimes;it++) {
+ read_int4( f, &j );
+ v->TimeStamp[it] = v5dSecondsToHHMMSS( j );
+ }
+ for (it=0;it<gridtimes;it++) {
+ read_int4( f, &j );
+ v->DateStamp[it] = v5dDaysToYYDDD( j );
+ }
+ for (it=0;it<gridtimes;it++) {
+ float nlat;
+ read_float4( f, &nlat );
+ if (it==0) v->ProjArgs[0] = nlat;
+ }
+ for (it=0;it<gridtimes;it++) {
+ float wlon;
+ read_float4( f, &wlon );
+ if (it==0) v->ProjArgs[1] = wlon;
+ }
+
+ /* calculate grid storage sizes */
+ if (id==0x80808082) {
+ gridsize = nl*2*4 + ( (v->Nr * v->Nc * nl + 3) / 4) * 4;
+ }
+ else {
+ /* McIDAS grid and file numbers present */
+ gridsize = 8 + nl*2*4 + ( (v->Nr * v->Nc * nl + 3) / 4) * 4;
+ }
+ for (i=0;i<v->NumVars;i++) {
+ v->GridSize[i] = gridsize;
+ }
+ v->SumGridSizes = gridsize * v->NumVars;
+
+ /* read McIDAS numbers??? */
+
+ /* size (in bytes) of all header info */
+ v->FirstGridPos = 9*4 + v->Nl[0]*4 + v->NumVars*16 + gridtimes*16;
+
+ }
+
+ v->CompressMode = 1; /* one byte per grid point */
+ v->Projection = 1; /* Cylindrical equidistant */
+ v->FileVersion[0] = 0;
+
+ return 1;
+}
+
+
+
+/*
+ * Read a compressed grid from a COMP* file.
+ * Return: 1 = ok, 0 = error.
+ */
+static int read_comp_grid( v5dstruct *v, int time, int var,
+ float *ga, float *gb, void *compdata )
+{
+ unsigned int pos;
+ V5Dubyte bias;
+ int i, n, nl;
+ int f;
+ V5Dubyte *compdata1 = (V5Dubyte *) compdata;
+
+ f = v->FileDesc;
+
+ /* move to position in file */
+ pos = grid_position( v, time, var );
+ lseek( f, pos, SEEK_SET );
+
+ if (v->FileFormat==0x80808083) {
+ /* read McIDAS grid and file numbers */
+ int mcfile, mcgrid;
+ read_int4( f, &mcfile );
+ read_int4( f, &mcgrid );
+ v->McFile[time][var] = (short) mcfile;
+ v->McGrid[time][var] = (short) mcgrid;
+ }
+
+ nl = v->Nl[var];
+
+ if (v->FileFormat==0x80808080 || v->FileFormat==0x80808081) {
+ /* single ga,gb pair for whole grid */
+ float a, b;
+ read_float4( f, &a );
+ read_float4( f, &b );
+ /* convert a, b to new v5d ga, gb values */
+ for (i=0;i<nl;i++) {
+ if (a==0.0) {
+ ga[i] = gb[i] = 0.0;
+ }
+ else {
+ gb[i] = (b+128.0) / -a;
+ ga[i] = 1.0 / a;
+ }
+ }
+ bias = 128;
+ }
+ else {
+ /* read ga, gb arrays */
+ read_float4_array( f, ga, v->Nl[var] );
+ read_float4_array( f, gb, v->Nl[var] );
+
+ /* convert ga, gb values to v5d system */
+ for (i=0;i<nl;i++) {
+ if (ga[i]==0.0) {
+ ga[i] = gb[i] = 0.0;
+ }
+ else {
+ /*gb[i] = (gb[i]+125.0) / -ga[i];*/
+ gb[i] = (gb[i]+128.0) / -ga[i];
+ ga[i] = 1.0 / ga[i];
+ }
+ }
+ bias = 128; /* 125 ??? */
+ }
+
+ /* read compressed grid data */
+ n = v->Nr * v->Nc * v->Nl[var];
+ if (read_bytes( f, compdata1, n )!=n)
+ return 0;
+
+ /* convert data values to v5d system */
+ n = v->Nr * v->Nc * v->Nl[var];
+ for (i=0;i<n;i++) {
+ compdata1[i] += bias;
+ }
+
+ return 1;
+}
+
+
+
+/*
+ * Read a v5d file header.
+ * Input: f - file opened for reading.
+ * v - pointer to v5dstruct to store header info into.
+ * Return: 1 = ok, 0 = error.
+ */
+static int read_v5d_header( v5dstruct *v )
+{
+#define SKIP(N) lseek( f, N, SEEK_CUR )
+ int end_of_header = 0;
+ unsigned int id;
+ int idlen, var, numargs;
+ int f;
+
+ f = v->FileDesc;
+
+ /* first try to read the header id */
+ read_int4( f, (int*) &id );
+ read_int4( f, &idlen );
+ if (id==TAG_ID && idlen==0) {
+ /* this is a v5d file */
+ v->FileFormat = 0;
+ }
+ else if (id>=0x80808080 && id<=0x80808083) {
+ /* this is an old COMP* file */
+ v->FileFormat = id;
+ return read_comp_header( f, v );
+ }
+ else {
+ /* unknown file type */
+ printf("Error: not a v5d file\n");
+ return 0;
+ }
+
+ v->CompressMode = 1; /* default */
+
+ while (!end_of_header) {
+ int tag, length;
+ int i, var, time, nl, lev;
+
+ if (read_int4(f,&tag)<1 || read_int4(f,&length)<1) {
+ printf("Error while reading header, premature EOF\n");
+ return 0;
+ }
+
+ switch (tag) {
+ case TAG_VERSION:
+ assert( length==10 );
+ read_bytes( f, v->FileVersion, 10 );
+ /* Check if reading a file made by a future version of Vis5D */
+ if (strcmp(v->FileVersion, FILE_VERSION)>0) {
+ /* WLH 6 Oct 98 */
+ printf("Warning: Trying to read a version %s file,", v->FileVersion);
+ printf(" you should upgrade Vis5D.\n");
+ }
+ break;
+ case TAG_NUMTIMES:
+ assert( length==4 );
+ read_int4( f, &v->NumTimes );
+ break;
+ case TAG_NUMVARS:
+ assert( length==4 );
+ read_int4( f, &v->NumVars );
+ break;
+ case TAG_VARNAME:
+ assert( length==14 ); /* 1 int + 10 char */
+ read_int4( f, &var );
+ read_bytes( f, v->VarName[var], 10 );
+ break;
+ case TAG_NR:
+ /* Number of rows for all variables */
+ assert( length==4 );
+ read_int4( f, &v->Nr );
+ break;
+ case TAG_NC:
+ /* Number of columns for all variables */
+ assert( length==4 );
+ read_int4( f, &v->Nc );
+ break;
+ case TAG_NL:
+ /* Number of levels for all variables */
+ assert( length==4 );
+ read_int4( f, &nl );
+ for (i=0;i<v->NumVars;i++) {
+ v->Nl[i] = nl;
+ }
+ break;
+ case TAG_NL_VAR:
+ /* Number of levels for one variable */
+ assert( length==8 );
+ read_int4( f, &var );
+ read_int4( f, &v->Nl[var] );
+ break;
+ case TAG_LOWLEV_VAR:
+ /* Lowest level for one variable */
+ assert( length==8 );
+ read_int4( f, &var );
+ read_int4( f, &v->LowLev[var] );
+ break;
+
+ case TAG_TIME:
+ /* Time stamp for 1 timestep */
+ assert( length==8 );
+ read_int4( f, &time );
+ read_int4( f, &v->TimeStamp[time] );
+ break;
+ case TAG_DATE:
+ /* Date stamp for 1 timestep */
+ assert( length==8 );
+ read_int4( f, &time );
+ read_int4( f, &v->DateStamp[time] );
+ break;
+
+ case TAG_MINVAL:
+ /* Minimum value for a variable */
+ assert( length==8 );
+ read_int4( f, &var );
+ read_float4( f, &v->MinVal[var] );
+ break;
+ case TAG_MAXVAL:
+ /* Maximum value for a variable */
+ assert( length==8 );
+ read_int4( f, &var );
+ read_float4( f, &v->MaxVal[var] );
+ break;
+ case TAG_COMPRESS:
+ /* Compress mode */
+ assert( length==4 );
+ read_int4( f, &v->CompressMode );
+ break;
+ case TAG_UNITS:
+ /* physical units */
+ assert( length==24 );
+ read_int4( f, &var );
+ read_bytes( f, v->Units[var], 20 );
+ break;
+
+ /*
+ * Vertical coordinate system
+ */
+ case TAG_VERTICAL_SYSTEM:
+ assert( length==4 );
+ read_int4( f, &v->VerticalSystem );
+ if (v->VerticalSystem<0 || v->VerticalSystem>3) {
+ printf("Error: bad vertical coordinate system: %d\n",
+ v->VerticalSystem );
+ }
+ break;
+ case TAG_VERT_ARGS:
+ read_int4( f, &numargs );
+ assert( numargs <= MAXVERTARGS );
+ read_float4_array( f, v->VertArgs, numargs );
+ assert( length==numargs*4+4 );
+ break;
+ case TAG_HEIGHT:
+ /* height of a grid level */
+ assert( length==8 );
+ read_int4( f, &lev );
+ read_float4( f, &v->VertArgs[lev] );
+ break;
+ case TAG_BOTTOMBOUND:
+ assert( length==4 );
+ read_float4( f, &v->VertArgs[0] );
+ break;
+ case TAG_LEVINC:
+ assert( length==4 );
+ read_float4( f, &v->VertArgs[1] );
+ break;
+
+ /*
+ * Map projection information
+ */
+ case TAG_PROJECTION:
+ assert( length==4 );
+ read_int4( f, &v->Projection );
+ if (v->Projection<0 || v->Projection>4) { /* WLH 4-21-95 */
+ printf("Error while reading header, bad projection (%d)\n",
+ v->Projection );
+ return 0;
+ }
+ break;
+ case TAG_PROJ_ARGS:
+ read_int4( f, &numargs );
+ assert( numargs <= MAXPROJARGS );
+ read_float4_array( f, v->ProjArgs, numargs );
+ assert( length==4*numargs+4 );
+ break;
+ case TAG_NORTHBOUND:
+ assert( length==4 );
+ if (v->Projection==0 || v->Projection==1 || v->Projection==4) {
+ read_float4( f, &v->ProjArgs[0] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+ case TAG_WESTBOUND:
+ assert( length==4 );
+ if (v->Projection==0 || v->Projection==1 || v->Projection==4) {
+ read_float4( f, &v->ProjArgs[1] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+ case TAG_ROWINC:
+ assert( length==4 );
+ if (v->Projection==0 || v->Projection==1 || v->Projection==4) {
+ read_float4( f, &v->ProjArgs[2] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+ case TAG_COLINC:
+ assert( length==4 );
+ if (v->Projection==0 || v->Projection==1 || v->Projection==4) {
+ read_float4( f, &v->ProjArgs[3] );
+ }
+ else if (v->Projection==2) {
+ read_float4( f, &v->ProjArgs[5] );
+ }
+ else if (v->Projection==3) {
+ read_float4( f, &v->ProjArgs[4] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+ case TAG_LAT1:
+ assert( length==4 );
+ if (v->Projection==2) {
+ read_float4( f, &v->ProjArgs[0] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+ case TAG_LAT2:
+ assert( length==4 );
+ if (v->Projection==2) {
+ read_float4( f, &v->ProjArgs[1] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+ case TAG_POLE_ROW:
+ assert( length==4 );
+ if (v->Projection==2) {
+ read_float4( f, &v->ProjArgs[2] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+ case TAG_POLE_COL:
+ assert( length==4 );
+ if (v->Projection==2) {
+ read_float4( f, &v->ProjArgs[3] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+ case TAG_CENTLON:
+ assert( length==4 );
+ if (v->Projection==2) {
+ read_float4( f, &v->ProjArgs[4] );
+ }
+ else if (v->Projection==3) {
+ read_float4( f, &v->ProjArgs[1] );
+ }
+ else if (v->Projection==4) { /* WLH 4-21-95 */
+ read_float4( f, &v->ProjArgs[5] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+ case TAG_CENTLAT:
+ assert( length==4 );
+ if (v->Projection==3) {
+ read_float4( f, &v->ProjArgs[0] );
+ }
+ else if (v->Projection==4) { /* WLH 4-21-95 */
+ read_float4( f, &v->ProjArgs[4] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+ case TAG_CENTROW:
+ assert( length==4 );
+ if (v->Projection==3) {
+ read_float4( f, &v->ProjArgs[2] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+ case TAG_CENTCOL:
+ assert( length==4 );
+ if (v->Projection==3) {
+ read_float4( f, &v->ProjArgs[3] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+ case TAG_ROTATION:
+ assert( length==4 );
+ if (v->Projection==4) { /* WLH 4-21-95 */
+ read_float4( f, &v->ProjArgs[6] );
+ }
+ else {
+ SKIP( 4 );
+ }
+ break;
+
+ case TAG_END:
+ /* end of header */
+ end_of_header = 1;
+ lseek( f, length, SEEK_CUR );
+ break;
+
+ default:
+ /* unknown tag, skip to next tag */
+ printf("Unknown tag: %d length=%d\n", tag, length );
+ lseek( f, length, SEEK_CUR );
+ break;
+ }
+
+ }
+
+ v5dVerifyStruct( v );
+
+ /* Now we're ready to read the grid data */
+
+ /* Save current file pointer */
+ v->FirstGridPos = ltell(f);
+
+ /* compute grid sizes */
+ v->SumGridSizes = 0;
+ for (var=0;var<v->NumVars;var++) {
+ v->GridSize[var] = 8 * v->Nl[var] + v5dSizeofGrid( v, 0, var );
+ v->SumGridSizes += v->GridSize[var];
+ }
+
+ return 1;
+#undef SKIP
+}
+
+
+
+
+/*
+ * Open a v5d file for reading.
+ * Input: filename - name of v5d file to open
+ * v - pointer to a v5dstruct in which to put header info or NULL
+ * if a struct should be dynamically allocated.
+ * Return: NULL if error, else v or a pointer to a new v5dstruct if v was NULL
+ */
+v5dstruct *v5dOpenFile( const char *filename, v5dstruct *v )
+{
+ int fd;
+
+ fd = open( filename, O_RDONLY );
+ if (fd==-1) {
+ /* error */
+ return 0;
+ }
+
+ if (v) {
+ v5dInitStruct( v );
+ }
+ else {
+ v = v5dNewStruct();
+ if (!v) {
+ return NULL;
+ }
+ }
+
+ v->FileDesc = fd;
+ v->Mode = 'r';
+ if (read_v5d_header( v )) {
+ return v;
+ }
+ else {
+ return NULL;
+ }
+}
+
+
+
+
+/*
+ * Read a compressed grid from a v5d file.
+ * Input: v - pointer to v5dstruct describing the file
+ * time, var - which timestep and variable
+ * ga, gb - arrays to store grid (de)compression values
+ * compdata - address of where to store compressed grid data.
+ * Return: 1 = ok, 0 = error.
+ */
+int v5dReadCompressedGrid( v5dstruct *v, int time, int var,
+ float *ga, float *gb, void *compdata )
+{
+ int pos, n, k;
+
+ if (time<0 || time>=v->NumTimes) {
+ printf("Error in v5dReadCompressedGrid: bad timestep argument (%d)\n",
+ time);
+ return 0;
+ }
+ if (var<0 || var>=v->NumVars) {
+ printf("Error in v5dReadCompressedGrid: bad var argument (%d)\n",
+ var);
+ return 0;
+ }
+
+ if (v->FileFormat) {
+ /* old COMP* file */
+ return read_comp_grid( v, time, var, ga, gb, compdata );
+ }
+
+ /* move to position in file */
+ pos = grid_position( v, time, var );
+ lseek( v->FileDesc, pos, SEEK_SET );
+
+ /* read ga, gb arrays */
+ read_float4_array( v->FileDesc, ga, v->Nl[var] );
+ read_float4_array( v->FileDesc, gb, v->Nl[var] );
+
+ /* read compressed grid data */
+ n = v->Nr * v->Nc * v->Nl[var];
+ if (v->CompressMode==1) {
+ k = read_block( v->FileDesc, compdata, n, 1 )==n;
+ }
+ else if (v->CompressMode==2) {
+ k = read_block( v->FileDesc, compdata, n, 2 )==n;
+ }
+ else if (v->CompressMode==4) {
+ k = read_block( v->FileDesc, compdata, n, 4 )==n;
+ }
+ if (!k) {
+ /* error */
+ printf("Error in v5dReadCompressedGrid: read failed, bad file?\n");
+ }
+ return k;
+
+
+/*
+ n = v->Nr * v->Nc * v->Nl[var] * v->CompressMode;
+ if (read( v->FileDesc, compdata, n )==n)
+ return 1;
+ else
+ return 0;
+*/
+}
+
+
+
+
+/*
+ * Read a grid from a v5d file, decompress it and return it.
+ * Input: v - pointer to v5dstruct describing file header
+ * time, var - which timestep and variable.
+ * data - address of buffer to put grid data
+ * Output: data - the grid data
+ * Return: 1 = ok, 0 = error.
+ */
+int v5dReadGrid( v5dstruct *v, int time, int var, float data[] )
+{
+ float ga[MAXLEVELS], gb[MAXLEVELS];
+ void *compdata;
+ int bytes;
+
+ if (time<0 || time>=v->NumTimes) {
+ printf("Error in v5dReadGrid: bad timestep argument (%d)\n", time);
+ return 0;
+ }
+ if (var<0 || var>=v->NumVars) {
+ printf("Error in v5dReadGrid: bad variable argument (%d)\n", var);
+ return 0;
+ }
+
+ /* allocate compdata buffer */
+ if (v->CompressMode==1) {
+ bytes = v->Nr * v->Nc * v->Nl[var] * sizeof(unsigned char);
+ }
+ else if (v->CompressMode==2) {
+ bytes = v->Nr * v->Nc * v->Nl[var] * sizeof(unsigned short);
+ }
+ else if (v->CompressMode==4) {
+ bytes = v->Nr * v->Nc * v->Nl[var] * sizeof(float);
+ }
+ compdata = (void *) malloc( bytes );
+ if (!compdata) {
+ printf("Error in v5dReadGrid: out of memory (needed %d bytes)\n", bytes);
+ return 0;
+ }
+
+ /* read the compressed data */
+ if (!v5dReadCompressedGrid( v, time, var, ga, gb, compdata )) {
+ return 0;
+ }
+
+ /* decompress the data */
+ v5dDecompressGrid( v->Nr, v->Nc, v->Nl[var], v->CompressMode,
+ compdata, ga, gb, data );
+
+ /* free compdata */
+ free( compdata );
+ return 1;
+}
+
+
+
+
+/**********************************************************************/
+/***** Output Functions *****/
+/**********************************************************************/
+
+
+
+static int write_tag( v5dstruct *v, int tag, int length, int newfile )
+{
+ if (!newfile) {
+ /* have to check that there's room in header to write this tagged item */
+ if (v->CurPos+8+length > v->FirstGridPos) {
+ printf("Error: out of header space!\n");
+ /* Out of header space! */
+ return 0;
+ }
+ }
+
+ if (write_int4( v->FileDesc, tag )==0) return 0;
+ if (write_int4( v->FileDesc, length )==0) return 0;
+ v->CurPos += 8 + length;
+ return 1;
+}
+
+
+
+/*
+ * Write the information in the given v5dstruct as a v5d file header.
+ * Note that the current file position is restored when this function
+ * returns normally.
+ * Input: f - file already open for writing
+ * v - pointer to v5dstruct
+ * Return: 1 = ok, 0 = error.
+ */
+static int write_v5d_header( v5dstruct *v )
+{
+ int var, time, filler, maxnl;
+ int f;
+ int newfile;
+
+ if (v->FileFormat!=0) {
+ printf("Error: v5d library can't write comp5d format files.\n");
+ return 0;
+ }
+
+ f = v->FileDesc;
+
+ if (!v5dVerifyStruct( v ))
+ return 0;
+
+ /* Determine if we're writing to a new file */
+ if (v->FirstGridPos==0) {
+ newfile = 1;
+ }
+ else {
+ newfile = 0;
+ }
+
+ /* compute grid sizes */
+ v->SumGridSizes = 0;
+ for (var=0;var<v->NumVars;var++) {
+ v->GridSize[var] = 8 * v->Nl[var] + v5dSizeofGrid( v, 0, var );
+ v->SumGridSizes += v->GridSize[var];
+ }
+
+ /* set file pointer to start of file */
+ lseek( f, 0, SEEK_SET );
+ v->CurPos = 0;
+
+ /*
+ * Write the tagged header info
+ */
+#define WRITE_TAG( V, T, L ) if (!write_tag(V,T,L,newfile)) return 0;
+
+ /* ID */
+ WRITE_TAG( v, TAG_ID, 0 );
+
+ /* File Version */
+ WRITE_TAG( v, TAG_VERSION, 10 );
+ write_bytes( f, FILE_VERSION, 10 );
+
+ /* Number of timesteps */
+ WRITE_TAG( v, TAG_NUMTIMES, 4 );
+ write_int4( f, v->NumTimes );
+
+ /* Number of variables */
+ WRITE_TAG( v, TAG_NUMVARS, 4 );
+ write_int4( f, v->NumVars );
+
+ /* Names of variables */
+ for (var=0;var<v->NumVars;var++) {
+ WRITE_TAG( v, TAG_VARNAME, 14 );
+ write_int4( f, var );
+ write_bytes( f, v->VarName[var], 10 );
+ }
+
+ /* Physical Units */
+ for (var=0;var<v->NumVars;var++) {
+ WRITE_TAG( v, TAG_UNITS, 24 );
+ write_int4( f, var );
+ write_bytes( f, v->Units[var], 20 );
+ }
+
+ /* Date and time of each timestep */
+ for (time=0;time<v->NumTimes;time++) {
+ WRITE_TAG( v, TAG_TIME, 8 );
+ write_int4( f, time );
+ write_int4( f, v->TimeStamp[time] );
+ WRITE_TAG( v, TAG_DATE, 8 );
+ write_int4( f, time );
+ write_int4( f, v->DateStamp[time] );
+ }
+
+ /* Number of rows */
+ WRITE_TAG( v, TAG_NR, 4 );
+ write_int4( f, v->Nr );
+
+ /* Number of columns */
+ WRITE_TAG( v, TAG_NC, 4 );
+ write_int4( f, v->Nc );
+
+ /* Number of levels, compute maxnl */
+ maxnl = 0;
+ for (var=0;var<v->NumVars;var++) {
+ WRITE_TAG( v, TAG_NL_VAR, 8 );
+ write_int4( f, var );
+ write_int4( f, v->Nl[var] );
+ WRITE_TAG( v, TAG_LOWLEV_VAR, 8 );
+ write_int4( f, var );
+ write_int4( f, v->LowLev[var] );
+ if (v->Nl[var]+v->LowLev[var]>maxnl) {
+ maxnl = v->Nl[var]+v->LowLev[var];
+ }
+ }
+
+ /* Min/Max values */
+ for (var=0;var<v->NumVars;var++) {
+ WRITE_TAG( v, TAG_MINVAL, 8 );
+ write_int4( f, var );
+ write_float4( f, v->MinVal[var] );
+ WRITE_TAG( v, TAG_MAXVAL, 8 );
+ write_int4( f, var );
+ write_float4( f, v->MaxVal[var] );
+ }
+
+ /* Compress mode */
+ WRITE_TAG( v, TAG_COMPRESS, 4 );
+ write_int4( f, v->CompressMode );
+
+ /* Vertical Coordinate System */
+ WRITE_TAG( v, TAG_VERTICAL_SYSTEM, 4 );
+ write_int4( f, v->VerticalSystem );
+ WRITE_TAG( v, TAG_VERT_ARGS, 4+4*MAXVERTARGS );
+ write_int4( f, MAXVERTARGS );
+ write_float4_array( f, v->VertArgs, MAXVERTARGS );
+
+ /* Map Projection */
+ WRITE_TAG( v, TAG_PROJECTION, 4 );
+ write_int4( f, v->Projection );
+ WRITE_TAG( v, TAG_PROJ_ARGS, 4+4*MAXPROJARGS );
+ write_int4( f, MAXPROJARGS );
+ write_float4_array( f, v->ProjArgs, MAXPROJARGS );
+
+ /* write END tag */
+ if (newfile) {
+ /* We're writing to a brand new file. Reserve 10000 bytes */
+ /* for future header growth. */
+ WRITE_TAG( v, TAG_END, 10000 );
+ lseek( f, 10000, SEEK_CUR );
+
+ /* Let file pointer indicate where first grid is stored */
+ v->FirstGridPos = ltell( f );
+ }
+ else {
+ /* we're rewriting a header */
+ filler = v->FirstGridPos - ltell(f);
+ WRITE_TAG( v, TAG_END, filler-8 );
+ }
+
+#undef WRITE_TAG
+
+ return 1;
+}
+
+
+
+/*
+ * Open a v5d file for writing. If the named file already exists,
+ * it will be deleted.
+ * Input: filename - name of v5d file to create.
+ * v - pointer to v5dstruct with the header info to write.
+ * Return: 1 = ok, 0 = error.
+ */
+int v5dCreateFile( const char *filename, v5dstruct *v )
+{
+ mode_t mask;
+ int fd;
+
+ mask = 0666;
+ fd = open( filename, O_WRONLY | O_CREAT | O_TRUNC, mask );
+ if (fd==-1) {
+ printf("Error in v5dCreateFile: open failed\n");
+ v->FileDesc = -1;
+ v->Mode = 0;
+ return 0;
+ }
+ else {
+ /* ok */
+ v->FileDesc = fd;
+ v->Mode = 'w';
+ /* write header and return status */
+ return write_v5d_header(v);
+ }
+}
+
+
+
+/*
+ * Open a v5d file for updating/appending and read the header info.
+ * Input: filename - name of v5d file to open for updating.
+ * v - pointer to v5dstruct in which the file header info will be
+ * put. If v is NULL a v5dstruct will be allocated and returned.
+ * Return: NULL if error, else v or a pointer to a new v5dstruct if v as NULL
+ */
+v5dstruct *v5dUpdateFile( const char *filename, v5dstruct *v )
+{
+ int fd;
+
+ fd = open( filename, O_RDWR );
+ if (fd==-1) {
+ return NULL;
+ }
+
+ if (!v) {
+ v = v5dNewStruct();
+ if (!v) {
+ return NULL;
+ }
+ }
+
+ v->FileDesc = fd;
+ v->Mode = 'w';
+
+ if (read_v5d_header( v )) {
+ return v;
+ }
+ else {
+ return NULL;
+ }
+}
+
+
+
+/*
+ * Write a compressed grid to a v5d file.
+ * Input: v - pointer to v5dstruct describing the file
+ * time, var - which timestep and variable
+ * ga, gb - the GA and GB (de)compression value arrays
+ * compdata - address of array of compressed data values
+ * Return: 1 = ok, 0 = error.
+ */
+int v5dWriteCompressedGrid( const v5dstruct *v, int time, int var,
+ const float *ga, const float *gb,
+ const void *compdata )
+{
+ int pos, n, k;
+
+ /* simple error checks */
+ if (v->Mode!='w') {
+ printf("Error in v5dWriteCompressedGrid: file opened for reading,");
+ printf(" not writing.\n");
+ return 0;
+ }
+ if (time<0 || time>=v->NumTimes) {
+ printf("Error in v5dWriteCompressedGrid: bad timestep argument (%d)\n",
+ time);
+ return 0;
+ }
+ if (var<0 || var>=v->NumVars) {
+ printf("Error in v5dWriteCompressedGrid: bad variable argument (%d)\n",
+ var);
+ return 0;
+ }
+
+ /* move to position in file */
+ pos = grid_position( v, time, var );
+ if (lseek( v->FileDesc, pos, SEEK_SET )<0) {
+ /* lseek failed, return error */
+ printf("Error in v5dWrite[Compressed]Grid: seek failed, disk full?\n");
+ return 0;
+ }
+
+ /* write ga, gb arrays */
+ k = 0;
+ if (write_float4_array( v->FileDesc, ga, v->Nl[var] ) == v->Nl[var] &&
+ write_float4_array( v->FileDesc, gb, v->Nl[var] ) == v->Nl[var]) {
+ /* write compressed grid data (k=1=OK, k=0=Error) */
+ n = v->Nr * v->Nc * v->Nl[var];
+ if (v->CompressMode==1) {
+ k = write_block( v->FileDesc, compdata, n, 1 )==n;
+ }
+ else if (v->CompressMode==2) {
+ k = write_block( v->FileDesc, compdata, n, 2 )==n;
+ }
+ else if (v->CompressMode==4) {
+ k = write_block( v->FileDesc, compdata, n, 4 )==n;
+ }
+ }
+
+ if (k==0) {
+ /* Error while writing */
+ printf("Error in v5dWrite[Compressed]Grid: write failed, disk full?\n");
+ }
+ return k;
+
+/*
+ n = v->Nr * v->Nc * v->Nl[var] * v->CompressMode;
+ if (write_bytes( v->FileDesc, compdata, n )!=n) {
+ printf("Error in v5dWrite[Compressed]Grid: write failed, disk full?\n");
+ return 0;
+ }
+ else {
+ return 1;
+ }
+*/
+}
+
+
+
+
+/*
+ * Compress a grid and write it to a v5d file.
+ * Input: v - pointer to v5dstruct describing the file
+ * time, var - which timestep and variable (starting at 0)
+ * data - address of uncompressed grid data
+ * Return: 1 = ok, 0 = error.
+ */
+int v5dWriteGrid( v5dstruct *v, int time, int var, const float data[] )
+{
+ float ga[MAXLEVELS], gb[MAXLEVELS];
+ void *compdata;
+ int n, bytes;
+ float min, max;
+
+ if (v->Mode!='w') {
+ printf("Error in v5dWriteGrid: file opened for reading,");
+ printf(" not writing.\n");
+ return 0;
+ }
+ if (time<0 || time>=v->NumTimes) {
+ printf("Error in v5dWriteGrid: bad timestep argument (%d)\n", time);
+ return 0;
+ }
+ if (var<0 || var>=v->NumVars) {
+ printf("Error in v5dWriteGrid: bad variable argument (%d)\n", var);
+ return 0;
+ }
+
+ /* allocate compdata buffer */
+ if (v->CompressMode==1) {
+ bytes = v->Nr * v->Nc * v->Nl[var] * sizeof(unsigned char);
+ }
+ else if (v->CompressMode==2) {
+ bytes = v->Nr * v->Nc * v->Nl[var] * sizeof(unsigned short);
+ }
+ else if (v->CompressMode==4) {
+ bytes = v->Nr * v->Nc * v->Nl[var] * sizeof(float);
+ }
+ compdata = (void *) malloc( bytes );
+ if (!compdata) {
+ printf("Error in v5dWriteGrid: out of memory (needed %d bytes)\n",
+ bytes );
+ return 0;
+ }
+
+ /* compress the grid data */
+ v5dCompressGrid( v->Nr, v->Nc, v->Nl[var], v->CompressMode, data,
+ compdata, ga, gb, &min, &max );
+
+ /* update min and max value */
+ if (min<v->MinVal[var])
+ v->MinVal[var] = min;
+ if (max>v->MaxVal[var])
+ v->MaxVal[var] = max;
+
+ /* write the compressed grid */
+ n = v5dWriteCompressedGrid( v, time, var, ga, gb, compdata );
+
+ /* free compdata */
+ free( compdata );
+
+ return n;
+}
+
+
+
+/*
+ * Close a v5d file which was opened with open_v5d_file() or
+ * create_v5d_file().
+ * Input: f - file descriptor
+ * Return: 1 = ok, 0 = error
+ */
+int v5dCloseFile( v5dstruct *v )
+{
+ int status = 1;
+
+ if (v->Mode=='w') {
+ /* rewrite header because writing grids updates the minval and */
+ /* maxval fields */
+ lseek( v->FileDesc, 0, SEEK_SET );
+ status = write_v5d_header( v );
+ lseek( v->FileDesc, 0, SEEK_END );
+ close( v->FileDesc );
+ }
+ else if (v->Mode=='r') {
+ /* just close the file */
+ close(v->FileDesc);
+ }
+ else {
+ printf("Error in v5dCloseFile: bad v5dstruct argument\n");
+ return 0;
+ }
+ v->FileDesc = -1;
+ v->Mode = 0;
+ return status;
+}
+
+
+
+
+/**********************************************************************/
+/***** Simple v5d file writing functions. *****/
+/**********************************************************************/
+
+
+
+static v5dstruct *Simple = NULL;
+
+
+
+/*
+ * Create a new v5d file specifying both a map projection and vertical
+ * coordinate system. See README file for argument details.
+ * Return: 1 = ok, 0 = error.
+ */
+int v5dCreate( const char *name, int numtimes, int numvars,
+ int nr, int nc, const int nl[],
+ const char varname[MAXVARS][10],
+ const int timestamp[], const int datestamp[],
+ int compressmode,
+ int projection,
+ const FLOAT proj_args[],
+ int vertical,
+ const FLOAT vert_args[] )
+{
+ int var, time, maxnl, i;
+
+ /* initialize the v5dstruct */
+ Simple = v5dNewStruct();
+
+ Simple->NumTimes = numtimes;
+ Simple->NumVars = numvars;
+ Simple->Nr = nr;
+ Simple->Nc = nc;
+ maxnl = nl[0];
+ for (var=0;var<numvars;var++) {
+ if (nl[var]>maxnl) {
+ maxnl = nl[var];
+ }
+ Simple->Nl[var] = nl[var];
+ Simple->LowLev[var] = 0;
+ strncpy( Simple->VarName[var], varname[var], 10 );
+ Simple->VarName[var][9] = 0;
+ }
+
+ /* time and date for each timestep */
+ for (time=0;time<numtimes;time++) {
+ Simple->TimeStamp[time] = timestamp[time];
+ Simple->DateStamp[time] = datestamp[time];
+ }
+
+ Simple->CompressMode = compressmode;
+
+ /* Map projection and vertical coordinate system */
+ Simple->Projection = projection;
+#ifdef VPP
+ {
+ int i;
+ for (i=0;i<MAXPROJARGS;i++)
+ Simple->ProjArgs[i] = (float)proj_args[i];
+ }
+#else
+ memcpy( Simple->ProjArgs, proj_args, MAXPROJARGS*sizeof(float) );
+#endif
+ Simple->VerticalSystem = vertical;
+ if (vertical == 3) {
+ /* convert pressures to heights */
+ for (i=0; i<MAXVERTARGS; i++) {
+ if (vert_args[i] > 0.000001) {
+ Simple->VertArgs[i] = pressure_to_height((float)vert_args[i]);
+ }
+ else Simple->VertArgs[i] = 0.0;
+ }
+ }
+ else {
+#ifdef VPP
+ {
+ int i;
+ for (i=0;i<MAXVERTARGS;i++)
+ Simple->VertArgs[i] = (float)vert_args[i];
+ }
+#else
+ memcpy( Simple->VertArgs, vert_args, MAXVERTARGS*sizeof(float) );
+#endif
+ }
+
+ /* create the file */
+ if (v5dCreateFile( name, Simple )==0) {
+ printf("Error in v5dCreateSimpleFile: unable to create %s\n", name );
+ return 0;
+ }
+ else {
+ return 1;
+ }
+}
+
+
+
+/*
+ * Create a new v5d file using minimal information.
+ * Return: 1 = ok, 0 = error. See README file for argument details.
+ */
+int v5dCreateSimple( const char *name, int numtimes, int numvars,
+ int nr, int nc, int nl,
+ const char varname[MAXVARS][10],
+ const int timestamp[], const int datestamp[],
+ float northlat, float latinc,
+ float westlon, float loninc,
+ float bottomhgt, float hgtinc )
+{
+ int nlvar[MAXVARS];
+ int compressmode, projection, vertical;
+ FLOAT proj_args[100], vert_args[MAXLEVELS];
+ int i;
+
+ for (i=0;i<numvars;i++) {
+ nlvar[i] = nl;
+ }
+
+ compressmode = 1;
+
+ projection = 1;
+ proj_args[0] = northlat;
+ proj_args[1] = westlon;
+ proj_args[2] = latinc;
+ proj_args[3] = loninc;
+
+ vertical = 1;
+ vert_args[0] = bottomhgt;
+ vert_args[1] = hgtinc;
+
+ return v5dCreate( name, numtimes, numvars, nr, nc, nlvar,
+ varname, timestamp, datestamp, compressmode,
+ projection, proj_args, vertical, vert_args );
+}
+
+
+
+/*
+ * Set lowest levels for each variable (other than default of 0).
+ * Input: lowlev - array [NumVars] of ints
+ * Return: 1 = ok, 0 = error
+ */
+int v5dSetLowLev( int lowlev[] )
+{
+ int var;
+
+ if (Simple) {
+ for (var=0;var<Simple->NumVars;var++) {
+ Simple->LowLev[var] = lowlev[var];
+ }
+ return 1;
+ }
+ else {
+ printf("Error: must call v5dCreate before v5dSetLowLev\n");
+ return 0;
+ }
+}
+
+
+/*
+ * Set the units for a variable.
+ * Input: var - a variable in [1,NumVars]
+ * units - a string
+ * Return: 1 = ok, 0 = error
+ */
+int v5dSetUnits( int var, const char *units )
+{
+ if (Simple) {
+ if (var>=1 && var<=Simple->NumVars) {
+ strncpy( Simple->Units[var-1], units, 19 );
+ Simple->Units[var-1][19] = 0;
+ return 1;
+ }
+ else {
+ printf("Error: bad variable number in v5dSetUnits\n");
+ return 0;
+ }
+ }
+ else {
+ printf("Error: must call v5dCreate before v5dSetUnits\n");
+ return 0;
+ }
+}
+
+
+
+/*
+ * Write a grid to a v5d file.
+ * Input: time - timestep in [1,NumTimes]
+ * var - timestep in [1,NumVars]
+ * data - array [nr*nc*nl] of floats
+ * Return: 1 = ok, 0 = error
+ */
+int v5dWrite( int time, int var, const FLOAT data[] )
+{
+ if (Simple) {
+ if (time<1 || time>Simple->NumTimes) {
+ printf("Error in v5dWrite: bad timestep number: %d\n", time );
+ return 0;
+ }
+ if (var<1 || var>Simple->NumVars) {
+ printf("Error in v5dWrite: bad variable number: %d\n", var );
+ }
+#ifdef VPP
+ {
+ float *rdata;
+ int i,irep;
+ int size = Simple->Nr * Simple->Nc * Simple->Nl[var-1];
+ rdata = (float *)malloc(size * 4);
+ if (!rdata){
+ printf("Error in v5dWrite: out of memory\n");
+ return 0;
+ }
+ for (i=0;i<size;i++)
+ rdata[i] = (float)data[i];
+ irep = v5dWriteGrid( Simple, time-1, var-1, rdata );
+ free(rdata);
+ return irep;
+
+ }
+#else
+ return v5dWriteGrid( Simple, time-1, var-1, data );
+#endif
+ }
+ else {
+ printf("Error: must call v5dCreate before v5dWrite\n");
+ return 0;
+ }
+}
+
+
+
+/*
+ * Close a v5d file after the last grid has been written to it.
+ * Return: 1 = ok, 0 = error
+ */
+int v5dClose( void )
+{
+ if (Simple) {
+ int ok = v5dCloseFile( Simple );
+ v5dFreeStruct( Simple );
+ return ok;
+ }
+ else {
+ printf("Error: v5dClose: no file to close\n");
+ return 0;
+ }
+}
+
+
+
+/**********************************************************************/
+/***** FORTRAN-callable simple output *****/
+/**********************************************************************/
+
+
+/*
+ * Create a v5d file. See README file for argument descriptions.
+ * Return: 1 = ok, 0 = error.
+ */
+#ifdef UNDERSCORE
+ int v5dcreate_
+#else
+# ifdef _CRAY
+ int V5DCREATE
+# else
+ int v5dcreate
+# endif
+#endif
+ ( const char *name, const int *numtimes, const int *numvars,
+ const int *nr, const int *nc, const int nl[],
+ const char varname[][10],
+ const int timestamp[], const int datestamp[],
+ const int *compressmode,
+ const int *projection,
+ const FLOAT proj_args[],
+ const int *vertical,
+ const FLOAT vert_args[] )
+{
+ char filename[100];
+ char names[MAXVARS][10];
+ int i, maxnl, args;
+
+ /* copy name to filename and remove trailing spaces if any */
+ copy_string( filename, name, 100 );
+
+ /*
+ * Check for uninitialized arguments
+ */
+ if (*numtimes<1) {
+ printf("Error: numtimes invalid\n");
+ return 0;
+ }
+ if (*numvars<1) {
+ printf("Error: numvars invalid\n");
+ return 0;
+ }
+ if (*nr<2) {
+ printf("Error: nr invalid\n");
+ return 0;
+ }
+ if (*nc<2) {
+ printf("Error: nc invalid\n");
+ return 0;
+ }
+ maxnl = 0;
+ for (i=0;i<*numvars;i++) {
+ if (nl[i]<1) {
+ printf("Error: nl(%d) invalid\n", i+1);
+ return 0;
+ }
+ if (nl[i]>maxnl) {
+ maxnl = nl[i];
+ }
+ }
+
+ for (i=0;i<*numvars;i++) {
+ if (copy_string2( names[i], varname[i], 10)==0) {
+ printf("Error: unitialized varname(%d)\n", i+1);
+ return 0;
+ }
+ }
+
+ for (i=0;i<*numtimes;i++) {
+ if (timestamp[i]<0) {
+ printf("Error: times(%d) invalid\n", i+1);
+ return 0;
+ }
+ if (datestamp[i]<0) {
+ printf("Error: dates(%d) invalid\n", i+1);
+ return 0;
+ }
+ }
+
+ if (*compressmode != 1 && *compressmode != 2 && *compressmode != 4) {
+ printf("Error: compressmode invalid\n");
+ return 0;
+ }
+
+ switch (*projection) {
+ case 0:
+ args = 4;
+ break;
+ case 1:
+ args = 0;
+ if (IS_MISSING(proj_args[0])) {
+ printf("Error: northlat (proj_args(1)) invalid\n");
+ return 0;
+ }
+ if (IS_MISSING(proj_args[1])) {
+ printf("Error: westlon (proj_args(2)) invalid\n");
+ return 0;
+ }
+ if (IS_MISSING(proj_args[2])) {
+ printf("Error: latinc (proj_args(3)) invalid\n");
+ return 0;
+ }
+ if (IS_MISSING(proj_args[3])) {
+ printf("Error: loninc (proj_args(4)) invalid\n");
+ return 0;
+ }
+ break;
+ case 2:
+ args = 6;
+ break;
+ case 3:
+ args = 5;
+ break;
+ case 4:
+ args = 7;
+ break;
+ default:
+ args = 0;
+ printf("Error: projection invalid\n");
+ return 0;
+ }
+ for (i=0;i<args;i++) {
+ if (IS_MISSING(proj_args[i])) {
+ printf("Error: proj_args(%d) invalid\n", i+1);
+ return 0;
+ }
+ }
+
+ switch (*vertical) {
+ case 0:
+/* WLH 31 Oct 96 - just fall through
+ args = 4;
+ break;
+*/
+ case 1:
+ args = 0;
+ if (IS_MISSING(vert_args[0])) {
+ printf("Error: bottomhgt (vert_args(1)) invalid\n");
+ return 0;
+ }
+ if (IS_MISSING(vert_args[1])) {
+ printf("Error: hgtinc (vert_args(2)) invalid\n");
+ return 0;
+ }
+ break;
+ case 2:
+ case 3:
+ args = maxnl;
+ break;
+ default:
+ args = 0;
+ printf("Error: vertical invalid\n");
+ return 0;
+ }
+ for (i=0;i<args;i++) {
+ if (IS_MISSING(vert_args[i])) {
+ printf("Error: vert_args(%d) invalid\n", i+1);
+ return 0;
+ }
+ }
+
+ return v5dCreate( filename, *numtimes, *numvars, *nr, *nc, nl,
+ (const char(*)[10]) names, timestamp, datestamp,
+ *compressmode,
+ *projection, proj_args, *vertical, vert_args );
+}
+
+
+
+
+/*
+ * Create a simple v5d file. See README file for argument descriptions.
+ * Return: 1 = ok, 0 = error.
+ */
+#ifdef UNDERSCORE
+ int v5dcreatesimple_
+#else
+# ifdef _CRAY
+ int V5DCREATESIMPLE
+# else
+ int v5dcreatesimple
+# endif
+#endif
+ ( const char *name, const int *numtimes, const int *numvars,
+ const int *nr, const int *nc, const int *nl,
+ const char varname[][10],
+ const int timestamp[], const int datestamp[],
+ const float *northlat, const float *latinc,
+ const float *westlon, const float *loninc,
+ const float *bottomhgt, const float *hgtinc )
+{
+ int compressmode, projection, vertical;
+ FLOAT projarg[100], vertarg[MAXLEVELS];
+ int varnl[MAXVARS];
+ int i;
+
+ for (i=0;i<MAXVARS;i++) {
+ varnl[i] = *nl;
+ }
+
+ compressmode = 1;
+
+ projection = 1;
+ projarg[0] = *northlat;
+ projarg[1] = *westlon;
+ projarg[2] = *latinc;
+ projarg[3] = *loninc;
+
+ vertical = 1;
+ vertarg[0] = *bottomhgt;
+ vertarg[1] = *hgtinc;
+
+#ifdef UNDERSCORE
+ return v5dcreate_
+#else
+# ifdef _CRAY
+ return V5DCREATE
+# else
+
+ return v5dcreate
+# endif
+#endif
+ ( name, numtimes, numvars, nr, nc, varnl,
+ varname, timestamp, datestamp, &compressmode,
+ &projection, projarg, &vertical, vertarg );
+}
+
+
+
+/*
+ * Set lowest levels for each variable (other than default of 0).
+ * Input: lowlev - array [NumVars] of ints
+ * Return: 1 = ok, 0 = error
+ */
+#ifdef UNDERSCORE
+ int v5dsetlowlev_
+#else
+# ifdef _CRAY
+ int V5DSETLOWLEV
+# else
+ int v5dsetlowlev
+# endif
+#endif
+ ( int *lowlev )
+{
+ return v5dSetLowLev(lowlev);
+}
+
+
+
+/*
+ * Set the units for a variable.
+ * Input: var - variable number in [1,NumVars]
+ * units - a character string
+ * Return: 1 = ok, 0 = error
+ */
+#ifdef UNDERSCORE
+ int v5dsetunits_
+#else
+# ifdef _CRAY
+ int V5DSETUNITS
+# else
+ int v5dsetunits
+# endif
+#endif
+ ( int *var, char *name )
+{
+ return v5dSetUnits( *var, name );
+}
+
+
+
+/*
+ * Write a grid of data to the file.
+ * Input: time - timestep in [1,NumTimes]
+ * var - timestep in [1,NumVars]
+ * data - array [nr*nc*nl] of floats
+ * Return: 1 = ok, 0 = error
+ */
+#ifdef UNDERSCORE
+ int v5dwrite_
+#else
+# ifdef _CRAY
+ int V5DWRITE
+# else
+ int v5dwrite
+# endif
+#endif
+ ( const int *time, const int *var, const FLOAT *data )
+{
+ return v5dWrite( *time, *var, data );
+}
+
+
+
+/*
+ * Specify the McIDAS GR3D file number and grid number which correspond
+ * to the grid specified by time and var.
+ * Input: time, var - timestep and variable of grid (starting at 1)
+ * mcfile, mcgrid - McIDAS grid file number and grid number
+ * Return: 1 = ok, 0 = errror (bad time or var)
+ */
+#ifdef UNDERSCORE
+ int v5dmcfile_
+#else
+# ifdef _CRAY
+ int V5DMCFILE
+# else
+ int v5dmcfile
+# endif
+#endif
+ ( const int *time, const int *var,
+ const int *mcfile, const int *mcgrid )
+{
+ if (*time<1 || *time>Simple->NumTimes) {
+ printf("Bad time argument to v5dSetMcIDASgrid: %d\n", *time );
+ return 0;
+ }
+ if (*var<1 || *var>Simple->NumVars) {
+ printf("Bad var argument to v5dSetMcIDASgrid: %d\n", *var );
+ return 0;
+ }
+
+ Simple->McFile[*time-1][*var-1] = (short) *mcfile;
+ Simple->McGrid[*time-1][*var-1] = (short) *mcgrid;
+ return 1;
+}
+
+
+
+/*
+ * Close a simple v5d file.
+ */
+#ifdef UNDERSCORE
+ int v5dclose_( void )
+#else
+# ifdef _CRAY
+ int V5DCLOSE( void )
+# else
+ int v5dclose( void )
+# endif
+#endif
+{
+ return v5dClose();
+}
diff --git a/LIBTOOLS/lib/vis5d/src/v5d.h b/LIBTOOLS/lib/vis5d/src/v5d.h
new file mode 100644
index 0000000000000000000000000000000000000000..97d2441a68767c139b10aedcb93bfe7ce9431623
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/src/v5d.h
@@ -0,0 +1,310 @@
+
+/* Vis5D version 5.1 */
+
+/*
+Vis5D system for visualizing five dimensional gridded data sets
+Copyright (C) 1990 - 1996 Bill Hibbard, Brian Paul, Dave Santek,
+and Andre Battaiola.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+This program 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
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+*/
+
+
+
+#ifndef V5D_H
+#define V5D_H
+
+
+/*
+ * A numeric version number which we can test for in utility programs which
+ * use the v5d functions. For example, we can do tests like this:
+ * #if V5D_VERSION > 42
+ * do something
+ * #else
+ * do something else
+ * #endif
+ *
+ * If V5D_VERSION is not defined, then its value is considered to be zero.
+ */
+
+#define V5D_VERSION 42
+
+
+/*
+ * Define our own 1 and 2-byte data types. We use these names to avoid
+ * collisions with types defined by the OS include files.
+ */
+typedef unsigned char V5Dubyte; /* Must be 1 byte, except for cray */
+typedef unsigned short V5Dushort; /* Must be 2 byte, except for cray */
+
+
+
+#define MISSING 1.0e35
+#define IS_MISSING(X) ( (X) >= 1.0e30 )
+
+
+/* Limits on 5-D grid size: (must match those in v5df.h!!!) */
+#define MAXVARS 100
+#define MAXTIMES 400
+#define MAXROWS 800
+#define MAXCOLUMNS 800
+#define MAXLEVELS 100
+
+
+#ifdef VPP
+#define FLOAT double
+#else
+#define FLOAT float
+#endif
+
+/************************************************************************/
+/*** ***/
+/*** Functions for writing v5d files. See README file for details. ***/
+/*** These are the functions user's will want for writing file ***/
+/*** converters, etc. ***/
+/*** ***/
+/************************************************************************/
+
+extern int v5dCreateSimple( const char *name,
+ int numtimes, int numvars,
+ int nr, int nc, int nl,
+ const char varname[MAXVARS][10],
+ const int timestamp[],
+ const int datestamp[],
+ float northlat, float latinc,
+ float westlon, float loninc,
+ float bottomhgt, float hgtinc );
+
+
+extern int v5dCreate( const char *name,
+ int numtimes, int numvars,
+ int nr, int nc, const int nl[],
+ const char varname[MAXVARS][10],
+ const int timestamp[],
+ const int datestamp[],
+ int compressmode,
+ int projection,
+ const FLOAT proj_args[],
+ int vertical,
+ const FLOAT vert_args[] );
+
+
+extern int v5dWrite( int time, int var, const FLOAT data[] );
+
+extern int v5dClose( void );
+
+
+extern int v5dSetLowLev( int lowlev[] );
+
+extern int v5dSetUnits( int var, const char *units );
+
+
+
+/************************************************************************/
+/*** ***/
+/*** Definition of v5d struct and function prototypes. ***/
+/*** These functions are used by vis5d and advanced v5d utilities. ***/
+/*** ***/
+/************************************************************************/
+
+#define MAXPROJARGS 100
+#define MAXVERTARGS (MAXLEVELS+1)
+
+/*
+ * This struct describes the structure of a .v5d file.
+ */
+typedef struct {
+ /* PUBLIC (user can freely read, sometimes write, these fields) */
+ int NumTimes; /* Number of time steps */
+ int NumVars; /* Number of variables */
+ int Nr; /* Number of rows */
+ int Nc; /* Number of columns */
+ int Nl[MAXVARS]; /* Number of levels per variable */
+ int LowLev[MAXVARS]; /* Lowest level per variable */
+ char VarName[MAXVARS][10]; /* 9-character variable names */
+ char Units[MAXVARS][20]; /* 19-character units for variables */
+ int TimeStamp[MAXTIMES]; /* Time in HHMMSS format */
+ int DateStamp[MAXTIMES]; /* Date in YYDDD format */
+ float MinVal[MAXVARS]; /* Minimum variable data values */
+ float MaxVal[MAXVARS]; /* Maximum variable data values */
+
+ /* This info is used for external function computation */
+ short McFile[MAXTIMES][MAXVARS];/* McIDAS file number in 1..9999 */
+ short McGrid[MAXTIMES][MAXVARS];/* McIDAS grid number in 1..? */
+
+ int VerticalSystem; /* Which vertical coordinate system */
+ float VertArgs[MAXVERTARGS]; /* Vert. Coord. Sys. arguments... */
+
+ /*
+ IF VerticalSystem==0 THEN
+ -- Linear scale, equally-spaced levels in generic units
+ VertArgs[0] = Height of bottom-most grid level in generic units
+ VertArgs[1] = Increment between levels in generic units
+ ELSE IF VerticalSystem==1 THEN
+ -- Linear scale, equally-spaced levels in km
+ VertArgs[0] = Height of bottom grid level in km
+ VertArgs[1] = Increment between levels in km
+ ELSE IF VerticalSystem==2 THEN
+ -- Linear scale, Unequally spaced levels in km
+ VertArgs[0] = Height of grid level 0 (bottom) in km
+ ... ...
+ VertArgs[n] = Height of grid level n in km
+ ELSE IF VerticalSystem==3 THEN
+ -- Linear scale, Unequally spaced levels in mb
+ VertArgs[0] = Pressure of grid level 0 (bottom) in mb
+ ... ...
+ VertArgs[n] = Pressure of grid level n in mb
+ ENDIF
+ */
+
+ int Projection; /* Which map projection */
+ float ProjArgs[MAXPROJARGS]; /* Map projection arguments... */
+
+ /*
+ IF Projection==0 THEN
+ -- Rectilinear grid, generic units
+ ProjArgs[0] = North bound, Y coordinate of grid row 0
+ ProjArgs[1] = West bound, X coordiante of grid column 0
+ ProjArgs[2] = Increment between rows
+ ProjArgs[3] = Increment between colums
+ NOTES: X coordinates increase to the right, Y increase upward.
+ NOTES: Coordinate system is right-handed.
+ ELSE IF Projection==1 THEN
+ -- Cylindrical equidistant (Old VIS-5D)
+ -- Rectilinear grid in lat/lon
+ ProjArgs[0] = Latitude of grid row 0, north bound, in degrees
+ ProjArgs[1] = Longitude of grid column 0, west bound, in deg.
+ ProjArgs[2] = Increment between rows in degrees
+ ProjArgs[3] = Increment between rows in degrees
+ NOTES: Coordinates (degrees) increase to the left and upward.
+ ELSE IF Projection==2 THEN
+ -- Lambert conformal
+ ProjArgs[0] = Standared Latitude 1 of conic projection
+ ProjArgs[1] = Standared Latitude 2 of conic projection
+ ProjArgs[2] = Row of North/South pole
+ ProjArgs[3] = Column of North/South pole
+ ProjArgs[4] = Longitude which is parallel to columns
+ ProjArgs[5] = Increment between grid columns in km
+ ELSE IF Projection==3 THEN
+ -- Polar Stereographic
+ ProjArgs[0] = Latitude of center of projection
+ ProjArgs[1] = Longitude of center of projection
+ ProjArgs[2] = Grid row of center of projection
+ ProjArgs[3] = Grid column of center of projection
+ ProjArgs[4] = Increment between grid columns at center in km
+ ELSE IF Projection==4 THEN
+ -- Rotated
+ ProjArgs[0] = Latitude on rotated globe of grid row 0
+ ProjArgs[1] = Longitude on rotated globe of grid column 0
+ ProjArgs[2] = Degrees of latitude on rotated globe between
+ grid rows
+ ProjArgs[3] = Degrees of longitude on rotated globe between
+ grid columns
+ ProjArgs[4] = Earth latitude of (0, 0) on rotated globe
+ ProjArgs[5] = Earth longitude of (0, 0) on rotated globe
+ ProjArgs[6] = Clockwise rotation of rotated globe in degrees
+ ENDIF
+ */
+
+ int CompressMode; /* 1, 2 or 4 = # bytes per grid point */
+ char FileVersion[10]; /* 9-character version number */
+
+ /* PRIVATE (not to be touched by user code) */
+ unsigned int FileFormat; /* COMP5D file version or 0 if .v5d */
+ int FileDesc; /* Unix file descriptor */
+ char Mode; /* 'r' = read, 'w' = write */
+ int CurPos; /* current position of file pointer */
+ int FirstGridPos; /* position of first grid in file */
+ int GridSize[MAXVARS]; /* size of each grid */
+ int SumGridSizes; /* sum of GridSize[0..NumVars-1] */
+} v5dstruct;
+
+
+
+extern float pressure_to_height( float pressure);
+
+extern float height_to_pressure( float height );
+
+
+
+
+extern int v5dYYDDDtoDays( int yyddd );
+
+extern int v5dHHMMSStoSeconds( int hhmmss );
+
+extern int v5dDaysToYYDDD( int days );
+
+extern int v5dSecondsToHHMMSS( int seconds );
+
+
+extern void v5dPrintStruct( const v5dstruct *v );
+
+
+extern v5dstruct *v5dNewStruct( void );
+
+extern void v5dFreeStruct( v5dstruct* v );
+
+extern void v5dInitStruct( v5dstruct *v );
+
+extern int v5dVerifyStruct( const v5dstruct *v );
+
+
+extern void v5dCompressGrid( int nr, int nc, int nl, int compressmode,
+ const float data[], void *compdata,
+ float ga[], float gb[],
+ float *minval, float *maxval );
+
+
+extern void v5dDecompressGrid( int nr, int nc, int nl, int compressmode,
+ void *compdata,
+ float ga[], float gb[],
+ float data[] );
+
+
+extern int v5dSizeofGrid( const v5dstruct *v, int time, int var );
+
+
+extern v5dstruct *v5dOpenFile( const char *filename, v5dstruct *v );
+
+
+extern int v5dCreateFile( const char *filename, v5dstruct *v );
+
+
+extern v5dstruct *v5dUpdateFile( const char *filename, v5dstruct *v );
+
+
+extern int v5dCloseFile( v5dstruct *v );
+
+
+extern int v5dReadCompressedGrid( v5dstruct *v,
+ int time, int var,
+ float *ga, float *gb,
+ void *compdata );
+
+
+extern int v5dReadGrid( v5dstruct *v, int time, int var, float data[] );
+
+
+extern int v5dWriteCompressedGrid( const v5dstruct *v,
+ int time, int var,
+ const float *ga, const float *gb,
+ const void *compdata );
+
+
+extern int v5dWriteGrid( v5dstruct *v, int time, int var, const float data[] );
+
+
+
+#endif
diff --git a/LIBTOOLS/lib/vis5d/src/vis5d.h b/LIBTOOLS/lib/vis5d/src/vis5d.h
new file mode 100644
index 0000000000000000000000000000000000000000..6996f3f25bf493c9ba59bea4aa107ee28f92abae
--- /dev/null
+++ b/LIBTOOLS/lib/vis5d/src/vis5d.h
@@ -0,0 +1,102 @@
+
+/* Vis5D version 5.1 */
+
+/*
+Vis5D system for visualizing five dimensional gridded data sets
+Copyright (C) 1990-1997 Bill Hibbard, Brian Paul, Dave Santek,
+and Andre Battaiola.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 1, or (at your option)
+any later version.
+
+This program 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
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+*/
+
+
+/*
+ * This configuration file contains options which can be safely
+ * changed by the user.
+ */
+
+
+
+#ifndef VIS5D_H
+#define VIS5D_H
+
+
+/*
+ * Amount of physical RAM in megabytes:
+ * vis5d normally uses a bounded amount of memory to avoid swapping.
+ * When the limit is reached, the least-recently-viewed graphics will
+ * be deallocated. If MBS is set to 0, however, vis5d will use ordinary
+ * malloc/free and not deallocate graphics (ok for systems with a lot
+ * of memory (>=128MB)).
+ */
+/* Default Value: 32 */
+#define MBS 128
+
+
+
+/* Default topography file: */
+#define TOPOFILE "/home/chajpmnt/chajp/ADD/data/EARTH.TOPO"
+
+
+/* Default map lines files: */
+#define WORLDFILE "/home/chajpmnt/chajp/ADD/data/OUTLSUPW"
+#define USAFILE "/home/chajpmnt/chajp/ADD/data/OUTLUSAM"
+
+
+/* Default filename of Tcl startup commands: */
+#define TCL_STARTUP_FILE "vis5d.tcl"
+
+
+/* Default directory to search for user functions: */
+#define FUNCTION_PATH "userfuncs"
+
+
+/* Default animation rate in milliseconds: */
+#define ANIMRATE 100
+
+
+/* Default scale and exponent values for logrithmic vertical coordinate system: */
+#define DEFAULT_LOG_SCALE 1012.5
+#define DEFAULT_LOG_EXP -7.2
+
+
+#define DEFAULT_SOUNDFONTNAME "6x12"
+
+/**********************************************************************/
+/**********************************************************************/
+/*** USERS: DON'T CHANGE ANYTHING BEYOND THIS POINT ***/
+/**********************************************************************/
+/**********************************************************************/
+
+/*
+ * Define BIG_GFX to allow larger isosurfaces, contour slices, etc. if
+ * there's enough memory.
+#if MBS==0 || MBS>=128
+# define BIG_GFX
+#endif
+ */
+
+#define BIG_GFX
+
+
+/*
+ * Shared by code above and below API:
+ */
+#define MAX_LABEL 1000
+#define MAX_FUNCS 100
+
+
+
+#endif
diff --git a/LIBTOOLS/readme/LATEX/Makefile b/LIBTOOLS/readme/LATEX/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..a69c6f90648fcec70676b6c4004f168dbf6a9d2f
--- /dev/null
+++ b/LIBTOOLS/readme/LATEX/Makefile
@@ -0,0 +1,13 @@
+tools.ps : tools.dvi
+ dvips -o $@ $<
+
+tools.dvi : tools.tex
+ latex tools.tex
+ latex tools.tex
+ latex tools.tex
+
+clean:
+ rm -f *.aux *.log *.toc *.dvi
+
+realclean: clean
+ rm -f *.ps
diff --git a/LIBTOOLS/readme/LATEX/conv2dia.tex b/LIBTOOLS/readme/LATEX/conv2dia.tex
new file mode 100644
index 0000000000000000000000000000000000000000..e6596ca0ec6fded8c19c049ac683a9530fc9c97e
--- /dev/null
+++ b/LIBTOOLS/readme/LATEX/conv2dia.tex
@@ -0,0 +1,102 @@
+\section{Conversion of FM synchronous file to diachronic format}
+Short description is given here, readers must refer to the original documentation on the Meso-NH web site:
+``{\sc traitement graphique des fichiers synchrones produits par le mod\`ele
+mesonh}, J. Duron''.
+
+\subsection{Synchronous and diachronic formats} \label{diachro_file}
+The Meso-NH graphic utility ({\tt diaprog}) works on FM files which are on
+diachronic format. A diachronic FM file is either
+\begin{itemize}
+\item
+a file produced during the simulation
+which contain time series of self-documented informations
+(e.g. file with name CEXP.1.CSEG.000).
+An information is one of the following:
+\subitem - a
+3-dimensional, 2-dimensional, 1-dimensional or 0-dimensional field (eventually
+time-averaged, or compressed in one direction): type {\sc cart},
+\subitem - a set of vertical profiles at points checking some criteria:
+type {\sc mask},
+\subitem - spectral coefficients obtained by FFT along the X or Y direction:
+type {\sc spxy},
+\subitem - pseudo-observations (ground station: type {\sc ssol};
+dropsonde: type {\sc drst}; radiosonde: type {\sc rspl};
+airborne radar: type {\sc rapl}).
+ \\
+A diachronic file can contains informations of one or several previous types
+stored at different time frequency.
+For a whole description about the diachronic file type, reader must refer
+to the original documentation on the Meso-NH web site:
+``{\sc cr\'eation et exploitation de fichiers diachroniques}, J. Duron''.
+\end{itemize}
+or
+\begin{itemize}
+\item a `pseudo'-diachronic file resulting of the conversion of a synchronous
+file (e.g. with name CEXP.1.CSEG.00n where n$>$0).
+Recall that such a file contains all the pronostic fields of the model at one
+instant (initial or during the simulation).
+When converted it is a 'pseudo'-diachronic file, because it contains only one
+instant and one type of diachronic information ({\sc cart}).
+The next subsection presents the conversion tool (named \texttt{conv2dia})
+to apply to synchronous files, necessary step to use \texttt{diaprog} graphic
+tool.
+\end{itemize}
+
+\subsection{{\tt conv2dia} tool}
+The conversion tool works on files produced by
+the initialisation programs ({\sc prep\_pgd, prep\_ideal\_case,
+prep\_real\_case}), the model simulation, or the post-processing program
+({\tt\sc diag}). It allows to convert one synchronous file onto one diachronic
+file, as well as merge several synchronous files with chronological times
+(outputs of one run, or files initialised from large-scale model)
+onto one diachronic file.
+
+With {\tt conv2dia.elim} tool, you can choose not to convert all the fields of
+the input file(s). The pronostic fields at $t-dt$ instant, or at $t$ instant,
+or any other fields can be eliminated.
+With {\tt conv2dia.select} tool, you have to indicate the fields to select
+for conversion.
+This is done to reduce the size of the output file.
+
+The output file contains informations whose type is {\sc cart} stored in arrays
+with size of {\tt (IIU*IJU*IKU), (IIU*IJU), (IIU*IKU),} or 1.
+
+
+\subsection{Example}
+
+Only the binary (\textsc{LFI}) part of the input FM files is required
+in the current directory (split the FM file with the {\tt fm2deslfi}
+script if not).
+
+All characters typed on keyboard are saved in {\tt dirconv.elim} or
+{\tt dirconv.select} file, it can be appended and used as input (after being
+renamed) for the next call of the tool
+\newline (e.g. {\tt conv2dia.elim < dirconv.elim.ex}).
+
+Below is the example of questions when {\tt conv2dia.elim} is invoked.
+
+\small
+\begin{tabular}{l}
+\\
+\\
+{\tt ENTER NUMBER OF INPUT FM FILES} \\
+{\tt\it 2 } \\
+{\tt ENTER FM FILE NAME} \\
+{\tt\it CEXP.1.CSEG.001} \\
+{\tt ENTER FM FILE NAME} \\
+{\tt\it CEXP.1.CSEG.002} \\
+{\tt ENTER DIACHRONIC FILE NAME} \\
+{\tt\it CEXP.1.CSEG.1-2.dia} \\
+{\tt DELETION OF PARAMETERS AT TIME t-dt ? (enter 1) } \\
+{\tt DELETION OF PARAMETERS AT TIME t ? (enter 2) } \\
+{\tt NO DELETION ? (enter 0) } \\
+{\tt\it 2 } \\
+{\tt Do you want to suppress others parameters ? (y/n) }\\
+{\tt\it y } \\
+{\tt Enter their names in UPPERCASE (1/1 line) }\\
+{\tt End by END}\\
+{\tt\it DTHCONV } \\
+{\tt\it DRVCONV } \\
+{\tt\it END } \\
+\end{tabular}
+\normalsize
diff --git a/LIBTOOLS/readme/LATEX/extract.tex b/LIBTOOLS/readme/LATEX/extract.tex
new file mode 100644
index 0000000000000000000000000000000000000000..6f9585e13ef74b4cae5d4945e388ddbfa127997f
--- /dev/null
+++ b/LIBTOOLS/readme/LATEX/extract.tex
@@ -0,0 +1,436 @@
+\section{Dealing with diachronic files}
+The Meso-NH program of post-processing ({\sc diag}) treats synchronous
+files from initialization or simulation.
+For a given need, one wants to work on fields stored in
+a diachronic file before exploration with {\tt diaprog} or with another
+graphical tool to possibly compare with observations.
+
+\begin{itemize}
+\item The \texttt{extractdia} tool allows to extract fields from a diachronic
+file, on the whole domain or on a part of it, to interpole them (horizontal
+grid and/or vertical grid) and to write
+them in some other given formats (section \ref{extractdia}).
+This program is based on a routine of reading and a routine of writing of
+diachronic variables:
+they are the essential source lines to deal with a diachronic file.
+These 2 routines can be used in the user own program to match his personal
+needs. An example of such a program \texttt{exrwdia.f90} and how to compile it
+is given in section \ref{exrwdia}.
+\end{itemize}
+
+Some other tools based on the 2 routines of reading and writing
+are also available to allow easier comparisons with observation
+data (sections \ref{mnh2obs} and \ref{obs2mnh}):
+\begin{itemize}
+\item \texttt{mesonh2obs} to get MesoNH field values at given
+observation points (the format of output file is ASCII),
+\item \texttt{obs2mesonh} to put observation values on a
+given MesoNH grid (the output file has diachronic FM format),
+observations can then be plotted with \texttt{diaprog} tool.
+\item \texttt{compute\_r00\_pc} to catenate evolution of Lagrangian tracers
+back to the model start (as done in {\sc diag} program, see documentation
+``Lagrangian trajectory and air-mass tracking analyses with
+MesoNH by means of Eulerian passive tracers'', Gheusi and Stein, 2005).
+\end{itemize}
+
+The figure \ref{outils_dia} resumes the input and output of these tools.
+\begin{figure}[htb]
+\centerline{\psfig{file=outils_dia.eps,width=10cm,angle=270} }
+\caption{\label{outils_dia}}
+\end{figure}
+\\
+
+\underline{Remark}:
+ for all the following tools, the input diachronic files can be located
+in another directory than the one in which the tool is invoked (as
+for \texttt{diaprog}). In this case, initialise the following shell variable
+\begin{verbatim}
+export DIRLFI=directory_files_diachro
+\end{verbatim}
+
+Shell links will be automatically performed during the execution and
+will be removed by the mesonh-shell-tool \texttt{rmlink} at the execution end.
+
+
+\subsection{Extracte fields, domain, change format with
+{\tt extractdia} tool}\label{extractdia}
+
+The input file is a FM diachronic file, either a `true' diachronic one
+(its name is ended by {\bf .000} and it contains time series of informations
+obtained during the run of the model),
+or a `pseudo'-diachronic one (it is the result of the conversion of a
+synchronous file, see section \ref{diachro_file}), compressed (with {\tt lfiz})
+or not.
+
+The format of the output file is chosen by the user among one of the following:
+\begin{itemize}
+\item a FM {\sc diac}hronic file,
+\item an ASCII file with
+{\sc l}atitude-{\sc l}ongitude-{\sc h}eight-{\sc v}alue or
+latitude-longitude-height-value,
+\item ASCII files with {\sc free} format defined by the user (one file per field),
+\item a {\sc cdl} file (converted to NetCDF format at the end of the program,
+with \texttt{ncgen} utility of NetCDF package inside the mesonh-shell-tool \texttt{tonetcdf}),
+\item a {\sc grib} file (in the future),
+\item a {\sc Vis5D} file (in the future).
+\end{itemize}
+The main program is an interactive one:
+the name of input diachronic file, the output format,
+the coordinates of the part of the domain,
+the name of fields to be read and written are required.
+All that is typed on keyboard is saved in {\tt dirextr.}fmt
+file, it can be appended and used as input (after renaming it) for the next call
+of the tool \\
+(e.g. {\tt mv dirextr.DIAC dirDIAC1 ; extractdia < dirDIAC1}).
+\\
+\\
+The advantages for each output format are the following:
+
+\begin{itemize}
+\item the wind direction (dd) and wind intensity (ff) could be asked.
+\item fields are eventually interpolated according output format,
+first vertically and then horizontally.
+For vertical interpolation, the user specifies the type of levels (Z or P),
+the number of levels and their values (in m or in hPa). No vertical interpolation if the type of levels is K (model levels).
+
+For horizontal interpolation on regular grid in longitude and latitude, the program chooses the optimum values computed for the model grid.
+
+If interpolations are required, the wind components are transformed in zonal and meridian components.
+
+These interpolations do not allow interpolation in a required cross-section, the {\sc ficval} file obtained during a {\tt diaprog} session gives this interpolation.
+\item for the {\sc diac}hronic format, the output file will be reduced in size
+since it contains only some fields on a part of the domain without any interpolations .
+It can still be plotted with {\tt diaprog}.
+\item for the {\sc ll*v}/ll*v format, the fields can be interpolated onto a
+regular grid in longitude and latitude ({\sc lalo} option) or can remained on
+the conformal model grid.
+({\sc llzv}/llzv option for interpolation on constant altitude levels,
+{\sc llpv}/llpv option for interpolation on constant pression levels
+{\sc llhv}/lhzv option to stay on MesoNH vertical levels).
+Three header lines give zoom, unit, variable name and temporal informations and
+are followed by four values on each line.
+\item for the {\sc cdl} format, the fields can be horizontally interpolated
+onto a regular grid in longitude and latitude ({\sc lalo} option),
+and eventually vertically on some prescribed levels
+({\sc zcdl} option for interpolation on constant altitude levels,
+{\sc pcdl} option for interpolation on constant pression levels,
+{\sc kcdl} option to stay on MesoNH vertical levels).
+The CDL format is transformed to binary Netdcf format at the end of the program run by the mesonh-shell-tool \texttt{tonetcdf}.
+\item the {\sc free} format allows to get the interpolated values (vertical or horizontal interpolations) without any geographical locations: just values list are available after one header line.
+\ignore{
+\item for the {\sc grib} format, the fields can be horizontally interpolated
+onto a regular grid in longitude and latitude and are vertically interpolated
+on constant Z-levels or P-levels.
+}%ignore
+\end{itemize}
+
+
+\subsection{Personal modifications: \texttt{exrwdia} program}\label{exrwdia}
+The \texttt{extractdia} program uses 2 routines of reading
+(\texttt{readvar.f90}) and writing (\texttt{writevar.f90}) of MesoNH variables
+as they are stored in diachronic files (that is in 6-dimensional arrays).
+These 2 routines can be used in your own program:
+an example of such a program is \texttt{exrwdia.f90}.
+The source code contains extended comments,
+and there are some examples of computation with the extracted fields
+(module and direction of components of wind, interpolation on some Z levels,
+maximum of a 3D field along the vertical direction, vertical average between two
+Z levels).
+
+The use of this method need to be familiar with the Mesonh specificities:
+ seven grids (Gal-Chen) for the storage of the variables, the U,V wind components are
+ referenced in the Mesonh grid and are different from the Uzonal and Vmeridian
+ components.
+
+\subsubsection{Routines of reading and writing}
+A diachronic file contain time series of informations that are
+self-documented (section \ref{diachro_file}).
+The self-documentation is provided by the header of the file, which contains
+a list of pre-defined records, and each field (or information)
+is stored by several records, the number of them varies
+from 8 to 11, according to the type of the information
+({\sc cart, mask, spxy, ssol, drst, rspl} or {\sc rapl}).
+
+The subroutine \texttt{readvar.f90} reads the required field. At the first call,
+the file is opened, its header is read
+(the dimensions of the total domain ({\sc imax, jmax, kmax}),
+the orography...)
+and some characteristics are computed
+(the conformal coordinates, the map factor...).
+The required field is then read and available in a 6-dimensional array:
+{\sc xvar}(i,j,k,t,n,p)\footnote{For a whole description of the diachronic file
+type, reader must refer to the original documentation on the Meso-NH web site:
+``{\sc cr\'eation et exploitation de fichiers diachroniques}, J. Duron''.}.
+
+The subroutine \texttt{writevar.f90} writes the field if the wanted output
+format is {\sc dia}chronic one.
+If it is the first call the header is written, then
+the field is stored by the same number of records than when it was read.
+
+
+The personal code can be inserted in the main program between the call of the
+two previous subroutines. For the {\sc free} format, the writing code lines
+are to be written in the main program.
+
+\subsubsection{Compilation}
+You have to
+\begin{itemize}
+\item create a sub-directory {\tt src} to put your own source files
+\item copy {\tt\$MESONH/MAKE/tools/diachro/src/EXTRACTDIA/exrwdia.f90} to {\tt src/my\_prog.f90} and modify it
+\item initialize the shell variable {\tt ARCH} which refers to your system and the compiler used (see
+examples as the suffix of files in {\tt \$MESONH/MAKE/conf} directory).
+\item compile with \\
+{\tt gmaketools PROG=my\_prog OBJS="my\_routine1.o my\_routine2.o" } \\
+(the \$MESONH/MAKE/tools/diachro/{\tt Makefile.exrwdia} version will be used).
+\end{itemize}
+
+\noindent To update the routines dependances directly inside the Makefile:
+\begin{itemize}
+\item initialize the following shell variables:
+\begin{itemize}
+\item {\tt MNH\_LIBTOOLS} which is the directory where the reference sources
+for the libraries and tools are,
+\item {\tt ARCH} which refers to your system and the compiler used (see
+examples as the suffix of files in {\tt \$MNH\_LIBTOOLS/conf} directory).
+\end{itemize}
+\item copy the {\tt \$MNH\_LIBTOOLS/tools/diachro/Makefile.exrwdia} file in your working directory,
+rename it to \texttt{Makefile},
+\item compile with {\tt gmake}
+\end{itemize}
+
+
+\subsection{Compare to observations with
+{\tt mesonh2obs} tool \label{mnh2obs}}
+\subsubsection{Input and output}
+The \texttt{mesonh2obs} tool allows to interpolate MesoNH fields
+at given points (such as points where observation data are available).
+
+The input files are an ASCII file indicated the position of the points by their
+latitude and longitude coordinates as well as vertical dimension if a vertical profile is required, and one or several diachronic FM file(s) with fields to interpolate
+at previous points.
+
+Each output file, one for each input FM file, is an ASCII one with six possible
+options for lines format
+(\textsc{llhv}, llhv, \textsc{llzv}, llzv, \textsc{llpv}, llpv).
+
+In the input ASCII file, each line indicates the location of one point,
+all lines have the same format, one of the following :\\
+\begin{tabular}{l|ll}
+ lon lat & and altitudes will be asked by the {\tt mesonh2obs} program\\
+ lat lon & and altitudes will be asked by the {\tt mesonh2obs} program\\
+ lon lat altitude(m) & \\
+ lat lon altitude(m) & \\
+\end{tabular} \\
+
+The output ASCII file contains lines with the same format, one of the
+following according to the option: \\
+\begin{tabular}{l|ll}
+ lon lat model\_level\_altitude(m)& option \textsc{llhv} \\
+ lat lon model\_level\_altitude(m)& option llhv \\
+ lon lat altitude(m) & option \textsc{llzv}&
+ --interpolation routine \texttt{zinter.f90} for 3D fields\\
+ lat lon altitude(m) & option llzv& \hspace*{1cm} " \\
+ lon lat pression(hPa) & option \textsc{llpv} &
+ --interpolation routine \texttt{pinter.f90} for 3D fields\\
+ lat lon pression(hPa) & option llpv& \hspace*{1cm} " (pressure variable is read in input FM file) \\
+\end{tabular} \\
+
+
+\subsubsection{Usage}
+The tool is an interactive one: the option for the lines format of the output
+file, the name of the ASCII file with the location of
+the observation points are first asked.
+Then the name of the input diachronic files is asked in a loop, and the
+name of the fields to interpolate in a second loop:
+\begin{verbatim}
+ mesonh2obs << eof
+format_output_file # line format of output file (LLHV/llhv/LLZV/llzv/LLPV/llpv)
+format_input_file # LL (lon,lat)ou ll (lat,lon)
+altitude_in_input_file # O (altitude_in_m on the third colon)/N
+if N, number_vertical_levels # number of vertical levels above
+ # each lat,lon points
+ list_of_these_levels # exemple: (in metres or hPa): 500 1500
+obs_file # name of the Obs file
+0 # control prints (0/1/2/3)
+diachronic_file1 # file with fields to be interpolated (without .lfi)
+field1_of_diachronic_file1 # field to be interpolated
+field2_of_diachronic_file1
+END # end of extraction in diachronic_file1
+diachronic_file2 # file with fields to be interpolated (without .lfi)
+fieldi_of_diachronic_file2 # field to be interpolated
+fieldj_of_diachronic_file2
+END # end of extraction in diachronic_file2
+END # end of diachronic files list
+eof
+\end{verbatim}
+
+ If \texttt{field\_of\_diachronic\_file} contains 'AC' string
+(for ACcumulated precipitation), you can substract values of the same field
+from a previous diachronic file. Then after line
+\texttt{field('AC')\_of\_diachronic\_file}, answer the question:
+\begin{verbatim}
+"- ACcumulated rain, do you want to make difference with a previous instant
+(o\/O\/y\/Y\/n\/N) ?"
+\end{verbatim}
+if \texttt{Y$/$O}, indicate the name of \texttt{diachronic\_file\_previous}
+(without .lfi) in a second supplementary line.
+
+\subsubsection{Method}
+The main program retrieves first the $X$ and $Y$ conformal coordinates of each
+observation point, then for each read field interpolates it vertically
+if required (vertical profile field with option \textsc{llzv}, llzv, \textsc{llpv} or llpv, \textsc{llhv}, llhv),
+and finally interpolates horizontally the field and the array of the vertical
+profile.
+
+
+
+
+\subsection{Compare to observations with
+\texttt{obs2mesonh} tool \label{obs2mnh}}
+\subsubsection{Input and output}
+The \texttt{obs2mesonh} tool allows to replace observations on a MesoNH grid.
+The output file has diachronic FM format: it can be used as input for
+\texttt{diaprog} to plot observations in the same background as MesoNH fields.
+
+The input files are one or several ASCII file(s), each of it contains the
+values of one type of observation (one value per line, all lines have the same
+format: (date-)lon-lat-(alt\_in\_meters-)value or
+(date-)lat-lon-(alt\_in\_meters-)value),
+and a diachronic FM file which spatial grid will be
+used to replace previous observation values.
+
+The output file is a diachronic file with the orography and the grids of the
+input diachronic one, each field corresponds to each input observation file.
+One or two fields are added for each observation field treated: N\_field\_name
+for the number of observation averaged in each grid points and if 2D type, ALT\_field\_name for the altitudes of the observation.
+
+\subsubsection{Usage}
+The tool is an interactive one:
+\begin{verbatim}
+ obs2mesonh << eof
+file_diachronic_with_zs # initialize MesoNH spatial and temporal grids
+0/1/2/3 # verbosity level
+LL # format of obs file (LL=lon lat alt value,
+ # ll=lat lon alt value)
+file1_obs # name of obs file (undefined value=999.0)
+name_new_field1 # name of the obs field in output file
+unit_new_field1 # free characters string for unit
+1D/2D/3D # profil of the obs field
+ # for the 2D case, only K=1 will be initialised
+LL # format of obs file (LL=lon lat alt value,
+ # ll=lat lon alt value)
+file2_obs
+name_new_field2
+unit_new_field2
+1D/2D/3D
+END # closing of output diachronic file
+eof
+\end{verbatim}
+
+\subsubsection{Method}
+For each observation read in an input file: \\
+- the MesoNH grid point I,J containing this observation is searching, \\
+- then for observation with 3D profil, the vertical level K is searched
+(the MesoNH vertical grid (Gal-Chen) at I,J is taken into account);
+for observation with 2D or 1D profil, the first level K=1 is attributed,\\
+- the value of the observation is stored on grid point (I,J,K). \\
+If several values are stored at the same grid point, arithmetic average of
+values is done (when unit is $dBz$, the average is computed in $Ze$).
+If there is no values at a grid point, undefined value is put.
+The observations whose altitude is below the altitude of the first MesoNH level are stored at level K=1, a warning message is printed in this case.
+
+The wind components are considered zonal and meridian in the observation and
+are transformed to wind components in the Mesonh grid.
+
+\subsubsection{Plotting with \texttt{diaprog}}
+For plotting observation values with \texttt{diaprog}, you have to use the
+pixel mode
+\texttt{LSPOT=T}: this option is recommended for sparse data since there is
+no interpolation of values for graphic plotting.
+For superpose with simulated field, do not forget to fix the extrema
+and interval of plotting for the 2 fields in order to compare them.
+Here is an example of directives for \texttt{diaprog} to plot observed values
+and superpose them with simulated fields:
+\begin{verbatim}
+LINVWB=T
+!
+LCOLAREA=T LISO=F
+LSPOT=T ! no interpolation
+_file1_'file_obs'
+T2M
+y ! yes to draw a black line around obs pixel
+0 0
+!
+_file2_'file_sim'
+NIMNMX=1 XDIAINT_T2M=2. XISOMIN_T2M=-8. XISOMAX_T2M=24.
+T2M_ON_ ! for superpose
+n ! no black border
+T2M_file1_
+y ! yes to draw a black line around obs pixel
+0 0
+quit
+\end{verbatim}
+
+
+\subsection{Catenation of Lagrangian trajectory with
+\texttt{compute\_r00\_pc} tool}
+\subsubsection{Input and output}
+The \texttt{compute\_r00\_pc} tool allows to compute advanced
+diagnostics.
+related to Lagrangian tracers activated during the model simulation
+(\texttt{LLG=.TRUE.} in namelist \texttt{NAM\_CONF}): it is based on the subroutine \texttt{compute\_r00} used in the DIAG program.
+See section 2.2 of documentation
+``Lagrangian trajectory and air-mass tracking analyses with
+MesoNH by means of Eulerian passive tracers'' (Gheusi and Stein, 2005).
+
+The input files are one or several diachronic FM file(s) containing Lagrangian
+tracers (\texttt{LGXM,LGYM,LGZM}) simply converted by \texttt{conv2dia} after
+simulation, or after {\sc diag} (in the latter case, only Lagrangian
+basic diagnostics were asked: \texttt{LTRAJ=.TRUE.}
+in namelist \texttt{NAM\_DIAG} with the namelist
+\texttt{NAM\_STO\_FILE} empty, and additional diagnostic fields can be asked:
+\texttt{CISO='EV'} and \texttt{LMOIST\_E=.T.}
+for the example of \ref{sss:compute.nam}),
+and an ASCII file named \texttt{compute\_r00.nam} with namelist format.
+
+The output file is a diachronic file containing advanced diagnostics: initial
+ coordinates resulting from catenation process, initial values of basic
+diagnostic fields (present in the input diachronic files) that the Lagrangian
+parcels had at initial time(s).
+
+
+\subsubsection{Usage} \label{sss:compute.nam}
+The ASCII file \texttt{compute\_r00.nam} looks as the following:
+\begin{verbatim}
+&NAM_STO_FILE CFILES(1)='AR40_mc2_19990921.00d.Z',
+ CFILES(2)='AR40_mc2_19990920.12d.Z',
+ CFILES(3)='AR40_mc2_19990920.00d.Z',
+ CFILES(4)='AR40_mc2_19990919.12d.Z',
+ CFILES(5)='AR40_mc2_19990919.00d.Z',
+ NSTART_SUPP(1)=3 /
+&NAM_FIELD CFIELD_LAG(1)='THETAE',
+ CFIELD_LAG(2)='POVOM' /
+\end{verbatim}
+The namelist \texttt{NAM\_STO\_FILE} is the same as in the file
+ \texttt{DIAG1.nam}. The namelist \texttt{NAM\_FIELD} indicates the other
+quantities for which initial values have to be computed.
+\\
+
+Then to run the tool,
+\begin{verbatim}
+# initialise the following shell variable (optional if input file
+# is in the current directory):
+export DIRLFI=directory_files_diachro
+# initialise the variable ARCH (LXNAGf95 for PC, HPf90 for HP)
+export ARCH=LXNAGf95
+# execute
+$MESONH/MAKE/tools/diachro/$ARCH/compute_r00_pc
+\end{verbatim}
+
+
+
+\subsubsection{Method}
+The structure of the program and the interpolation subroutine
+ (\texttt{interpxyz}) are the same as in the {\sc diag} program,
+ the subroutines of reading and writing are those for handling diachronic files
+ (\texttt{readvar} and \texttt{writevar}).
diff --git a/LIBTOOLS/readme/LATEX/fic1.eps b/LIBTOOLS/readme/LATEX/fic1.eps
new file mode 100644
index 0000000000000000000000000000000000000000..958cd57248a824dbbb3d348bafe1e3552713685b
--- /dev/null
+++ b/LIBTOOLS/readme/LATEX/fic1.eps
@@ -0,0 +1,1085 @@
+%!PS-Adobe-3.0 EPSF-3.0
+%%BoundingBox: 0 676 567 842
+%%Title: fic1
+%%CreationDate: Wed Apr 2 12:35:31 2008
+%%Creator: Tgif-4.1.45-QPL written by William Chia-Wei Cheng (bill.cheng@acm.org)
+%%ProducedBy: (unknown)
+%%Pages: 1
+%%DocumentFonts: (atend)
+%%EndComments
+%%BeginProlog
+
+/tgifdict 86 dict def
+tgifdict begin
+
+/tgifarrowtipdict 8 dict def
+tgifarrowtipdict /mtrx matrix put
+
+/TGAT % tgifarrowtip
+ { tgifarrowtipdict begin
+ /dy exch def
+ /dx exch def
+ /h exch def
+ /w exch def
+ /y exch def
+ /x exch def
+ /savematrix mtrx currentmatrix def
+ x y translate
+ dy dx atan rotate
+ 0 0 moveto
+ w neg h lineto
+ w neg h neg lineto
+ savematrix setmatrix
+ end
+ } def
+
+/tgifpatdict 10 dict def
+
+/tgifpatbyte
+ { currentdict /retstr get exch
+ pat i cellsz mod get put
+ } def
+
+/tgifpatproc
+ { 0 1 widthlim {tgifpatbyte} for retstr
+ /i i 1 add def
+ } def
+
+/TGPF % tgifpatfill
+ { tgifpatdict begin
+ /h exch def
+ /w exch def
+ /lty exch def
+ /ltx exch def
+ /cellsz exch def
+ /pat exch def
+
+ /widthlim w cellsz div cvi 1 sub def
+ /retstr widthlim 1 add string def
+ /i 0 def
+
+ tgiforigctm setmatrix
+ ltx lty translate
+ w h true [1 0 0 1 0 0] {tgifpatproc} imagemask
+ ltx neg lty neg translate
+ end
+ } def
+
+/pat3 <8000000008000000> def
+/pat4 <8800000022000000> def
+/pat5 <8800220088002200> def
+/pat6 <8822882288228822> def
+/pat7 <aa55aa55aa55aa55> def
+/pat8 <77dd77dd77dd77dd> def
+/pat9 <77ffddff77ffddff> def
+/pat10 <77ffffff77ffffff> def
+/pat11 <7fffffff7fffffff> def
+/pat12 <8040200002040800> def
+/pat13 <40a00000040a0000> def
+/pat14 <ff888888ff888888> def
+/pat15 <ff808080ff080808> def
+/pat16 <f87422478f172271> def
+/pat17 <038448300c020101> def
+/pat18 <081c22c180010204> def
+/pat19 <8080413e080814e3> def
+/pat20 <8040201008040201> def
+/pat21 <8844221188442211> def
+/pat22 <77bbddee77bbddee> def
+/pat23 <c1e070381c0e0783> def
+/pat24 <7fbfdfeff7fbfdfe> def
+/pat25 <3e1f8fc7e3f1f87c> def
+/pat26 <0102040810204080> def
+/pat27 <1122448811224488> def
+/pat28 <eeddbb77eeddbb77> def
+/pat29 <83070e1c3870e0c1> def
+/pat30 <fefdfbf7efdfbf7f> def
+/pat31 <7cf8f1e3c78f1f3e> def
+
+/TGMAX
+ { exch dup 3 1 roll exch dup 3 1 roll gt { pop } { exch pop } ifelse
+ } def
+/TGMIN
+ { exch dup 3 1 roll exch dup 3 1 roll lt { pop } { exch pop } ifelse
+ } def
+/TGSW { stringwidth pop } def
+
+/bd { bind def } bind def
+
+/GS { gsave } bd
+/GR { grestore } bd
+/NP { newpath } bd
+/CP { closepath } bd
+/CHP { charpath } bd
+/CT { curveto } bd
+/L { lineto } bd
+/RL { rlineto } bd
+/M { moveto } bd
+/RM { rmoveto } bd
+/S { stroke } bd
+/F { fill } bd
+/TR { translate } bd
+/RO { rotate } bd
+/SC { scale } bd
+/MU { mul } bd
+/DI { div } bd
+/DU { dup } bd
+/NE { neg } bd
+/AD { add } bd
+/SU { sub } bd
+/PO { pop } bd
+/EX { exch } bd
+/CO { concat } bd
+/CL { clip } bd
+/EC { eoclip } bd
+/EF { eofill } bd
+/IM { image } bd
+/IMM { imagemask } bd
+/ARY { array } bd
+/SG { setgray } bd
+/RG { setrgbcolor } bd
+/SD { setdash } bd
+/W { setlinewidth } bd
+/SM { setmiterlimit } bd
+/SLC { setlinecap } bd
+/SLJ { setlinejoin } bd
+/SH { show } bd
+/FF { findfont } bd
+/MS { makefont setfont } bd
+/AR { arcto 4 {pop} repeat } bd
+/CURP { currentpoint } bd
+/FLAT { flattenpath strokepath clip newpath } bd
+/TGSM { tgiforigctm setmatrix } def
+/TGRM { savematrix setmatrix } def
+
+end
+
+%%EndProlog
+%%Page: 1 1
+
+%%PageBoundingBox: 0 676 567 842
+tgifdict begin
+/tgifsavedpage save def
+
+1 SM
+1 W
+
+0 SG
+
+72 0 MU 72 11.695 MU TR
+72 128 DI 100.000 MU 100 DI DU NE SC
+
+GS
+
+/tgiforigctm matrix currentmatrix def
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 368 16 M
+ GS
+ 0 SG
+ /Courier FF [17 0 0 -17 0 0] MS
+ (prepmodel MAINPROG=) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 160 64 M
+ GS
+ GS
+ 0
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_PGD) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_PGD) SH
+ GR
+ 0 17 RM
+ GS
+ GS
+ 0
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_NEST_PGD) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_NEST_PGD) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 336 64 M
+ GS
+ GS
+ 0
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_IDEAL_CASE) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_IDEAL_CASE) SH
+ GR
+ 0 17 RM
+ GS
+ GS
+ 0
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_REAL_CASE) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_REAL_CASE) SH
+ GR
+ 0 17 RM
+ GS
+ GS
+ 0
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (DIAG) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (DIAG) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 640 64 M
+ GS
+ GS
+ 0
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (MODEL) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (MODEL) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 160 160 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (physiographic output) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (physiographic output) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 320 160 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (synchronous output) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (synchronous output) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 576 160 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (synchronous outputs) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (synchronous outputs) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 864 160 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (diachronic output) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (diachronic output) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+GS
+ NP 137 161 M 183 161 L 183 180 L 137 180 L CP 1 SG F
+ 0 SG
+ NP 137 161 M 183 161 L 183 180 L 137 180 L CP EC NP
+ pat26 8 136 160 56 24 TGPF
+GR
+ GS
+ 1 W
+ 160 176 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (PGD.lfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 1.000 0.000 0.000 RG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (PGD.lfi) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+GS
+ NP 329 193 M 375 193 L 375 212 L 329 212 L CP 1 SG F
+ 0 SG
+ NP 329 193 M 375 193 L 375 212 L 329 212 L CP EC NP
+ pat26 8 328 192 56 24 TGPF
+GR
+ GS
+ 1 W
+ 352 208 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (INIT.lfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 1.000 0.000 0.000 RG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (INIT.lfi) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 272 208 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (INIT.des) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (INIT.des) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 496 208 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.00n.des) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.00n.des) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+GS
+ NP 577 193 M 702 193 L 702 212 L 577 212 L CP 1 SG F
+ 0 SG
+ NP 577 193 M 702 193 L 702 212 L 577 212 L CP EC NP
+ pat26 8 576 192 128 24 TGPF
+GR
+ GS
+ 1 W
+ 640 208 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.00n.lfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 1.000 0.000 0.000 RG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.00n.lfi) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 800 208 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.000.des) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.000.des) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+GS
+ NP 881 193 M 1006 193 L 1006 212 L 881 212 L CP 1 SG F
+ 0 SG
+ NP 881 193 M 1006 193 L 1006 212 L 881 212 L CP EC NP
+ pat4 8 880 192 128 24 TGPF
+GR
+ GS
+ 1 W
+ 944 208 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.000.lfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.000.lfi) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 48 192 M
+ GS
+ GS
+ 0
+ /Courier FF [12 0 0 -12 0 0] MS
+ (fm2deslfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Courier FF [12 0 0 -12 0 0] MS
+ (fm2deslfi) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 320 176 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (INIT) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (INIT) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 576 176 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.00n) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.00n) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 864 176 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.000) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.000) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 336 176 M
+ 16 16 atan DU cos 8.000 MU 352 exch SU
+ exch sin 8.000 MU 192 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 352 192 8.000 3.000 16 16 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 352 192 8.000 3.000 16 16 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 640 176 M
+ 16 16 atan DU cos 8.000 MU 656 exch SU
+ exch sin 8.000 MU 192 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 656 192 8.000 3.000 16 16 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 656 192 8.000 3.000 16 16 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 928 176 M
+ 16 16 atan DU cos 8.000 MU 944 exch SU
+ exch sin 8.000 MU 192 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 944 192 8.000 3.000 16 16 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 944 192 8.000 3.000 16 16 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 800 176 M
+ 16 -16 atan DU cos 8.000 MU 784 exch SU
+ exch sin 8.000 MU 192 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 784 192 8.000 3.000 -16 16 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 784 192 8.000 3.000 -16 16 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 512 176 M
+ 16 -16 atan DU cos 8.000 MU 496 exch SU
+ exch sin 8.000 MU 192 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 496 192 8.000 3.000 -16 16 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 496 192 8.000 3.000 -16 16 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 304 176 M
+ 16 -16 atan DU cos 8.000 MU 288 exch SU
+ exch sin 8.000 MU 192 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 288 192 8.000 3.000 -16 16 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 288 192 8.000 3.000 -16 16 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+0 SG
+GS
+ NP 109 273 M 483 273 L 483 292 L 109 292 L CP 1 SG F
+ 0 SG
+ NP 109 273 M 483 273 L 483 292 L 109 292 L CP EC NP
+ pat26 8 104 272 384 24 TGPF
+GR
+ GS
+ 1 W
+ 296 288 M
+ GS
+ GS
+ 0
+ /Times-Bold FF [14 0 0 -14 0 0] MS
+ (synchronuous files: PGD.lfi, INIT.lfi, CEXP.1.CSEG.00n.lfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 1.000 0.000 0.000 RG
+ /Times-Bold FF [14 0 0 -14 0 0] MS
+ (synchronuous files: PGD.lfi, INIT.lfi, CEXP.1.CSEG.00n.lfi) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+GS
+ NP 658 273 M 894 273 L 894 292 L 658 292 L CP 1 SG F
+ 0 SG
+ NP 658 273 M 894 273 L 894 292 L 658 292 L CP EC NP
+ pat4 8 656 272 240 24 TGPF
+GR
+ GS
+ 1 W
+ 776 288 M
+ GS
+ GS
+ 0
+ /Times-Bold FF [14 0 0 -14 0 0] MS
+ (diachronic file: CEXP.1.CSEG.000.lfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Times-Bold FF [14 0 0 -14 0 0] MS
+ (diachronic file: CEXP.1.CSEG.000.lfi) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ [4 4] 0 SD
+ NP
+ 240 32 M
+ 240 152 L
+ TGSM
+ 1 W
+ S
+ [] 0 SD
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ [4 4] 0 SD
+ NP
+ 416 32 M
+ 416 152 L
+ TGSM
+ 1 W
+ S
+ [] 0 SD
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 64 208 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (\() TGSW
+ AD
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (on the computer where ) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (\() SH
+ 0 SG
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (on the computer where ) SH
+ GR
+ 0 15 RM
+ GS
+ GS
+ 0
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ ( the file was created\)) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ ( the file was created\)) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 576 112 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t1,t2,...,tn) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t1,t2,...,tn) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 552 120 M
+ 24 0 atan DU cos 8.000 MU 552 exch SU
+ exch sin 8.000 MU 144 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 552 144 8.000 3.000 0 24 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 552 144 8.000 3.000 0 24 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 568 120 M
+ 24 0 atan DU cos 8.000 MU 568 exch SU
+ exch sin 8.000 MU 144 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 568 144 8.000 3.000 0 24 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 568 144 8.000 3.000 0 24 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 592 120 M
+ 24 0 atan DU cos 8.000 MU 592 exch SU
+ exch sin 8.000 MU 144 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 592 144 8.000 3.000 0 24 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 592 144 8.000 3.000 0 24 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 800 120 M
+ 872 120 L
+ 24 0 atan DU cos 8.000 MU 872 exch SU
+ exch sin 8.000 MU 144 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 872 144 8.000 3.000 0 24 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 872 144 8.000 3.000 0 24 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 880 120 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 328 116 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t0) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t0) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 328 120 M
+ 24 0 atan DU cos 8.000 MU 328 exch SU
+ exch sin 8.000 MU 144 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 328 144 8.000 3.000 0 24 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 328 144 8.000 3.000 0 24 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 160 116 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t0) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t0) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 160 120 M
+ 24 0 atan DU cos 8.000 MU 160 exch SU
+ exch sin 8.000 MU 144 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 160 144 8.000 3.000 0 24 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 160 144 8.000 3.000 0 24 TGAT
+ CP F
+GR
+
+GR
+tgifsavedpage restore
+end
+showpage
+
+%%Trailer
+%MatchingCreationDate: Wed Apr 2 12:35:31 2008
+%%DocumentFonts: Times-Bold
+%%+ Times-Italic
+%%+ Times-Roman
+%%+ Helvetica
+%%+ Courier
+%%EOF
diff --git a/LIBTOOLS/readme/LATEX/intro.tex b/LIBTOOLS/readme/LATEX/intro.tex
new file mode 100644
index 0000000000000000000000000000000000000000..6a08e62ee3ec034b5fd709521c4882c63375718a
--- /dev/null
+++ b/LIBTOOLS/readme/LATEX/intro.tex
@@ -0,0 +1,38 @@
+\section{Introduction}
+
+After initialisation, run of the model or computation of diagnostics,
+output Meso-NH files can be convert into other formats of files.
+The present documentation aims at describ the differents tools which can be
+applied to the binary part of FM files (their suffix is {\bf .lfi}).
+Most of these tools can be run on the user local
+computer (Linux PC or HP workstation).
+\\
+
+First, the compression tool \texttt{lfiz} and the conversion
+tool \texttt{conv2dia} dealing with FM files (synchronous and diachronic)
+as input and output, are described.
+The next sections concern tools dealing with other formats than
+FM: conversions with \texttt{lfi2cdf}, \texttt{lfi2grb} and \texttt{lfi2v5d}.
+A set of tools for reading diachronic FM files and dealing with diachronic
+informations is presented: \texttt{extractdia}, \texttt{mesonh2obs} and
+\texttt{obs2mesonh} (the 2 latest aim at help users to compare MesoNH outputs to
+observations).
+\\
+
+The figure \ref{fig:fic1} shows when a FM file is either \underline{synchronous}
+(contains the values of all the fields corresponding to the same instant of the
+simulation) or \underline{diachronic} (contains time series of some fields
+obtained during the run of the model).
+Then the figure \ref{fig:toolstab} resumes the tools which can be applied to a
+FM file according its type, one of the two previous ones. \\
+
+\begin{figure}[htb]
+\psfig{file=fic1.eps,width=17cm}
+\caption{Type of FM files after a MesoNH program\label{fig:fic1}}
+\end{figure}
+
+\begin{figure}[htb]
+\centerline{\psfig{file=toolstab.eps,width=17cm} }
+\caption{Which tools on FM files? \label{fig:toolstab}}
+\end{figure}
+
diff --git a/LIBTOOLS/readme/LATEX/lfi2cdf.tex b/LIBTOOLS/readme/LATEX/lfi2cdf.tex
new file mode 100644
index 0000000000000000000000000000000000000000..0a18f50636e72f102bad232dfafac9a538b3ee4a
--- /dev/null
+++ b/LIBTOOLS/readme/LATEX/lfi2cdf.tex
@@ -0,0 +1,68 @@
+\section{Conversion to NetCDF files}
+
+\subsection{{\tt lfi2cdf} tool}
+
+The \texttt{lfi2cdf} tool converts the binary part (or LFI file) of a
+FM file (synchronous or diachronic) into a NetCDF file. All the fields
+(or more precisely all the LFI articles) contained in the input LFI file
+are copied to the NetCDF output file with their values unchanged. As
+a LFI article does not hold any information on the variable, the tool
+tries to describe the corresponding NetCDF variable by using~:
+
+\begin{itemize}
+\item 3 LFI articles: \texttt{IMAX, JMAX,} and \texttt{KMAX}
+ if they are available in the LFI input file. These articles may
+ provide the NetCDF dimensions \texttt{DIMX, DIMY,} and \texttt{DIMZ}
+ of an array variable. If these variables are not available in the
+ input file, the tool treats each array variable as a 1D array.
+\item a small database implemented as a structure array in the
+ \texttt{lfi2cdf} source file \texttt{fieldtype.f90}. This array
+ holds the type (\texttt{REAL, INTEGER, LOGICAL}\ldots) of every
+ common LFI article. When an article is not present in this database,
+ its name is displayed on \texttt{stdout} by the running tool, and
+ the corresponding values are always considered as \texttt{REAL}
+ values. A new LFI article type description can be easily added in
+ the \texttt{fieldtype.f90} source file and the tool must be then
+ recompiled.
+\end{itemize}
+
+\subsubsection{Usage}
+The binary part of the FM file is required in the current directory.
+The following commands convert a file \texttt{myfile.lfi} from LFI to NetCDF:
+
+\begin{verbatim}
+lfi2cdf myfile.lfi
+\end{verbatim}
+or
+\begin{verbatim}
+lfi2cdf myfile
+\end{verbatim}
+
+\noindent The output NetCDF file is named:
+\texttt{myfile.cdf}.
+%myfile{\bf .cdf}.
+It can easily be manipulated by NetCDF tools\footnote{see
+freely available NetCDF software at http://www.unidata.ucar.edu/packages/netcdf/software.html} like
+\texttt{ncdump}, \texttt{ncview}, or \texttt{NCO} operators.\\
+
+\noindent In the same way, you will convert a NetCDF
+file \texttt{myfile.cdf} back to LFI format by typing:
+
+\begin{verbatim}
+cdf2lfi myfile.cdf
+\end{verbatim}
+or
+\begin{verbatim}
+cdf2lfi myfile
+\end{verbatim}
+The output LFI file is then named: \texttt{myfile.lfi}
+
+
+\subsection{{\tt extractdia} tool}
+The \texttt{extractdia} tool converts a diachronic FM file into a NetCDF file after an extraction of a list of fields and an optional extraction of a sub-domain. See the section \ref{extractdia}.
+
+
+%%% Local Variables:
+%%% mode: latex
+%%% TeX-master: "tools"
+%%% End:
diff --git a/LIBTOOLS/readme/LATEX/lfi2grb.tex b/LIBTOOLS/readme/LATEX/lfi2grb.tex
new file mode 100644
index 0000000000000000000000000000000000000000..8bc0efd3efdcfedf2044d4eee5d5b2f763800989
--- /dev/null
+++ b/LIBTOOLS/readme/LATEX/lfi2grb.tex
@@ -0,0 +1,630 @@
+\section{Conversion to GRIB or Vis5D files}
+
+\subsection{Presentation}
+FM synchronous file can be convert into \underline{GRIB}
+or \underline{Vis5D} format.
+This section aims at describ how the converter works and how use it.
+
+The GRIB (GRId in Binary) format is a standard meteorological one, defined
+by the WMO. GRIB files can be plotted with METVIEW
+%\footnote{available on {\tt xdata} workstation in CNRM}
+graphic interface (developped at ECMWF), or
+R2\footnote{used in the GMME/MICADO team at CNRM} software.
+
+The Vis5D format is specified for using Vis5D\footnote{home page
+{\tt http://www.ssec.wisc.edu/\~ billh/vis5d.html}}
+software (following the GNU General Public License): 3 spatial
+dimensions, time dimension, 5$^{th}$ dimension for enumeration of variables.
+It is rather designed for animation of 3D plotting.
+
+Choice was made to put together the two file formats in a same conversion
+program because in both cases specificities of Meso-NH grids have to be
+treated in the same way (horizontally: Arakawa C-grid, vertically: Gal-Chen
+coordinate $\hat z$ following terrain). However, the user has to choose one
+of the two formats available when running the tool
+(see section \ref{s:execution}).
+
+
+\subsection{Usage} \label{s:execution}
+The interactive tool is
+called {\tt lfi2grb} or {\tt lfi2v5d} according the wanted output
+file format, but it runs the same program. Some questions are to be
+answered to indicate the number and type of vertical levels, the type of
+horizontal domain,
+and the name of the variables to write into the output file.
+All that is typed on keyboard is saved in {\tt dirconv.grb} or {\tt dirconv.v5d}
+file, it can be appended and used as input (after renaming it) for the next call
+of the tool (e.g. {\tt mv dirconv.grb dirgrb ; lfi2grb < dirgrb}).
+
+For historical reasons, a program with the same goal of conversion to GRIB or
+Vis5d has been first developped as a main program
+of MesoNH, as DIAG program is. This program called {\bf CONVLFI} runs with
+the MesoNH procedure {\bf prepmodel} and
+a namelist file {\tt CONVLFI1.nam} (see \ref{ss:convlfi}).
+
+To use the converter after a {\bf DIAG prepmodel} job, the Meso-NH file must
+remain a synchronous file, not transformed onto a diachronic file:
+in {\bf prepmodelrc} specify {\tt OUTFILE\_TOOLS='fm'}
+(default is 'conv2dia' to convert with {\tt conv2dia}).
+
+
+\subsubsection{{\tt lfi2grb} tool}
+When {\tt lfi2grb} tool is invoked, you must indicate,
+after the name of the input file, first
+the horizontal grid (type, eventually type of interpolation and domain),
+the vertical grid (type and levels),
+then the list of the 3-dimensional fields to convert,
+and the list of the 2-dimensional ones.
+
+For the \underline{horizontal grid}, you can either keep the one of MesoNH file
+(cartesien or conformal projection) or interpolate onto a lat-lon regular grid.
+In the first case, you can replace all the fields on mass points (A-grid)
+or keep the native grid (C-grid).
+In the second case, you have to indicate
+the bounds of the domain with north and south latitudes and west and east
+longitudes, as well as the type of horizontal interpolation:
+nearest-neighbour value or bilinear interpolation with the 4 surrounding values.
+The resolution of the lat.-lon. grid is automatically initialized
+with the equivalent value of the grid-mesh where the map scale is minimum.
+The program also indicates the number of grid points of the Meso-NH domain
+inside the prescribed lat-lon domain. If there are points of lat-lon domain
+outside Meso-NH one, the value of the interpolated fields at these points
+will be a missing one.
+
+The \underline{vertical grid} can be either the native K levels or pressure
+levels.
+In the first case ({\tt K}), all levels are kept and no interpolation is done:
+the height specified in the GRIB header is the one of the grid without orography.
+In the second case ({\tt P}), the list of pressure levels is either specified
+manually or computed using a linear function from user-specified
+minimum, maximum and increment values. If a prescribed level is below the lower
+Meso-NH level or above the upper MesoNH level, the value of the field at this
+level will be a missing one. Otherwise, the value is computed from
+a linear interpolation in log(P).
+
+The \underline{3-dimensional fields} to convert are specified as follows:
+one field per line with first the name of the record in the input file
+following by its grib code (tabular character is allowed). Note that no test
+is done on the value of grib code (GRIB header {\sf ISEC1(6)}): you choose it
+to easily identify the field with the software used after the conversion.
+The end of the list is indicated by the keyword {\tt END}.
+
+The \underline{2-dimensional fields} to convert are specified as follows:
+one field per line with first the name of the record in the input file
+(it can be a K-level of a 3-dimensional field too),
+following by its grib code and possibly level indicator and level value
+(tabular character is allowed).
+Note that the value of the level indicator ({\sf ISEC1(7)}) is optional
+(the default value is 105: {\sf 'specified height above ground'}).
+So is the level value ({\sf ISEC1(8)}), the default value is the altitude of
+the first mass point of the K-levels.
+The end of the list is indicated by the keyword {\tt END}.
+
+\subsubsection{Example of {\tt lfi2grb} use}
+\begin{itemize}
+\item to convert onto a GRIB file with horizontal and vertical interpolations in P levels:\\
+(all that is typed on keyboard (in {\it italic} in the example below)
+is saved in {\tt dirconv.grb})
+\end{itemize}
+\small
+{\tt - ENTER FM synchronous FILE NAME (without .lfi) ?} \\
+{\tt\it CEXP.1.CSEG.001d } \hspace{3.5cm} $<$- the input file must be splitted in .des and .lfi \\
+{\tt - Horizontal interpolation to lat-lon regular grid? (Y/y/O/o/N/n)}\\
+{\tt\it y } \\
+{\tt - Type of interpolation? NEARest-neighbour (default) or BILInear }\\
+{\tt\it NEAR } \\
+{\tt - NSWE target domain bounds (in degrees)? }\\
+{\tt\it 55. 35. -20. 10. } \\
+{\tt - Vertical grid: type K or P ? }\\
+{\tt\it P } \\
+{\tt - Type of vertical grid: given by linear FUNCTN (default) or MANUALly ?}\\
+{\tt\it FUNCTN } \\
+{\tt - Enter number of P levels ?} \\
+{\tt\it 5 } \\
+{\tt - Values of the 5 P levels (hPa, from bottom to top):} \\
+{\tt\it 1000. 850. 700. 500. 300. } \\
+{\tt - Enter 3D variables to CONVERT (1/1 line, end by END): }\\
+{\tt MesoNH field name, grib parameter indicator }\\
+{\tt\it UM 33 }\\
+{\tt - next 3D field or END ? }\\
+{\tt\it VM 34 }\\
+{\tt - next 3D field or END ? }\\
+{\tt\it END }\\
+{\tt - Enter 2D variables to CONVERT (1/1 line, end by END): }\\
+{\tt MesoNH field name, grib parameter indicator, eventually level indicator and level value}\\
+{\tt\it T2M 13 105 2}\\
+{\tt - next 2D field or END ? }\\
+{\tt\it THM\_K\_2 13}\\
+{\tt - next 2D field or END ? }\\
+{\tt\it END}\\
+{\tt 2 fields (3D), and 2 fields (2D) written in CEXP.1.CSEG.001d.GRB }\\
+
+\normalsize
+\subsubsection{{\tt lfi2v5d} tool}
+When {\tt lfi2v5d} tool is invoked, you must indicate,
+after the name of the input file, first
+the vertical grid (type and levels),
+then the list of the 3-dimensional fields to convert,
+and the list of the 2-dimensional ones.
+
+No horizontal interpolation is available for the Vis5D format output: all the
+converted fields are replaced on mass points (A-grid) of the MesoNH grid
+(cartesien or conformal projection).
+
+The \underline{vertical grid} can be either the native K levels, altitude
+levels or pressure levels.
+In the first case ({\tt K}), all levels are kept and the fields are interpolated
+on the levels of the lowest point of the domain.
+In the second and third cases ({\tt Z} and {\tt P}), the list of levels is
+either specified
+manually or computed using a linear function from user-specified
+minimum, maximum and increment values. The value of the field is computed from
+a linear interpolation in Z or in log(P).
+
+The \underline{3-dimensional fields} to convert are specified with
+one record name per line.
+The end of the list is indicated by the keyword {\tt END}.
+
+Then the \underline{2-dimensional fields},
+or a K-level of 3-dimensional fields,
+to convert are specified in the same way.
+
+\subsubsection{Example of {\tt lfi2v5d} use}
+\begin{itemize}
+\item to convert onto a Vis5D file with vertical interpolation in Z levels:\\
+(all that is typed on keyboard (in {\it italic} in the example below)
+is saved in {\tt dirconv.v5d})
+\end{itemize}
+\small
+{\tt - ENTER FM synchronous FILE NAME (without .lfi) ?} \\
+{\tt\it CEXP.1.CSEG.001 } \hspace{3.5cm} $<$- the input file must be splitted in .des and .lfi \\
+{\tt - Verbosity level ?} \\
+{\tt\it 5 } \\
+{\tt - File 2D (xz): L2D=T or F ?} \\
+{\tt\it F } \\
+{\tt - Vertical grid: type K,Z or P ?} \\
+{\tt\it Z } \\
+{\tt - Type of vertical grid: given by linear FUNCTN (default) or MANUALly ?} \\
+{\tt\it FUNCTN } \\
+{\tt - Vertical grid: min, max, int (m for Z, hPa for P)?} \\
+{\tt\it 1500 9000 3000 } \\
+{\tt - Enter 3D variables to CONVERT (1/1 line, end by END): }\\
+{\tt\it THM } \\
+{\tt - next 3D field or END ? }\\
+{\tt\it POVOM } \\
+{\tt - next 3D field or END ? }\\
+{\tt\it END }\\
+{\tt - Enter 2D variables to CONVERT (1/1 line, end by END): }\\
+{\tt\it ZS } \\
+{\tt - next 2D field or END ? }\\
+{\tt\it END }\\
+{\tt 2 fields (3D), and 1 fields (2D) written in CEXP.1.CSEG.001d.V5D }\\
+
+\subsubsection{{\bf CONVLFI} program} \label{ss:convlfi}
+The MesoNH program {\bf CONVLFI} allows conversion onto GRIB
+(the horizontal grid is either the native
+MesoNH grid (Arakawa C-grid) of the field, the MesoNH mass grid
+(Arakawa A-grid),
+the vertical grid is either the native K levels or pressure levels), or
+conversion onto Vis5D (the horizontal grid is the MesoNH mass grid
+(A-grid), the vertical grid is either the native K levels without orography,
+altitude or pressure levels).
+
+The conversion is done with the Meso--NH procedure {\bf prepmodel} used with
+the {\bf CONVLFI} program and the {\tt CONVLFI1.nam} namelist file.
+Up to 24 FM files can be treated identically in a single prepmodel job.
+\\
+
+A) In the file \underline{\bf prepmodelrc}, the input and output host, directories
+and login control variables refer to the input and output files as usual.
+The other control variables to initialize specifically in this file are:
+\begin{itemize}
+\item MAINPROG=CONVLFI
+\item LOAD\_OPT='location\_of\_v5d\_library'
+\item OUTHOST=name\_workstation (for example) \\
+this allows future use of {\tt vis5d} or {\tt metview} on your local host.
+\end{itemize}
+
+B) In the \underline{\tt CONVLFI1.nam} namelist file, the user must indicate
+the format type wanted, the number and type of vertical levels,
+the type of horizontal interpolation on a lat/lon domain
+as well as the name of the variables to write into the output file:
+\begin{enumerate}
+\item\underline{Namelist NAM\_OUTFILE}:
+
+\begin{center}
+\begin{tabular} {|l|l|l|}
+\hline
+Fortran name & Fortran type & default value\\
+\hline
+\hline
+CMNHFILE & array of character (len=28) & none \\
+COUTFILETYPE & character (len=3) & none \\
+NVERB & integer & 5 \\
+LAGRID & logical & .TRUE. \\
+CLEVTYPE & character (len=1) & 'P' if COUTFILETYPE='GRB' \\
+ & & 'K' if COUTFILETYPE='V5D' \\
+CLEVLIST & character (len=6) & 'FUNCTN' \\
+XVLMIN & real & 10000. if COUTFILETYPE='GRB' \\
+XVLMAX & real & 100000. if COUTFILETYPE='GRB' \\
+XVLINT & real & 10000. if COUTFILETYPE='GRB' \\
+LLMULTI & logical & .TRUE. \\
+\hline
+\end{tabular}
+\end{center}
+
+\begin{itemize}
+\item CMNHFILE: name of the input FM file (from an initialization sequence, or
+a model simulation, or after diagnostics computation).
+\index{CMNHFILE!\innam{NAM\_OUTFILE}}
+\item COUTFILETYPE: type of the output file, appended
+to CMNHFILE to generate the name of the output file.
+\begin{itemize}
+\item 'V5D'
+\item 'GRB'
+\end{itemize}
+\index{COUTFILETYPE!\innam{NAM\_OUTFILE}}
+\item NVERB: verbosity level
+\begin{itemize}
+\item 0 for minimum of prints
+\item 5 for intermediate level of prints
+\item 10 for maximum of prints.
+\end{itemize}
+\index{NVERB!\innam{NAM\_OUTFILE}}
+\item LAGRID: switch to interpolate fields on an Arakawa A-grid (mass grid),
+\subitem forced to .TRUE. if Vis5D file or horizontal interpolation.
+\index{LAGRID!\innam{NAM\_OUTFILE}}
+\item CLEVTYPE: type of vertical levels in output file,
+\index{CLEVTYPE!\innam{NAM\_OUTVER}}
+\begin{itemize}
+\item 'P' pressure levels
+\item 'Z' z levels (only used for COUTFILETYPE='V5D')
+\item 'K'
+\subitem if COUTFILETYPE='GRB': native vertical grid of Meso-NH (no
+interpolation, height specified in GRIB message is the one of the grid
+without orography),
+\subitem if COUTFILETYPE='V5D': native vertical grid of Meso-NH (fields are
+interpolated on the levels of the lowest point of the domain).
+\end{itemize}
+\item CLEVLIST: how vertical levels are specified
+\begin{itemize}
+\item 'MANUAL' number and list of levels specified in the 1$^{st}$ free-format
+part,
+\item 'FUNCTN' using a linear function, with the next 3 parameters.
+\end{itemize}
+\index{CLEVLIST!\innam{NAM\_OUTVER}}
+\item XVLMIN: minimum value for the vertical grid
+\subitem (in m for CLEVTYPE = 'Z', in Pa for CLEVTYPE = 'P'),
+\item XVLMAX: maximum value for the vertical grid (`'),
+\item XVLINT: increment value for the vertical grid (`').
+\item LLMULTI: switch to produce a multigrib file (.T.) or monogrib files (.F.),
+only used for COUTFILETYPE='GRB' (each monogrib file name is composed with the
+date, the variable name and the level).
+\index{LLMULTI!\innam{NAM\_OUTFILE}}
+
+\end{itemize}
+
+\item\underline{Free-format part}: (number and list of vertical levels) \\
+This part is only used if CLEVLIST='MANUAL':
+\begin{enumerate}
+\item first the number of vertical levels,
+\item then the list of levels, by increasing values in m if CLEVTYPE = 'Z', or decreasing
+values in Pa if CLEVTYPE = 'P'
+\end{enumerate}
+
+\item\underline{Free-format part}: (variable names)
+This part indicates the record name of the variables of the input file to
+write in the output file. It is specified in two parts:
+\begin{enumerate}
+\item between the keywords BEGIN\_3D and END\_3D: the name of the 3D fields,
+following by their grib code if COUTFILETYPE='GRB' (separed by tabular
+character).
+\item between the keywords BEGIN\_2D and END\_2D: the name of the 2D fields,
+following by their grib code, and possibly level indicator and level value
+if COUTFILETYPE='GRB' (separed by tabular character).
+\end{enumerate}
+{\bf N.B.:} do not forget the comment line after the keyword BEGIN\_3D
+and BEGIN\_2D.
+
+
+\end{enumerate}
+
+\underline{C) Example of namelist file CONVLFI1.nam}
+\begin{itemize}
+\item
+to convert into a Vis5d file:
+\end{itemize}
+
+\begin{verbatim}
+&NAM_OUTFILE CMNHFILE(1)='T1E20.2.09B24.002',
+ CMNHFILE(2)='T1E20.2.09B24.003',
+ COUTFILETYPE='V5D',
+ CLEVTYPE='Z', CLEVLIST='MANUAL',
+ LAGRID=T, NVERB=10 /
+15
+30.
+100.
+250.
+500.
+1000.
+1500.
+2000.
+2500.
+3000.
+3500.
+4000.
+4500.
+5000.
+6000.
+8000.
+
+BEGIN_3D
+#variables 3D (MesoNH field name)
+UM
+VM
+WM
+THM
+END_3D
+BEGIN_2D
+#variables 2D (MesoNH field name)
+ZS
+END_2D
+\end{verbatim}
+
+\begin{itemize}
+\item
+to convert into a GRIB file:
+\end{itemize}
+\begin{verbatim}
+&NAM_OUTFILE CMNHFILE(1)='T1E20.2.09B24.002',
+ CMNHFILE(2)='T1E20.2.09B24.003',
+ COUTFILETYPE='GRB',
+ CLEVTYPE='P', CLEVLIST='FUNCTN',
+ XVLMAX=100000., XVLMIN=10000., XVLINT=10000.,
+ LAGRID=T, NVERB=5 /
+
+BEGIN_3D
+#variables 3D (MesoNH field name, grib parameter indicator)
+UM 33
+VM 34
+WM 40
+THM 13
+END_3D
+BEGIN_2D
+#variables 2D (MesoNH field name, grib parameter indicator)
+ZS 8
+END_2D
+next lines are ignored
+codes example:
+MSLP 1
+ACPRR 61
+INPRR 59
+PABSM 1
+ALT 6
+TEMP 11
+REHU 52
+RVM 53
+RCM 153
+RRM 170
+RIM 178
+RSM 171
+RGM 179
+RHM 226
+RARE 230
+HHRE 231
+VVRE 232
+VDOP 233
+POVOM 234
+\end{verbatim}
+
+
+\normalsize
+\subsection{Short description of the program}
+Two main tasks are performed by the program:
+\begin{enumerate}
+ \item \subitem After the specification of the name of the input file, a `light'
+initialization subroutine {\tt init\_for\_convlfi.f90 } is called to initialize
+the I/O interface, the geometry, dimensions, grids, metric coefficients, times,
+and to read pressure field.
+ \subitem According the output grids choosen, extra arrays are allocated for
+interpolations.
+\ignore{
+If horizontal interpolation is required, the equivalent
+resolution and the number of usefull points are computed by the subroutine
+{\tt ini2lalo.f90}.
+}%ignore
+ \item Then fields are treated one after another: first 3D fields, then
+2D fields.
+ \subitem In the case of GRIB conversion, fields are interpolated and written
+one after another (subroutine {\tt code\_and\_write\_grib.f90 } called for each
+horizontal level of each field).
+ \subitem For Vis5D conversion, fields are interpolated and written
+all together (subroutine \newline {\tt code\_and\_write\_vis5d.f90 } called at the end).
+\end{enumerate}
+Using a `light' initialization routine and reading fields name from standard
+input allows the conversion program not to be dependant of a MesoNH version
+or program.
+
+
+\subsection{Some tips to use Vis5D}
+See the complete guide for using Vis5D: file README.ps in the Vis5D package.
+
+\subsubsection{Utilities} (section 5 of README.ps)
+\begin{itemize}
+\item
+{\tt v5dinfo filename}: shows summary of the v5d file: number and name of
+the variables, size of the 3-D grid, number of time steps, vertical
+grid definition and projection definition.
+\item
+{\tt v5dstats filename}: shows statistics of the v5d file:
+minimum value, maximum value, mean value, standard deviation of
+ each variable.
+\item
+{\tt v5dedit filename}: edits the header of the v5d file and allows to change
+it: variables names, variables units, times and dates, projection, vertical
+coordinate system, low levels. \\
+{\it Useful to set the variable's units since they are not set by the program
+ CONVLFI.}
+\item
+{\tt v5dappend [-var] filename1 ... targetfile}: joins v5d files together:
+{\it useful since the {\bf prepmodel} job generates a separate v5d file for each
+ timestep}, {\tt var} indicates list of variables to omit in the target file,
+the dimensions of 3-D grids must be the same in each input file.
+\end{itemize}
+
+\subsubsection{Options} \label{ss:opt} (section 6.1 of README.ps) \\
+
+To call Vis5D: {\tt vis5d file1 [options] file2 [options] ...} \\
+Options can be be specified here when calling, or by pressing the {\sf DISPLAY}
+button of the main control panel and then the 'Options' menu.
+
+Options useful to set when calling: \\
+{\tt [-date]} use 'dd month yy' instead of julian 'yyddd' date, \\
+{\tt [-box x y z]} specify the aspect ratio of the 3-D box (default is 2 2 1), \\
+{\tt [-mbs n]} override the assumed system memory size of 32 megabytes (Vis5D
+tells you value to specify if not enough), \\
+{\tt [-topo file]} use a topography file other than the default EARTH.TOPO
+
+
+\subsubsection{Control panel} (section 6.2 of README.ps) \\
+The top buttons control primary functions of Vis5D (see section
+\ref{sss:funct}). \\
+The middle ones control the viewing modes (see section \ref{sss:viewing}).\\
+The bottom 2-D matrix of buttons contains physical variables on the rows, and
+types of graphic representation on the columns. To control any type of graphic,
+click on the button with the left mouse button.
+A pop-up window appears when clicking with the middle mouse button, and
+one window to modify colors with the right button
+(see section \ref{sss:graph}).
+\\
+
+\underline{\bf Primary functions} \label{sss:funct}(section 6.3 of README.ps)
+\begin{itemize}
+\item{\sf SAVE PIC} to save the image in a file: first toggle the {\sf REVERSE}
+button to reverse black and white, then toggle the {\sf SAVE PIC} button and
+choose {\tt xwd} (X Window Dump) format. The file can be visualised with
+ {\tt xv} utility and transformed into {\tt postscript} format.
+
+\item{\sf GRID\#s} to display the grid indices instead of latitude, longitude and
+vertical units along the edges of the box.
+
+\item{\sf CONT\#s, LEGENDS} to toggle on or off the isoline values, the colorbar
+legends.
+
+\item{\sf BOX, CLOCK} to toggle on or off the display of the box and the clock.
+
+\item{\sf TOP, SOUTH, WEST} to set a top (or bottom), a south (or north), a west
+(or east) view.
+{\it Select} {\sf SOUTH} {\it to visualise 2D file.}
+
+\item{\sf SAVE, RESTORE, SCRIPT} to save and restore isolines, colors, labels,
+view (write and read a Tcl script).
+
+\item{\sf UVW VARS} to specify the names of the variables to use to display wind
+slices and trajectories, several triplets of variables can be used.
+
+\item{\sf NEW VAR..} to duplicate variables or create new ones by specifying
+mathematical expressions (formulas use names of existing variables, numbers,
+arithmetic operations, functions such as $SQRT,EXP,LOG,SIN,COS,TAN,ABS,MIN,MAX$,
+ex: horizontal wind speed, $spd=SQRT(UM*UM+VM*VM)$
+see section 6.13 of README.ps).
+
+\item{\sf ANIMATE} when several time steps: left mouse button: forward,
+right button: backward, S key: slower, F key: faster.
+
+\item{\sf STEP} when several time steps: left mouse button: one step ahead,
+ middle button: first step, right button: one step back.
+
+\item{\sf DISPLAY} to change the number of displays, the display options
+(see section \ref{ss:opt}), the display parameters (as with the {\tt v5dedit}
+utility).
+
+\end{itemize}
+
+\underline{\bf Viewing modes} \label{sss:viewing}(section 6.4 of README.ps) \\
+The underlined modes are the most useful (the others are much better displayed
+with {\tt diaprog} Meso-NH graphics).
+\begin{itemize}
+\item\underline{\sf Normal}
+ to rotate, zoom and translate the graphics in the 3D window.
+
+%\item{\sf Trajectory}
+% to create and display wind trajectories.
+%
+\item\underline{\sf Slice}
+ to reposition horizontal and vertical slices.
+
+\item\underline{\sf Label}
+ to create and edit text labels in the 3D window.
+
+\item{\sf Probe}
+ to inspect individual grid values with a cursor moving through the 3D grid.
+
+\item{\sf Sounding}
+ to display a vertical sounding at the location of the moveable cursor.
+
+\item{\sf Clipping}
+ to reposition the six bounding planes of the 3-D box. Select one plane (top, bottom,
+ north, south, west or east) with the middle mouse button, and reposition it
+ with the right mouse button.
+
+\end{itemize}
+
+\underline{\bf Types of graphic representations} \label{sss:graph}(sections 6.5 to 6.9 of README.ps) \\
+The underlined types are the most useful (the others are much better displayed
+with {\tt diaprog} Meso-NH graphics).
+\begin{itemize}
+\item\underline{\sf Isosurfaces}:
+ A 3-D contour surface showing the volume bounding by a particular value of the
+field (set with the left mouse button). The isosurface is either monocolor
+or colored according to the values of another variable (right mouse button).
+
+\item\underline{\sf Slices}:
+Planar cross section (horizontally or vertically) can be moved in this mode.
+To replace geographic coordinates by grid
+coordinates, press the {\sf "GRID \#s"} button on the control panel.
+
+\subitem contour line: interval can be changed
+and min/max values specified in the pop-up window. {\tt -10 (-30,20)} will
+plot values between -30 and 20 at intervals 10 with negative values dashed.
+Color can be changed with the right mouse button.
+
+\subitem colored slice: colors can be changed in the pop-up window
+(with the mouse buttons or arrow keys). Color table is displayed in the
+3-D window if the {\sf "LEGEND \#s"} button is selected.
+%Transparency can be changed by pressing the SHIFT key while using mouse.
+To change limits of plotted values, use the keyboard array buttons when in
+the variable control panel (left and right for limits in the extend of the
+variable values, up and down for colors inside it).
+
+\subitem wind vector slice: (buttons {\sf Hwind1, Vwind1, Hwind2, Vwind2})
+the scale parameter multiplies the length of vectors drawn
+(double: 2, half: 0.5), the density parameter controls the number of vectors
+(between zero and one, 0.5 for one vector of two, 0.25 for one of four).
+
+\subitem wind stream slice: (buttons {\sf HStream, VStream})
+the density parameter controls the number of streamlines
+(between zero and two).
+
+\item\underline{\sf Volume rendering}: {\it for powerful workstations..}
+
+\end{itemize}
+
+
+\subsubsection{Advanced use}
+
+\begin{itemize}
+\item generate your own topography file, with the {\tt maketopo.c} program
+in the {\tt util} directory (see 5 of README.ps).
+
+\item Tcl language, to write script (button {\sf SCRIPT}) or
+interactively (button {\sf INTERP..}) (see 6.16 of README.ps).
+
+\item external analysis functions written in Fortran,
+in {\tt userfuncs} directory (see 6.13.3 of README.ps).
+
+\end{itemize}
+
+\subsection{State of art}
+The converter only runs on Linux and VPP.
+In HP, right compilation options have to be found to use the external library...
diff --git a/LIBTOOLS/readme/LATEX/lfiz.tex b/LIBTOOLS/readme/LATEX/lfiz.tex
new file mode 100644
index 0000000000000000000000000000000000000000..0abc536f786e9b3207027a050750e47d62343f24
--- /dev/null
+++ b/LIBTOOLS/readme/LATEX/lfiz.tex
@@ -0,0 +1,61 @@
+\section{Compression of FM files}
+
+A specific compression tool has been developed for FM files. This
+tool, called {\tt lfiz}, was first devoted for files that will be
+explored by the graphic utility {\tt diaprog}. In fact, it is also
+used for files used during a simulation (initial and coupling files)
+to reduce the data storage. Some information of how the compression
+works is given here, its execution is particularly easy.
+
+\subsection{{\tt lfiz} tool}
+
+The \texttt{lfiz} tool works on the binary part (LFI file) of a FM
+file, synchronous or diachronic. It is a lossy compression tool.
+The compressed articles are exclusively the 2-dimensional or
+3-dimensional \texttt{REAL} fields. When dealing with 3D fields the tool works
+with each 2D plane on every vertical level. The initial values stored
+with 64-bit \texttt{REAL} precision are first converted into 32-bit
+\texttt{REAL} precision and then compressed by mapping the 32-bit
+real values upon 16-bit integer values (with a possible isolation of
+extrema values). The better compression is
+achieved for fields with small value range. For fields with missing
+value (e.g. 2-dimensional fields with land-sea mask), the extremum
+value is excluded and the compression is done on significant values of
+the field. The minimum compression ratio is 4 for each 2D or 3D
+\texttt{REAL} compressed field.
+
+\subsection{{\tt unlfiz} tool}
+The \texttt{unlfiz} tool will restore the 64-bit \texttt{REAL} value size to all
+the compressed LFI articles. However, each previously compressed article
+will gain no more than a 32-bit \texttt{REAL} precision because of the lossy
+technique involved above.
+
+
+\subsection{Usage}
+The binary part of the FM file is required in the current
+directory. To compress the file \texttt{myfile.lfi}, you can type:
+
+\begin{verbatim}
+lfiz myfile.lfi
+\end{verbatim}
+
+\noindent This will produce the compressed file \texttt{myfile.Z.lfi}\\
+
+
+\noindent In the same way, to uncompress the file \texttt{myfile.Z.lfi}, you can
+type:
+\begin{verbatim}
+unlfiz myfile.Z.lfi
+\end{verbatim}
+
+\noindent The output file \texttt{myfile.lfi} is a valid LFI file but the LFI
+articles previously compressed are 64-bit \texttt{REAL} with no more than 32-bit
+\texttt{REAL} precision.
+
+
+
+
+%%% Local Variables:
+%%% mode: latex
+%%% TeX-master: "tools"
+%%% End:
diff --git a/LIBTOOLS/readme/LATEX/outils_dia.eps b/LIBTOOLS/readme/LATEX/outils_dia.eps
new file mode 100644
index 0000000000000000000000000000000000000000..73433b6eb457fece5522b35c73b9de4c4d6ba202
--- /dev/null
+++ b/LIBTOOLS/readme/LATEX/outils_dia.eps
@@ -0,0 +1,1365 @@
+%!PS-Adobe-3.0 EPSF-3.0
+%%BoundingBox: 11 7 602 838
+%%Title: outils_dia
+%%CreationDate: Thu Mar 3 16:51:45 2005
+%%Creator: Tgif-4.1.43-QPL written by William Chia-Wei Cheng (bill.cheng@acm.org)
+%%ProducedBy: (unknown)
+%%Pages: 1
+%%DocumentFonts: (atend)
+%%EndComments
+%%BeginProlog
+
+/tgifdict 53 dict def
+tgifdict begin
+
+/tgifarrowtipdict 8 dict def
+tgifarrowtipdict /mtrx matrix put
+
+/TGAT % tgifarrowtip
+ { tgifarrowtipdict begin
+ /dy exch def
+ /dx exch def
+ /h exch def
+ /w exch def
+ /y exch def
+ /x exch def
+ /savematrix mtrx currentmatrix def
+ x y translate
+ dy dx atan rotate
+ 0 0 moveto
+ w neg h lineto
+ w neg h neg lineto
+ savematrix setmatrix
+ end
+ } def
+
+/TGMAX
+ { exch dup 3 1 roll exch dup 3 1 roll gt { pop } { exch pop } ifelse
+ } def
+/TGMIN
+ { exch dup 3 1 roll exch dup 3 1 roll lt { pop } { exch pop } ifelse
+ } def
+/TGSW { stringwidth pop } def
+
+/bd { bind def } bind def
+
+/GS { gsave } bd
+/GR { grestore } bd
+/NP { newpath } bd
+/CP { closepath } bd
+/CHP { charpath } bd
+/CT { curveto } bd
+/L { lineto } bd
+/RL { rlineto } bd
+/M { moveto } bd
+/RM { rmoveto } bd
+/S { stroke } bd
+/F { fill } bd
+/TR { translate } bd
+/RO { rotate } bd
+/SC { scale } bd
+/MU { mul } bd
+/DI { div } bd
+/DU { dup } bd
+/NE { neg } bd
+/AD { add } bd
+/SU { sub } bd
+/PO { pop } bd
+/EX { exch } bd
+/CO { concat } bd
+/CL { clip } bd
+/EC { eoclip } bd
+/EF { eofill } bd
+/IM { image } bd
+/IMM { imagemask } bd
+/ARY { array } bd
+/SG { setgray } bd
+/RG { setrgbcolor } bd
+/SD { setdash } bd
+/W { setlinewidth } bd
+/SM { setmiterlimit } bd
+/SLC { setlinecap } bd
+/SLJ { setlinejoin } bd
+/SH { show } bd
+/FF { findfont } bd
+/MS { makefont setfont } bd
+/AR { arcto 4 {pop} repeat } bd
+/CURP { currentpoint } bd
+/FLAT { flattenpath strokepath clip newpath } bd
+/TGSM { tgiforigctm setmatrix } def
+/TGRM { savematrix setmatrix } def
+
+end
+
+%%EndProlog
+%%Page: 1 1
+
+%%PageBoundingBox: 11 7 602 838
+tgifdict begin
+/tgifsavedpage save def
+
+1 SM
+1 W
+
+0 SG
+
+90 RO
+72 0 MU 72 0 MU TR
+72 128 DI 100.000 MU 100 DI DU NE SC
+
+GS
+
+/tgiforigctm matrix currentmatrix def
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 224 392 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (readvar) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 472 392 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (writevar) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 680 392 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (writecdl) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 880 392 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (writellhv) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1120 392 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (write Fortran) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 224 168 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (diachronic file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 456 168 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (diachronic file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 664 168 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (netcdf file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 864 168 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (ASCII file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1136 168 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (ASCII file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 16 132 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (ASCII file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 256 184 M
+ 176 0 atan DU cos 12.000 MU 256 exch SU
+ exch sin 12.000 MU 360 exch SU L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 256 360 12.000 5.000 0 176 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 256 360 12.000 5.000 0 176 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 520 184 M
+ 176 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 520 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 520 184 12.000 5.000 0 -176 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 520 184 12.000 5.000 0 -176 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 728 184 M
+ 176 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 728 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 728 184 12.000 5.000 0 -176 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 728 184 12.000 5.000 0 -176 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 928 184 M
+ 176 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 928 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 928 184 12.000 5.000 0 -176 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 928 184 12.000 5.000 0 -176 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 1200 184 M
+ 176 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 1200 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 1200 184 12.000 5.000 0 -176 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 1200 184 12.000 5.000 0 -176 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 256 456 M
+ 96 0 atan DU cos 12.000 MU 256 exch SU
+ exch sin 12.000 MU 552 exch SU L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 256 552 12.000 5.000 0 96 TGAT
+ 1 SG CP F
+ 0.000 0.000 1.000 RG
+ NP
+ 256 552 12.000 5.000 0 96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 520 456 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 520 552 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 520 456 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 0.000 0.000 1.000 RG
+ NP
+ 520 456 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 728 456 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 728 552 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 728 456 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 0.000 0.000 1.000 RG
+ NP
+ 728 456 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 936 456 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 936 552 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 936 456 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 0.000 0.000 1.000 RG
+ NP
+ 936 456 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 1200 456 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 1200 552 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 1200 456 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 0.000 0.000 1.000 RG
+ NP
+ 1200 456 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 256 552 M
+ 1336 552 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 352 584 M
+ GS
+ 0.000 0.000 1.000 RG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 1.000 0.000 RG
+GS
+ NP
+ 256 632 M
+ 96 0 atan DU cos 12.000 MU 256 exch SU
+ exch sin 12.000 MU 728 exch SU L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 256 728 12.000 5.000 0 96 TGAT
+ 1 SG CP F
+ 0.000 1.000 0.000 RG
+ NP
+ 256 728 12.000 5.000 0 96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 1.000 0.000 RG
+GS
+ NP
+ 944 632 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 944 728 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 944 632 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 0.000 1.000 0.000 RG
+ NP
+ 944 632 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 1.000 0.000 RG
+GS
+ NP
+ 64 728 M
+ 944 728 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 352 760 M
+ GS
+ 0.000 1.000 0.000 RG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (mesonh2obs) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 240 880 M
+ 96 0 atan DU cos 12.000 MU 240 exch SU
+ exch sin 12.000 MU 976 exch SU L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 240 976 12.000 5.000 0 96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 240 976 12.000 5.000 0 96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 528 880 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 528 976 L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 528 880 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 528 880 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 784 880 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 784 976 L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 784 880 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 784 880 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 1040 880 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 1040 976 L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 1040 880 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 1040 880 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 1296 880 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 1296 976 L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 1296 880 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 1296 880 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 240 976 M
+ 1296 976 L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 336 1008 M
+ GS
+ 1.000 0.000 1.000 RG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (exrwdia ) SH
+ GR
+ 0 28 RM
+ GS
+ 1.000 0.000 1.000 RG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (\( compilation via) SH
+ GR
+ 0 26 RM
+ GS
+ 1.000 0.000 1.000 RG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ( make -f $MESONH/MAKE/tools/diachro/Makefile.exrwdia \) ) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 256 880 M
+ 96 0 atan DU cos 12.000 MU 256 exch SU
+ exch sin 12.000 MU 976 exch SU L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 256 976 12.000 5.000 0 96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 256 976 12.000 5.000 0 96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 272 880 M
+ 96 0 atan DU cos 12.000 MU 272 exch SU
+ exch sin 12.000 MU 976 exch SU L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 272 976 12.000 5.000 0 96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 272 976 12.000 5.000 0 96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 1.000 0.000 RG
+GS
+ NP
+ 64 200 M
+ 528 0 atan DU cos 12.000 MU 64 exch SU
+ exch sin 12.000 MU 728 exch SU L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 64 728 12.000 5.000 0 528 TGAT
+ 1 SG CP F
+ 0.000 1.000 0.000 RG
+ NP
+ 64 728 12.000 5.000 0 528 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+1.000 0.000 1.000 RG
+ GS
+ 1 W
+ 368 56 M
+ GS
+ 0 SG
+ /Helvetica FF [34 0 0 -34 0 0] MS
+ (Input/Output of extractdia, mesonh2obs, obs2mesonh, exrwdia programs) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 32 164 M
+ GS
+ 0 SG
+ /Helvetica FF [18 0 0 -18 0 0] MS
+ (format=lon,lat) SH
+ GR
+ 0 22 RM
+ GS
+ 0 SG
+ /Helvetica FF [18 0 0 -18 0 0] MS
+ ( lat,lon) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 856 184 M
+ GS
+ 0 SG
+ /Helvetica FF [18 0 0 -18 0 0] MS
+ (format=lon,lat,altitude,value) SH
+ GR
+ 0 22 RM
+ GS
+ 0 SG
+ /Helvetica FF [18 0 0 -18 0 0] MS
+ ( lat,lon,altitude,value) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1104 184 M
+ GS
+ 0 SG
+ /Helvetica FF [18 0 0 -18 0 0] MS
+ (format=user choice) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 208 424 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([head ]+ field) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 456 424 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([head ]+ field) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 688 424 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (head+ field) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 848 424 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (3 head lines + x lines data) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1144 424 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (x lines data) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 296 544 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([domain reduced]) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 532 544 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (if DIAC) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 732 544 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (if ZCDL/KCDL/PCDL) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 940 544 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (if LLHV/llhv/LLZV/LLPV) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1204 544 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (if FREE) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 920 768 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ vertical interpolation]) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 920 748 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ( horizontal interpolation) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 20 96 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (export DIROBS=dirname1) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 208 132 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (export DIRLFI=dirname2) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+NP 695 259 M 768 259 L 768 286 L 695 286 L CP 1 SG F
+0 SG
+ GS
+ 1 W
+ 696 280 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (tonetcdf) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 852 1004 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ horizontal interpolation \(hor_interp_4pts\)) SH
+ GR
+ 0 26 RM
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ( vertical interpolation \(zinter, pinter, zmoy\) ]) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 688 576 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ vertical interpolation on Z-levels or P-levels ]) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 688 596 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ horizontal interpolation on regular lat-lon grid if LALO]) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 1336 456 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 1336 552 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 1336 456 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 0.000 0.000 1.000 RG
+ NP
+ 1336 456 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1340 544 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (if GRIB) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1288 392 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (writegrib) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1288 168 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (GRIB file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 1336 184 M
+ 176 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 1336 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 1336 184 12.000 5.000 0 -176 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 1336 184 12.000 5.000 0 -176 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1272 424 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (field \(4 sections\)) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 688 616 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ computation of dd,ff]) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 688 636 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ Uzonal,Vmerid if LALO]) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 0.000 RG
+GS
+ NP
+ 40 192 M
+ 648 0 atan DU cos 12.000 MU 40 exch SU
+ exch sin 12.000 MU 840 exch SU L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 40 840 12.000 5.000 0 648 TGAT
+ 1 SG CP F
+ 1.000 0.000 0.000 RG
+ NP
+ 40 840 12.000 5.000 0 648 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 0.000 RG
+GS
+ NP
+ 256 744 M
+ 96 0 atan DU cos 12.000 MU 256 exch SU
+ exch sin 12.000 MU 840 exch SU L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 256 840 12.000 5.000 0 96 TGAT
+ 1 SG CP F
+ 1.000 0.000 0.000 RG
+ NP
+ 256 840 12.000 5.000 0 96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 0.000 RG
+GS
+ NP
+ 40 840 M
+ 528 840 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 0.000 RG
+GS
+ NP
+ 528 744 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 528 840 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 528 744 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 1.000 0.000 0.000 RG
+ NP
+ 528 744 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 296 864 M
+ GS
+ 1.000 0.000 0.000 RG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (obs2mesonh) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 456 860 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ Uzonal,Vmerid ->UM,VM]) SH
+ GR
+ GR
+
+GR
+tgifsavedpage restore
+end
+showpage
+
+%%Trailer
+%MatchingCreationDate: Thu Mar 3 16:51:45 2005
+%%DocumentFonts: Helvetica
+%%EOF
diff --git a/LIBTOOLS/readme/LATEX/tools.tex b/LIBTOOLS/readme/LATEX/tools.tex
new file mode 100644
index 0000000000000000000000000000000000000000..7162548296f7d57d5097db714fe7be09c0b95d8a
--- /dev/null
+++ b/LIBTOOLS/readme/LATEX/tools.tex
@@ -0,0 +1,33 @@
+\documentclass[12pt]{article}
+\usepackage[latin1]{inputenc}
+\usepackage{epsfig}
+\setlength{\textwidth}{16.cm}
+\setlength{\textheight}{24.cm}
+%\oddsidemargin=+1.6cm
+%\evensidemargin=+0.6cm
+\voffset=-1.8cm
+\hoffset=-1.cm
+
+%\makeindex
+
+\begin{document}
+%%%%%%%%%% Definition of new commands for LATEX :
+%
+\newcommand{\ignore}[1]{}
+%
+%
+\title {Tools related to Meso-NH model}
+\author{N. Asencio, J. Duron, J. Escobar, D. Gazen, P. Jabouille, I. Mallet}
+\date{\today}
+\maketitle
+
+\tableofcontents
+
+\include{intro}
+\include{lfiz}
+\include{conv2dia}
+\include{lfi2cdf}
+\include{extract}
+\include{lfi2grb}
+
+\end{document}
diff --git a/LIBTOOLS/readme/LATEX/toolstab.eps b/LIBTOOLS/readme/LATEX/toolstab.eps
new file mode 100644
index 0000000000000000000000000000000000000000..2d9172e9f76045bdab1eccaf574705afe3124220
--- /dev/null
+++ b/LIBTOOLS/readme/LATEX/toolstab.eps
@@ -0,0 +1,2291 @@
+%!PS-Adobe-3.0 EPSF-3.0
+%%BoundingBox: 3 397 592 827
+%%Title: toolstab
+%%CreationDate: Wed Mar 2 10:14:19 2005
+%%Creator: Tgif-4.1.43-QPL written by William Chia-Wei Cheng (bill.cheng@acm.org)
+%%ProducedBy: (unknown)
+%%Pages: 1
+%%DocumentFonts: (atend)
+%%EndComments
+%%BeginProlog
+
+/tgifdict 56 dict def
+tgifdict begin
+
+/tgifarrowtipdict 8 dict def
+tgifarrowtipdict /mtrx matrix put
+
+/TGAT % tgifarrowtip
+ { tgifarrowtipdict begin
+ /dy exch def
+ /dx exch def
+ /h exch def
+ /w exch def
+ /y exch def
+ /x exch def
+ /savematrix mtrx currentmatrix def
+ x y translate
+ dy dx atan rotate
+ 0 0 moveto
+ w neg h lineto
+ w neg h neg lineto
+ savematrix setmatrix
+ end
+ } def
+
+/tgifarcdict 8 dict def
+tgifarcdict /mtrx matrix put
+
+/TGAN % tgifarcn
+ { tgifarcdict begin
+ /endangle exch def
+ /startangle exch def
+ /yrad exch def
+ /xrad exch def
+ /y exch def
+ /x exch def
+ /savematrix mtrx currentmatrix def
+ x y translate
+ xrad yrad scale
+ 0 0 1 startangle endangle arc
+ savematrix setmatrix
+ end
+ } def
+
+/TGAR % tgifarc
+ { tgifarcdict begin
+ /endangle exch def
+ /startangle exch def
+ /yrad exch def
+ /xrad exch def
+ /y exch def
+ /x exch def
+ /savematrix mtrx currentmatrix def
+ x y translate
+ xrad yrad scale
+ 0 0 1 startangle endangle arcn
+ savematrix setmatrix
+ end
+ } def
+
+/TGMAX
+ { exch dup 3 1 roll exch dup 3 1 roll gt { pop } { exch pop } ifelse
+ } def
+/TGMIN
+ { exch dup 3 1 roll exch dup 3 1 roll lt { pop } { exch pop } ifelse
+ } def
+/TGSW { stringwidth pop } def
+
+/bd { bind def } bind def
+
+/GS { gsave } bd
+/GR { grestore } bd
+/NP { newpath } bd
+/CP { closepath } bd
+/CHP { charpath } bd
+/CT { curveto } bd
+/L { lineto } bd
+/RL { rlineto } bd
+/M { moveto } bd
+/RM { rmoveto } bd
+/S { stroke } bd
+/F { fill } bd
+/TR { translate } bd
+/RO { rotate } bd
+/SC { scale } bd
+/MU { mul } bd
+/DI { div } bd
+/DU { dup } bd
+/NE { neg } bd
+/AD { add } bd
+/SU { sub } bd
+/PO { pop } bd
+/EX { exch } bd
+/CO { concat } bd
+/CL { clip } bd
+/EC { eoclip } bd
+/EF { eofill } bd
+/IM { image } bd
+/IMM { imagemask } bd
+/ARY { array } bd
+/SG { setgray } bd
+/RG { setrgbcolor } bd
+/SD { setdash } bd
+/W { setlinewidth } bd
+/SM { setmiterlimit } bd
+/SLC { setlinecap } bd
+/SLJ { setlinejoin } bd
+/SH { show } bd
+/FF { findfont } bd
+/MS { makefont setfont } bd
+/AR { arcto 4 {pop} repeat } bd
+/CURP { currentpoint } bd
+/FLAT { flattenpath strokepath clip newpath } bd
+/TGSM { tgiforigctm setmatrix } def
+/TGRM { savematrix setmatrix } def
+
+end
+
+%%EndProlog
+%%Page: 1 1
+
+%%PageBoundingBox: 3 397 592 827
+tgifdict begin
+/tgifsavedpage save def
+
+1 SM
+1 W
+
+0 SG
+
+72 0 MU 72 11.695 MU TR
+72 128 DI 100.000 MU 100 DI DU NE SC
+
+GS
+
+/tgiforigctm matrix currentmatrix def
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 40 40 M
+ 168 104 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 32 M
+ 168 784 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 104 M
+ 840 104 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 424 32 M
+ 424 784 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 104 56 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (IN) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 56 88 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (OUT) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 232 56 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (synchronous FM file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 496 56 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (diachronic FM file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 296 72 M
+ 296 232 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 552 72 M
+ 552 232 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 172 88 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Uncompressed) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 312 88 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Compressed) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 56 152 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (synchro-) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (synchro-) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (nuous ) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (nuous ) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (FM file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (FM file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 104 168 M
+ 840 168 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 104 144 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Uncomp.) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 56 288 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (diachronic) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (diachronic) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (FM file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (FM file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 232 M
+ 840 232 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 432 88 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Uncompressed) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 576 88 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Compressed) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 104 208 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Comp.) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 68 268 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Uncomp.) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 72 328 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Comp.) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 104 296 M
+ 840 296 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 360 M
+ 840 360 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 360 136 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 224 208 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) SH
+ GR
+ GR
+
+% ARC
+0 SG
+GS
+ GS
+ NP
+ 92 92 45 45 -105 -131 TGAR
+ 2 W
+ S
+ GR
+GR
+GS
+ TGSM
+ NP
+ 57 64 10.000 4.000 -55 71 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 57 64 10.000 4.000 -55 71 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 104 M
+ 296 168 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 168 M
+ 296 104 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 424 104 M
+ 680 232 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 424 232 M
+ 680 104 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 296 168 M
+ 424 232 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 296 232 M
+ 424 168 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 296 252 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (conv2dia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (conv2dia) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 476 316 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 424 M
+ 680 424 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 488 M
+ 680 488 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 624 280 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 64 392 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (GRIB) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (GRIB) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 248 392 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2grb) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2grb) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 64 456 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (Vis5D) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (Vis5D) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 248 456 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2v5d) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2v5d) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 68 516 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (NetCDF) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (NetCDF) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 232 512 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 488 512 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 552 M
+ 680 552 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 64 584 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (ASCII) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (ASCII) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 616 M
+ 680 616 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 76 648 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (NCAR-CGM) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (NCAR-CGM) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 616 M
+ 424 680 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 680 M
+ 424 616 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 552 656 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (diaprog) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.373 0.620 0.627 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (diaprog) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 552 572 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (diaprog ) TGSW
+ AD
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (->FICVAL) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.373 0.620 0.627 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (diaprog ) SH
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (->FICVAL) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 552 592 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 488 536 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 296 320 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (conv2dia+lfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (conv2dia+lfiz) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 624 536 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 552 488 M
+ 552 552 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 296 488 M
+ 296 552 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 616 252 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 492 348 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia+lfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia+lfiz) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 680 M
+ 680 680 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 560 696 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (exrwdia \(readvar, writevar,) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (exrwdia \(readvar, writevar,) SH
+ GR
+ 0 23 RM
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (zinter,pinter,lalo\)) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (zinter,pinter,lalo\)) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 736 M
+ 168 784 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 424 736 M
+ 424 784 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 96 744 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (ex: diachronic file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (ex: diachronic file) SH
+ GR
+ 0 23 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (\(Lag. var.\)) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (\(Lag. var.\)) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 292 760 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (DIAG with) TGSW
+ AD
+ /Helvetica-Bold FF [14 0 0 -14 0 0] MS
+ ( LTRAJ =TRUE) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (DIAG with) SH
+ 0 SG
+ /Helvetica-Bold FF [14 0 0 -14 0 0] MS
+ ( LTRAJ =TRUE) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 560 752 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [14 0 0 -14 0 0] MS
+ (compute_r00_pc ) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [14 0 0 -14 0 0] MS
+ (compute_r00_pc ) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 552 608 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (mesonh2obs) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (mesonh2obs) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 840 32 M
+ 840 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 680 32 M
+ 840 32 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 720 72 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (ASCII file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 760 136 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (PREP_PGD) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (PREP_PGD) SH
+ GR
+ 0 23 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (\() TGSW
+ AD
+ /Helvetica-Bold FF [14 0 0 -14 0 0] MS
+ (&NAM_DUMMY_PGD) TGSW
+ AD
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (\)) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (\() SH
+ 0 SG
+ /Helvetica-Bold FF [14 0 0 -14 0 0] MS
+ (&NAM_DUMMY_PGD) SH
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (\)) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 760 192 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (PREP_PGD) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (PREP_PGD) SH
+ GR
+ 0 19 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (+) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (+) SH
+ GR
+ 0 19 RM
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 344 392 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (CONVLFI) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (CONVLFI) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 344 456 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (CONVLFI) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (CONVLFI) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 96 704 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (other treatments,) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (other treatments,) SH
+ GR
+ 0 17 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (other formats) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (other formats) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 352 512 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz+) TGSW
+ AD
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz+) SH
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 624 512 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz+) TGSW
+ AD
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz+) SH
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 224 396 M
+ 272 396 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 224 460 M
+ 276 460 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 208 516 M
+ 256 516 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 356 516 M
+ 404 516 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 452 540 M
+ 524 540 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 464 516 M
+ 508 516 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 628 516 M
+ 672 516 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 588 540 M
+ 656 540 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 516 596 M
+ 584 596 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 504 612 M
+ 600 612 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 460 700 M
+ 516 700 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 764 272 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (obs2mesonh) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (obs2mesonh) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 716 276 M
+ 812 276 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 764 316 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (obs2mesonh) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (obs2mesonh) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 716 320 M
+ 812 320 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 764 336 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (+) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (+) SH
+ GR
+ 0 19 RM
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 688 428 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (MAINPROG) SH
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ ( : ) SH
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (main program of MesoNH ) SH
+ GR
+ 0 23 RM
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ ( \(run it on supc with prepmodel\)) SH
+ GR
+ 0 23 RM
+ GS
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (tool : one of the libtools package ) SH
+ GR
+ 0 23 RM
+ GS
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ ( \(run it interactively on local host\)) SH
+ GR
+ 0 23 RM
+ GS
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ ( \() SH
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (tool) SH
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ ( with change of file format\)) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 744 512 M
+ 768 512 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 492 280 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 552 232 M
+ 552 296 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 552 296 M
+ 552 360 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 624 348 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 712 524 M
+ 740 524 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 140 520 M
+ 680 520 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 104 544 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (var. list) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 112 508 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (all var.) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 140 324 M
+ 680 324 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 140 260 M
+ 680 260 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 108 252 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (all var.) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 108 316 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (all var.) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 104 288 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (var. list) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 100 352 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (var. list) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 260 M
+ 420 292 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 292 M
+ 420 260 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 172 324 M
+ 424 356 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 172 356 M
+ 424 324 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 552 M
+ 424 616 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 616 M
+ 424 552 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 548 396 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia in future) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia in future) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 548 456 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia in future) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia in future) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 472 400 M
+ 544 400 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 476 460 M
+ 548 460 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 28 M
+ 12 788 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 680 32 M
+ 12 32 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 784 M
+ 684 784 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 684 360 M
+ 684 784 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 684 32 M
+ 684 364 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 684 360 M
+ 840 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+GR
+tgifsavedpage restore
+end
+showpage
+
+%%Trailer
+%MatchingCreationDate: Wed Mar 2 10:14:19 2005
+%%DocumentFonts: Helvetica-Bold
+%%+ NewCenturySchlbk-Bold
+%%+ NewCenturySchlbk-Roman
+%%EOF
diff --git a/LIBTOOLS/readme/compute_r00.LISEZMOI b/LIBTOOLS/readme/compute_r00.LISEZMOI
new file mode 100644
index 0000000000000000000000000000000000000000..80b5353296e45cada6627567c14b1f427ef1fee5
--- /dev/null
+++ b/LIBTOOLS/readme/compute_r00.LISEZMOI
@@ -0,0 +1,75 @@
+#
+#compute_r00_pc
+#==============
+# Version PC de la routine compute_r00 utilisee dans le programme DIAG
+#(voir la doc. "Lagrangian trajectory and air-mass tracking analyses with
+#MesoNH by means of Eulerian passive tracers", Gheusi and Stein, 2003)
+# On garde la structure F90 et la routine d'interpolation (interpxyz) mais on
+#utilise les routines de lecture/ecriture de fichiers diachroniques
+#(READVAR et WRITEVAR)
+#
+# il faut disposer
+# 1)des fichiers diachroniques contenant les champs Lagrangiens LGXM,LGYM,LGZM
+#(conversion par conv2dia de fichiers synchrones issus d une simulation avec LLG=T)
+# 2)d'un fichier de namelist nommé compute_r00.nam, contenant le nom des
+# fichiers diachroniques et eventuellement une liste de champs supplementaires
+# devant etre concatenes, ex:
+cat<<'eof' >compute_r00.nam
+&NAM_STO_FILE CFILES(1)='AR40_mc2_19990921.00d.Z',
+ CFILES(2)='AR40_mc2_19990920.12d.Z',
+ CFILES(3)='AR40_mc2_19990920.00d.Z',
+ CFILES(4)='AR40_mc2_19990919.12d.Z',
+ CFILES(5)='AR40_mc2_19990919.00d.Z',
+ NSTART_SUP(1)=3 /
+&NAM_FIELD CFIELD_LAG(1)='THM',
+ CFIELD_LAG(2)='RVM' /
+eof
+#
+# initialiser
+export DIRLFI=directory_fichier_diachro # facultatif si les fichiers sont dans le repertoire courant
+# initialiser la variable ARCH (LXNAGf95 sur PC, HPf90 sur HP)
+export ARCH=LXNAGf95
+# executer
+$MESONH/MAKE/tools/diachro/$ARCH/compute_r00_pc
+#
+# Les champs (X000,Y000,Z000,THM00,RVM00) sont concatenes depuis l instant
+#initial (celui du dernier fichier de NAM_STO_FILE, CFILES(5) dans l exemple)
+#jusqu'a l'instant du fichier traite (tous sauf le dernier de NAM_STO_FILE).
+#Dans l exemple ci-dessus, une deuxieme serie de champs
+#(X001,Y001,Z001,THM01,RVM01) sont concatenes depuis l'instant du fichier
+#repere par NSTART_SUP(1) (CFILES(3) dans l exemple).
+#Ces champs supplementaires sont ajoutes a ceux du fichier traite.
+#Les possibilites de trace sont elargies puisque champs Lagrangiens concatenes
+#et champs synchrones sont dans le meme fichier.
+#
+#
+#personnalisation :
+#=================
+# cf $MESONH/MAKE/tools/diachro/exrwdia.LISEZMOI
+#
+# Pour modifier le programme:
+#
+# *initialiser et exporter la variable MNH_LIBTOOLS
+#
+export MNH_LIBTOOLS=$MESONH/MAKE
+#
+# *dans votre repertoire de travail:
+# copier le fichier Makefile.exrwdia de $MNH_LIBTOOLS/tools/diachro
+#
+cp $MNH_LIBTOOLS/tools/diachro/Makefile.exrwdia Makefile
+#
+# *creer un repertoire qui contiendra les fichiers sources nommé src
+# puis y copier exrwdia.f90, le modifier eventuellement
+#
+mkdir src
+cp $MNH_LIBTOOLS/tools/diachro/src/EXTRACTDIA/compute_r00_pc.f90 src/.
+#
+# compiler par
+#
+gmake PROG=compute_r00_pc
+#
+# *completer le Makefile (liste des objets dans OBJS et dependances)
+# si vous ajoutez des routines (exemple dans
+# $MESONH/MAKE/tools/diachro/Makefile.extractdia)
+#
+# Mise à jour le 30/04/2004
diff --git a/LIBTOOLS/readme/compute_r00.nam b/LIBTOOLS/readme/compute_r00.nam
new file mode 100644
index 0000000000000000000000000000000000000000..3cd2fd57e5b4c190f42a40450b141eb87f7477f3
--- /dev/null
+++ b/LIBTOOLS/readme/compute_r00.nam
@@ -0,0 +1,7 @@
+&NAM_STO_FILE CFILES(1)='AR40_mc2_19990921.00d.Z',
+ CFILES(2)='AR40_mc2_19990920.12d.Z',
+ CFILES(3)='AR40_mc2_19990920.00d.Z',
+ CFILES(4)='AR40_mc2_19990919.12d.Z',
+ CFILES(5)='AR40_mc2_19990919.00d.Z' /
+&NAM_FIELD CFIELD_LAG(1)='THM',
+ CFIELD_LAG(2)='RVM' /
diff --git a/LIBTOOLS/readme/exrwdia.LISEZMOI b/LIBTOOLS/readme/exrwdia.LISEZMOI
new file mode 100644
index 0000000000000000000000000000000000000000..7ff444722b06bc1c8ab198d001217bae9ebcb174
--- /dev/null
+++ b/LIBTOOLS/readme/exrwdia.LISEZMOI
@@ -0,0 +1,91 @@
+# exrwdia
+# =======
+#outil (version simplifiee de extractdia) qui permet:
+# 1)d'extraire des champs 2D/3D d'un fichier diachronique (sortie conv2dia)
+# 2)d'extraire un zoom i,j,k,t,traj,process du champ
+# 3)d'effectuer des calculs sur le champ extrait
+# (ex: maximum sur la verticale, moyenne verticale entre 2 niveaux,
+# interpolation verticale et horizontale, autre code perso)
+# 4)d'ecrire ce zoom extrait au format:
+# 'DIAC'= nouveau fichier diachronique visualisable par diaprog
+# 'LLHV'= fichier ascii lon,lat,altitude,valeur
+# 'llhv'= fichier ascii lat,lon,altitude,valeur
+# 'FREE'= format libre à fixer au programme
+# 'KCDL'= format CDL ( passage au format netcdf via
+# le script Unix tonetcdf appelé par le programme)
+#
+#
+# Pour les autres formats possibles LLZV LLPV llzv llpv ZCDL ou PCDL,
+# 'CONF' grille régulière sur le plan conforme,'LALO' grille régulière
+# en lat-lon , un conseil: sortir en format 'DIAC' puis utiliser extractdia
+# et activer les choix LLZV LLPV llzv llpv ZCDL PCDL , CONF ou LALO
+#
+# Cet outil nécessite une connaissance de l'utilisation des différentes
+# grilles de Mesonh (voir le book3).
+#
+#personnalisation :
+#=================
+# Le programme extractdia est base sur 2 routines de lecture (READVAR)
+# et d'écriture (WRITEVAR) de champs Mesonh qui peuvent être utilisées
+# dans un programme utilisateur pour traiter des fichiers diachroniques.
+#
+#- Un exemple de programme (exrwdia.f90) est disponible sous le repertoire
+# $MESONH/MAKE/tools/diachro/src/EXTRACTDIA
+#
+# Pour modifier le programme exrwdia (ou un autre programme personnel):
+# 1)initialiser et exporter la variable ARCH
+#(LXpgf90 ou LXNAGf95 sur PC Linux 32bits, HPf90 sur HP)
+#
+export ARCH=LXNAGf95
+#
+# 2)creer un repertoire nomme src qui contiendra les fichiers sources
+# puis y copier exrwdia.f90 et eventuellement vos propres routines
+#
+mkdir src
+cp $MESONH/MAKE/tools/diachro/src/EXTRACTDIA/exrwdia.f90 src/my_prog.f90
+#
+# 3)dans votre repertoire de travail:
+# compiler par
+#
+gmaketools PROG=my_prog OBJS="my_routine1.o my_routine2.o"
+#
+# 3bis)OU initialiser et exporter la variable MNH_LIBTOOLS
+#
+export MNH_LIBTOOLS=$MESONH/MAKE
+#
+# copier le fichier Makefile.exrwdia de $MNH_LIBTOOLS/tools/diachro
+#
+cp $MNH_LIBTOOLS/tools/diachro/Makefile.exrwdia Makefile
+#
+# completer le Makefile si vous avez des routines supplementaires
+#(liste des objets dans OBJS et dependances) :
+# exemple dans $MESONH/MAKE/tools/diachro/Makefile.extractdia
+#
+# compiler par
+#
+gmake
+# 4) l executable est dans le repertoire $ARCH
+#
+#- D autres exemples de programmes bases sur READVAR et WRITEVAR sont
+#extractdia.f90
+#mesonh2obs.f90
+#obs2mesonh.f90
+#compute_r00_pc.f90
+#dans $MESONH/MAKE/tools/diachro/src/EXTRACTDIA
+#
+#execution :
+#===========
+# initialiser (facultatif si le fichier est dans le repertoire courant)
+export DIRLFI=directory_fichier_diachro
+# et executer
+exrwdia
+#
+#
+#
+#Scripts utilisés donc accessibles depuis votre environnement:
+#===========================================================
+#rmlink, tonetcdf
+#
+#
+# Mise à jour le 30/01/2004
+# Mise à jour le 01/03/2005
diff --git a/LIBTOOLS/readme/extractdia.LISEZMOI b/LIBTOOLS/readme/extractdia.LISEZMOI
new file mode 100644
index 0000000000000000000000000000000000000000..70c4493a843f8a97a54fef442a702ad4b8bdf613
--- /dev/null
+++ b/LIBTOOLS/readme/extractdia.LISEZMOI
@@ -0,0 +1,57 @@
+#
+#extractdia
+#==========
+#outil qui permet:
+# 1)d'extraire des champs 2D/3D d'un fichier diachronique (sortie conv2dia)
+# 2)d'extraire un zoom i,j,k,t,traj,process du champ
+# 3)de calculer dd(direction 0-360),ff(intensité)
+# 3)d'ecrire ce zoom extrait au format:
+# 'DIAC'= nouveau fichier diachronique visualisable par diaprog
+# 'LLHV'= fichier ascii lon,lat,altitude_niveaux_modèle,valeur
+# 'llhv'= fichier ascii lat,lon,altitude_niveaux_modèle,valeur
+# 'LLZV'= fichier ascii lon,lat,altitude_niveaux_Z=cst,valeur
+# 'llzv'= fichier ascii lat,lon,altitude_niveaux_Z=cst,valeur
+# 'LLPV'= fichier ascii lon,lat,altitude_niveaux_P=cst,valeur
+# 'llpv'= fichier ascii lat,lon,altitude_niveaux_P=cst,valeur
+# 'FREE'= format libre à fixer au programme
+# 'KCDL' ou 'ZCDL' ou 'PCDL'= format CDL ( passage au format netcdf via
+# le script Unix tonetcdf appelé par le programme)
+# KCDL = fichier cdl avec les niveaux verticaux du modèle
+# ZCDL = fichier cdl avec des interpolations sur des
+# niveaux Z=constante donnés en input à extractdia
+# PCDL = fichier cdl avec des interpolations sur des
+# niveaux P=constante donnés en input à extractdia
+# pour le format *CDL,*Z*,*P* 2 types de grilles horizontales sont
+# possibles 'CONF' grille régulière sur le plan conforme
+# 'LALO' grille régulière en lat-lon
+# dans ce cas les composantes du vent seront transformées
+# en composantes zonales et méridiennes.
+#
+# initialiser (facultatif si le fichier est dans le repertoire courant)
+export DIRLFI=directory_fichier_diachro
+# (les liens crees seront supprimes a la fin du programme par l appel a rmlink
+# present dans bin)
+# *executer (procedure de $MESONH)
+extractdia # et répondre aux questions
+ # Un fichier "dirextract" consignera toutes vos réponses
+ # rentrées au clavier
+# ou
+extractdia < dirextract_créé_execution_précédente
+#
+# pour acceder directement au binaire:
+# *initialiser et exporter la variable ARCH
+#(LXpgf90 ou LXNAGf95 sur PC Linux, HPf90 sur HP)
+export ARCH=LXpgf90
+# *initialiser et exporter la variable MNH_LIBTOOLS
+export MNH_LIBTOOLS=$MESONH/MAKE
+# *executer
+${MNH_LIBTOOLS}/tools/diachro/$ARCH/extractdia
+#
+#Scripts utilisés donc accessibles depuis votre environnement
+#===========================================================
+#rmlink, tonetcdf
+#(presents dans ${MNH_LIBTOOLS}/bin)
+#
+#
+# Mise à jour le 30/01/2004
+# Mise à jour le 01/03/2005
diff --git a/LIBTOOLS/readme/extractdia.test_cdl.x b/LIBTOOLS/readme/extractdia.test_cdl.x
new file mode 100755
index 0000000000000000000000000000000000000000..73de6d58c96856ea3fef6006a60a6355473c7ca0
--- /dev/null
+++ b/LIBTOOLS/readme/extractdia.test_cdl.x
@@ -0,0 +1,23 @@
+#! /bin/sh
+FILE=${1:-Bret45.99082200dg.Z}
+#DIRLFI=${2:-.}
+export DIRLFI
+#
+ARCH=LXNAGf95
+B=32
+#
+rm ${FILE}*zc*
+/mesonh/MAKE/tools/diachro/${ARCH}_${B}/extractdia << EOF
+$FILE
+ZCDL
+5
+1,10,1,10
+1,1,1,1,1,1
+3
+1500 3000 5000
+LALO
+LAT
+ALT
+LON
+END
+EOF
diff --git a/LIBTOOLS/readme/extractdia.test_diac.x b/LIBTOOLS/readme/extractdia.test_diac.x
new file mode 100755
index 0000000000000000000000000000000000000000..087d673eaeb4bc50a26acce397bc0ac8b3dbfb23
--- /dev/null
+++ b/LIBTOOLS/readme/extractdia.test_diac.x
@@ -0,0 +1,21 @@
+#! /bin/sh
+FILE=${1:-16J36.1.00A12.001dg.Z}
+DIRLFI=${2:-DATA}
+export DIRLFI
+#
+ARCH=LXNAGf95
+B=32
+#
+rm $(basename $FILE .Z)2.lfi
+/mesonh/MAKE/tools/diachro/${ARCH}_${B}/extractdia << EOF
+$FILE
+DIAC
+1
+30,50,20,40,0,0
+1,1,1,1
+FF
+THM
+DD
+ALT
+END
+EOF
diff --git a/LIBTOOLS/readme/extractdia.test_llhv.x b/LIBTOOLS/readme/extractdia.test_llhv.x
new file mode 100755
index 0000000000000000000000000000000000000000..2c859475f6da40cc93e38d9f9244f8d24ae3aed9
--- /dev/null
+++ b/LIBTOOLS/readme/extractdia.test_llhv.x
@@ -0,0 +1,20 @@
+#! /bin/sh
+FILE=${1:-Bret45.99082200dg.Z}
+DIRLFI=${2:-.}
+export DIRLFI
+#
+ARCH=LXNAGf95
+B=32
+#
+rm ${FILE}LLHV
+/mesonh/MAKE/tools/diachro/${ARCH}_${B}/extractdia << EOF
+$FILE
+LLHV
+0
+1,10,1,10,2,5
+1,1,1,1,1,1
+FF
+THM
+DD
+END
+EOF
diff --git a/LIBTOOLS/readme/libtools.LISEZMOI b/LIBTOOLS/readme/libtools.LISEZMOI
new file mode 100644
index 0000000000000000000000000000000000000000..d001df64ed8d47e73aba1f8a1bf40daea605bd91
--- /dev/null
+++ b/LIBTOOLS/readme/libtools.LISEZMOI
@@ -0,0 +1,160 @@
+0) Repertoires presents dans le paquetage LIBTOOLS
+
+
+conf/ : contient les fichiers de configuration des Makefiles
+ sous la forme 'config.$ARCH'.
+
+bin/ : scripts utilises par les outils (a mettre dans le PATH)
+bin/gmaketools : pour recompiler un programme personnel de tools/diachro
+bin/rmlink : pour supprimer les liens crees par l usage de la variable
+ DIRLFI
+bin/tonetcdf : appel par extractdia a ncgen pour transformer en fichier NetCDF
+
+lib/NEWLFI : sources librairie LFI
+lib/COMPRESS : sources librairie compression
+lib/MPIvide : sources librairie MPIvide
+lib/rad2 : sources librairie rayonnement
+lib/gribex_1302b : sources librairie GRIB
+lib/SURCOUCHE : sources de la surcouche
+
+tools/diachro : outils diaprog, conv2dia, lfi2grb, extractdia, exrwdia
+tools/fmmore : outil fmmore
+tools/lfi2cdf : outils lfi2cdf/cdf2lfi
+tools/lfiz : outils lfiz/unlfiz
+tools/vergrid : outil vergrid
+
+1) Principe de gestion avec les Makefiles :
+
+Chaque sous-repertoire dans 'lib' et 'tools' contient un Makefile qui
+a besoin de deux fichiers pour fonctionner :
+
+- config.$ARCH : present dans le repertoire 'conf/' qui definit les
+ variables CPP,F90,F77... suivant l'architecture ou l'on
+ se trouve. Ce fichier de configuration est commun a
+ toutes les librairies et outils pour une architecture
+ donnee.
+
+- Rules.$ARCH : present dans le repertoire ou se trouve le Makefile de
+ la librairie ou de l'outil que l'on desire generer.
+ Il contient les variables associees aux options de
+ compilation et directives specifiques (CPPFLAGS...)
+ a une librairie/application donnée.
+
+$ARCH est le contenu de la variable d'environnement ARCH a definir
+comme suit avant toute compilation du paquetage :
+
+export ARCH=LXNAGf95 sur Linux avec Fortran NAG f95
+export ARCH=LXpgf90 sur Linux avec Fortran PGI
+export ARCH=HPNAGf95 sur HP avec Fortran NAG f95
+export ARCH=HPf90 sur HP avec Fortran HP f90
+export ARCH=SGI32 sur Silicon avec gestion 32bits memoire
+export ARCH=SGI64 sur Silicon avec gestion 64bits memoire
+export ARCH=SX5 sur NEC SX5
+export ARCH=VPP sur Fujitsu VPP
+export ARCH=AIX sur IBM
+
+
+Remarque :
+
+Dans chaque Makefile, le fichier Rules.$ARCH est inclus
+APRES le fichier config.$ARCH. Par consequent, si une variable est
+definie a la fois dans le fichier config.$ARCH et Rules.$ARCH par le
+signe '=', la definition dans Rules.$ARCH ecrase la valeur de la
+variable definie dans config.$ARCH. Il est quand meme possible de
+conserver la valeur d'une variable definie dans config.$ARCH en
+redefinissant la variable dans Rules.$ARCH par le signe '+=' auquel
+cas, on concatene la valeur de la variable dans Rules.$ARCH a la
+valeur qui etait presente dans config.$ARCH.
+
+2) Generation des libraries :
+
+ - fixer la valeur de la variable d'environnement ARCH
+ - se placer dans le repertoire 'lib/'
+ - lancer la commande : make/gmake (GNU Make)
+
+Les repertoires NEWLFI,COMPRESS,MPIvide et rad2 sont alors parcourus
+et les librairies associees sont creees. Pour creer une librairie
+particuliere on peut, soit se placer dans le repertoire correspondant
+(par exemple lib/NEWLFI) et lancer 'make/gmake' soit lancer la
+commande 'make/gmake <repertoire>' dans 'lib/' pour compiler la
+librairie du repertoire 'lib/<repertoire>'.
+
+Noter que pour l'instant, il faut generer manuellement la librairie
+GRIB en se placant dans le repertoire 'lib/gribex_1302b/', en fixant
+la variable d'env. R64 et en redefinissant la variable ARCH. Il faut
+reprendre cela pour le rendre homogene avec le reste.
+
+
+3) Generation des outils : identique a la generation des libraries en
+ remplacant le repertoire 'lib/' par le repertoire 'tools/'.
+
+ - fixer la valeur de la variable d'environnement ARCH
+ - se placer dans le repertoire 'tools/'
+ - lancer la commande : make/gmake (GNU Make)
+
+Les repertoires lfiz,lfi2cdf et diachro sont parcourus pour generer
+les differents outils. Les outils conv2dia et diaprog sont crees l'un
+apres l'autre dans le repertoire 'diachro'. On peut se placer dans
+chacun des repertoires lfiz, lfi2cdf ou diaprog pour construire un
+outil particulier ou lancer gmake <repertoire> dans 'tools' pour creer
+les executables des outils dans <repertoire>.
+
+Si l'on tente de generer ces outils avant de creer les librairies
+NEWLFI et COMPRESS, ces dernieres sont automatiquement generees.
+
+Remarque concernant le repertoire 'diachro' (conv2dia et diaprog): il
+se peut que sur certaines architectures, on ne veuille pas generer
+conv2dia ou diaprog. Pour cela, il faut specifier dans le fichier
+Rules.$ARCH, la variable PROGALL et l'initialiser avec le programme
+que l'on desire generer : 'conv2dia' ou 'diaprog' (Cf. Rules.SX5 pour
+exemple). La variable "PROGALL=conv2dia diaprog" par defaut.
+
+4) Ou se trouvent les libraries/executables apres compilation ?
+
+Dans chaque sous-repertoire lib/NEWLFI...,tools/diachro,... est créé
+un repertoire $ARCH qui contient le resultat de la compilation.
+
+5) Nettoyage des fichiers objets, librairies, executables :
+
+Se placer dans les repertoires 'lib' ou 'tools'.
+Il existe 2 solutions decrites ci-dessous :
+
+- la premiere permet de supprimer les fichiers *.o cpp_*.f90 mais
+conserve le repertoire $ARCH avec les librairies ou les executables:
+
+make/gmake clean
+
+
+- la seconde efface tous les repertoires $ARCH et restitue les libtools
+tels qu'ils apparaissent a l'installation du fichier TAR :
+
+make/gmake distclean
+
+
+On peut egalement utiliser plus specifiquement le make/gmake
+clean/distclean dans chacun des sous-repertoires a partir de 'lib' et
+'tools'.
+
+6) Quelques remarques pour la generation des outils :
+
+- lfiz : necessite les librairies COMPRESS et NEWLFI presentes dans le
+repertoire 'lib'. A priori, pas de pb lors de l'edition de liens.
+
+- lfi2cdf : necessite la librairie NEWLFI ainsi que la librairie
+NetCDF. Pour generer l'executable avec succes, il faut s'assurer que
+le repertoire specifie dans Rules.$ARCH pour acceder a NetCDF est
+correct (variable NETCDFHOME) sinon la commande Make echoue avec un
+message clair a ce sujet.
+
+- conv2dia (repertoire 'diachro') : necessite les librairies COMPRESS
+et NEWLFI. A priori pas de pb a l'edition de lien
+
+- diaprog (repertoire 'diachro') : necessite en plus des librairies
+NEWLFI et COMPRESS, de libraries externes : ncar et X11. L'emplacement
+de la librairie NCAR est definie a partir de la variable
+d'environnment NCARG_ROOT qui doit etre valide. L'emplacement de la
+librairie X11 est definie par la variable LIBEXT de chaque fichier
+Rules.$ARCH dans 'diachro'.
+
+
+
diff --git a/LIBTOOLS/readme/mesonh2obs.LISEZMOI b/LIBTOOLS/readme/mesonh2obs.LISEZMOI
new file mode 100644
index 0000000000000000000000000000000000000000..8016ffe23550cda63f4555d54896802dfcd7e738
--- /dev/null
+++ b/LIBTOOLS/readme/mesonh2obs.LISEZMOI
@@ -0,0 +1,63 @@
+#
+# mesonh2obs
+#
+# Interpolation des champs modele aux points d'observation
+# et sorties aux formats:LL (lon,lat) ou ll (lat,lon) sur l'horizontale
+# H (niveaux modèle) ou Z (Z=cst) ou P (p=cst)
+# sur la verticale
+#
+# 1) preparer un fichier ascii des positions d observation (une position par ligne):
+# lon lat et les altitudes seront fournies en interactif
+# ou
+# lon lat altitude_en_m
+# ou
+# lat lon et les altitudes seront fournies en interactif
+# ou
+# lat lon altitude_en_m
+#
+# 2) disposer d un(des) fichier(s) diachronique(s): les champs indiques a mesonh2obs seront interpoles aux points reperes dans le fichier de positions
+#
+# 3) initialiser (facultatif si les fichiers sont dans le repertoire courant)
+ export DIRLFI=directory_fichier_diachro
+ export DIROBS=directory_fichier_position_des_obs
+# puis executer
+ mesonh2obs # et repondre aux questions en interactif
+ # un fichier "dirmnh2obs" consignera toutes vos réponses
+ # rentrées au clavier
+# ou
+ mesonh2obs < dirmnh2obs_precedente_execution
+# ou
+ mesonh2obs << eof
+format_fichier_de_sortie # format du fichier de sortie (LLHV/llhv/LLZV/llzv/LLPV/llpv)
+format_fichier_d_entrée # LL (lon,lat)ou ll (lat,lon)
+altitude_fichier_d_entrée # O (altitude_en_m en colonne 3)/N
+si N, nombre_niveaux_verticaux # nombre de niveaux verticaux à la verticale de
+ # chaque points lat,lon
+ liste de ces niveaux # liste exemple: (en metres ou hPa): exemple 500 1500
+fichier_position_des_obs # nom du fichier de localisation des obs préparé en 1)
+0 # prints de controle (0/1/2/3)
+fichier_diachronique1 # fichier contenant les champs a interpoler (sans .lfi)
+champ1_du_fichier_diachro1 # champ à interpoler
+champ2_du_fichier_diachro1
+END # fin d extraction fichier_diachronique1
+fichier_diachronique2 # fichier contenant les champs a interpoler (sans .lfi)
+champi_du_fichier_diachro2
+champj_du_fichier_diachro2
+END # fin d extraction fichier_diachronique2
+END # fin d extraction liste fichiers diachroniques
+eof
+#
+# si champ_du_fichier_diachro contient la chaine 'AC' (pour precipitations
+#ACcumulees), prévoir 1 ou 2 lignes de directive supplémentaire placées
+#directement derrière ce nom de champ:
+# première ligne supplémentaire= la réponse 'Y/N' à la question
+#"Pluie cumulee, voulez-vous faire la difference avec un instant anterieur (o/O/y/Y/n/N) ?"
+# si la réponse est 'Y/O',
+#seconde ligne supplémentaire= nom du fichier diachronique (sans .lfi)
+#correspondant à l'instant précédent
+# on soustrait alors champ_du_fichier_diachro1 et champ_du_fichier_diachro_seconde_ligne_supplémentaire
+#
+# 4) on obtient un fichier ascii par fichier diachro traite contenant les differents champs modele interpoles aux points d'observation (deux lignes de commentaire avant chaque champ)
+#
+# Mise à jour le 30/01/2004
+# Mise à jour le 01/03/2005
diff --git a/LIBTOOLS/readme/obs2mesonh.LISEZMOI b/LIBTOOLS/readme/obs2mesonh.LISEZMOI
new file mode 100644
index 0000000000000000000000000000000000000000..60cbc9840d56776ef687481ae9ec8442fcd1e8bd
--- /dev/null
+++ b/LIBTOOLS/readme/obs2mesonh.LISEZMOI
@@ -0,0 +1,80 @@
+#
+# obs2mesonh
+#
+# Intégration des observations 1D,2D,3D dans la grille Mesonh et écriture d'un fichier
+# diachronique pouvant être utilisé via diaprog ou extractdia (readvar/writevar)
+#
+# 1) préparer un(des) fichier(s) ascii contenant toutes les observations
+# au format suivant: une obs par ligne, la valeur indéfinie prévue étant 999.0
+# lon lat altitude_en_mètres valeur
+# ou lat lon altitude_en_mètres valeur
+#
+# 2) disposer d un fichier diachronique (fic_diachro_avec_zs): les observations seront integrees sur la grille definie dans ce fichier
+#
+# 3) initialiser (facultatif si les fichiers sont dans le repertoire courant)
+ export DIROBS=directory_fichiers_obs
+ export DIRLFI=directory_fichier_grille_mesonh
+# puis executer
+ obs2mesonh #et répondre aux questions en interactif
+ # Un fichier "dirobs2mnh" consignera toutes vos réponses
+ # rentrées au clavier
+# ou
+ obs2mesonh < dirobs2mnh_execution_precedente
+# ou
+ obs2mesonh << eof
+fic_diachro_avec_zs # pour initialiser la grille Mesonh et les dates/heures
+0/1/2/3 # + ou - de prints de contrôle
+LL # format du fichier d obs (LL=lon lat alt valeur,
+ # ll=lat lon alt valeur)
+fichier1_obs # format lon lat altitude valeur (indef=999.0)
+nom_nouveau_champ # nom des obs du fichier1 suivant la logique diaprog
+unité_nouveau_champ # chaine de caractères libre
+1D/2D/3D # champ créé de type 1D ou 3D ou 2D
+ # pour le cas 2D, seul K=1 sera initialisé
+LL # format du fichier d obs (LL=lon lat alt valeur, ll= lat lon alt valeur)
+fichier2_obs
+nom_nouveau_champ2
+unité_nouveau_champ2
+1D/2D/3D
+END # fin donc fermeture du fichier diachro résultat
+eof
+#
+# 4) le fichier résultat est nommé fic_diachro_avec_zs+'obs':
+# sa grille et ses dates/heures sont celles de fic_diachro_avec_zs,
+# le champ ZS est celui de fic_diachro_avec_zs
+# il contient autant de champs que de fichiers d'obs traités lors de
+# l'exécution de obs2mesonh.
+# + un champ ALT_nom_champ si le type=2D : altitude des obs
+# + un champ N_nom_champ : nombre d obs par point de grille
+#
+# diaprog ou extractdia ou ... sont utilisables
+#
+# Pour les tracés, utiliser la version postérieure à diaprog_LX_020204
+# activer l'option LSPOT=T pour obtenir le tracé de
+# toutes les valeurs même si celles-ci sont trés peu denses.
+#
+#
+#Méthode utilisée:
+#=================
+#
+# pour chaque obs lue,
+# - recherche du point de grille Mesonh I,J contenant cette obs.
+# - puis recherche du niveau vertical en tenant compte de la
+# grille verticale au point I,J ( grille verticale W si le nom du champ
+# commence par la lettre W, grille de masse pour tous les autres noms
+# - stockage de l'obs au point de grille (I,J,K)
+#
+# Pour les composantes du vent, on suppose que les observations sont
+# lues en Uzonal et Vméridien et on transforme ces composantes pour les
+# utiliser dans la grille Mesonh.
+#
+# Moyenne arithmétique des obs contenues dans la même maille du modèle
+# Valeur indefinie si aucune obs.
+# Pour les obs dont l unité est "dBz" : passage dbZe à Ze pour effectuer
+# la moyenne puis retour à dbZe pour l'écriture
+# Les observations dont l'altitude est inférieure à l'altitude du premier
+# niveau de modèle sont stockées au niveau k=1 et un message est affiché lors de
+# l'exécution.
+#
+# Mise à jour le 02/04/2004
+# Mise à jour le 01/03/2005
diff --git a/LIBTOOLS/readme/tools.ps b/LIBTOOLS/readme/tools.ps
new file mode 100644
index 0000000000000000000000000000000000000000..e1e6f8ea8f0d131b3957880641dd0d464e33c6c8
--- /dev/null
+++ b/LIBTOOLS/readme/tools.ps
@@ -0,0 +1,11341 @@
+%!PS-Adobe-2.0
+%%Creator: dvips(k) 5.92b Copyright 2002 Radical Eye Software
+%%Title: tools.dvi
+%%Pages: 27
+%%PageOrder: Ascend
+%%BoundingBox: 0 0 596 842
+%%DocumentFonts: CMR17 CMR12 CMBX12 CMTT12 Times-Bold Times-Italic
+%%+ Times-Roman Helvetica Courier Helvetica-Bold NewCenturySchlbk-Bold
+%%+ NewCenturySchlbk-Roman CMCSC10 CMSY10 CMMI12 CMTT10 CMTI10 CMR8 CMR7
+%%+ CMR10 CMMI8 CMSS12 CMTI12 CMMI10 CMBX10
+%%EndComments
+%DVIPSWebPage: (www.radicaleye.com)
+%DVIPSCommandLine: dvips -f tools.dvi
+%DVIPSParameters: dpi=600, compressed
+%DVIPSSource: TeX output 2005.03.21:1057
+%%BeginProcSet: texc.pro
+%!
+/TeXDict 300 dict def TeXDict begin/N{def}def/B{bind def}N/S{exch}N/X{S
+N}B/A{dup}B/TR{translate}N/isls false N/vsize 11 72 mul N/hsize 8.5 72
+mul N/landplus90{false}def/@rigin{isls{[0 landplus90{1 -1}{-1 1}ifelse 0
+0 0]concat}if 72 Resolution div 72 VResolution div neg scale isls{
+landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div hsize
+mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul TR[
+matrix currentmatrix{A A round sub abs 0.00001 lt{round}if}forall round
+exch round exch]setmatrix}N/@landscape{/isls true N}B/@manualfeed{
+statusdict/manualfeed true put}B/@copies{/#copies X}B/FMat[1 0 0 -1 0 0]
+N/FBB[0 0 0 0]N/nn 0 N/IEn 0 N/ctr 0 N/df-tail{/nn 8 dict N nn begin
+/FontType 3 N/FontMatrix fntrx N/FontBBox FBB N string/base X array
+/BitMaps X/BuildChar{CharBuilder}N/Encoding IEn N end A{/foo setfont}2
+array copy cvx N load 0 nn put/ctr 0 N[}B/sf 0 N/df{/sf 1 N/fntrx FMat N
+df-tail}B/dfs{div/sf X/fntrx[sf 0 0 sf neg 0 0]N df-tail}B/E{pop nn A
+definefont setfont}B/Cw{Cd A length 5 sub get}B/Ch{Cd A length 4 sub get
+}B/Cx{128 Cd A length 3 sub get sub}B/Cy{Cd A length 2 sub get 127 sub}
+B/Cdx{Cd A length 1 sub get}B/Ci{Cd A type/stringtype ne{ctr get/ctr ctr
+1 add N}if}B/id 0 N/rw 0 N/rc 0 N/gp 0 N/cp 0 N/G 0 N/CharBuilder{save 3
+1 roll S A/base get 2 index get S/BitMaps get S get/Cd X pop/ctr 0 N Cdx
+0 Cx Cy Ch sub Cx Cw add Cy setcachedevice Cw Ch true[1 0 0 -1 -.1 Cx
+sub Cy .1 sub]/id Ci N/rw Cw 7 add 8 idiv string N/rc 0 N/gp 0 N/cp 0 N{
+rc 0 ne{rc 1 sub/rc X rw}{G}ifelse}imagemask restore}B/G{{id gp get/gp
+gp 1 add N A 18 mod S 18 idiv pl S get exec}loop}B/adv{cp add/cp X}B
+/chg{rw cp id gp 4 index getinterval putinterval A gp add/gp X adv}B/nd{
+/cp 0 N rw exit}B/lsh{rw cp 2 copy get A 0 eq{pop 1}{A 255 eq{pop 254}{
+A A add 255 and S 1 and or}ifelse}ifelse put 1 adv}B/rsh{rw cp 2 copy
+get A 0 eq{pop 128}{A 255 eq{pop 127}{A 2 idiv S 128 and or}ifelse}
+ifelse put 1 adv}B/clr{rw cp 2 index string putinterval adv}B/set{rw cp
+fillstr 0 4 index getinterval putinterval adv}B/fillstr 18 string 0 1 17
+{2 copy 255 put pop}for N/pl[{adv 1 chg}{adv 1 chg nd}{1 add chg}{1 add
+chg nd}{adv lsh}{adv lsh nd}{adv rsh}{adv rsh nd}{1 add adv}{/rc X nd}{
+1 add set}{1 add clr}{adv 2 chg}{adv 2 chg nd}{pop nd}]A{bind pop}
+forall N/D{/cc X A type/stringtype ne{]}if nn/base get cc ctr put nn
+/BitMaps get S ctr S sf 1 ne{A A length 1 sub A 2 index S get sf div put
+}if put/ctr ctr 1 add N}B/I{cc 1 add D}B/bop{userdict/bop-hook known{
+bop-hook}if/SI save N @rigin 0 0 moveto/V matrix currentmatrix A 1 get A
+mul exch 0 get A mul add .99 lt{/QV}{/RV}ifelse load def pop pop}N/eop{
+SI restore userdict/eop-hook known{eop-hook}if showpage}N/@start{
+userdict/start-hook known{start-hook}if pop/VResolution X/Resolution X
+1000 div/DVImag X/IEn 256 array N 2 string 0 1 255{IEn S A 360 add 36 4
+index cvrs cvn put}for pop 65781.76 div/vsize X 65781.76 div/hsize X}N
+/p{show}N/RMat[1 0 0 -1 0 0]N/BDot 260 string N/Rx 0 N/Ry 0 N/V{}B/RV/v{
+/Ry X/Rx X V}B statusdict begin/product where{pop false[(Display)(NeXT)
+(LaserWriter 16/600)]{A length product length le{A length product exch 0
+exch getinterval eq{pop true exit}if}{pop}ifelse}forall}{false}ifelse
+end{{gsave TR -.1 .1 TR 1 1 scale Rx Ry false RMat{BDot}imagemask
+grestore}}{{gsave TR -.1 .1 TR Rx Ry scale 1 1 false RMat{BDot}
+imagemask grestore}}ifelse B/QV{gsave newpath transform round exch round
+exch itransform moveto Rx 0 rlineto 0 Ry neg rlineto Rx neg 0 rlineto
+fill grestore}B/a{moveto}B/delta 0 N/tail{A/delta X 0 rmoveto}B/M{S p
+delta add tail}B/b{S p tail}B/c{-4 M}B/d{-3 M}B/e{-2 M}B/f{-1 M}B/g{0 M}
+B/h{1 M}B/i{2 M}B/j{3 M}B/k{4 M}B/w{0 rmoveto}B/l{p -4 w}B/m{p -3 w}B/n{
+p -2 w}B/o{p -1 w}B/q{p 1 w}B/r{p 2 w}B/s{p 3 w}B/t{p 4 w}B/x{0 S
+rmoveto}B/y{3 2 roll p a}B/bos{/SS save N}B/eos{SS restore}B end
+
+%%EndProcSet
+%%BeginProcSet: f7b6d320.enc
+% Thomas Esser, Dec 2002. public domain
+%
+% Encoding for:
+% cmb10 cmbx10 cmbx12 cmbx5 cmbx6 cmbx7 cmbx8 cmbx9 cmbxsl10
+% cmdunh10 cmr10 cmr12 cmr17cmr6 cmr7 cmr8 cmr9 cmsl10 cmsl12 cmsl8
+% cmsl9 cmss10cmss12 cmss17 cmss8 cmss9 cmssbx10 cmssdc10 cmssi10
+% cmssi12 cmssi17 cmssi8cmssi9 cmssq8 cmssqi8 cmvtt10
+%
+/TeXf7b6d320Encoding [
+/Gamma /Delta /Theta /Lambda /Xi /Pi /Sigma /Upsilon /Phi /Psi /Omega
+/ff /fi /fl /ffi /ffl /dotlessi /dotlessj /grave /acute /caron /breve
+/macron /ring /cedilla /germandbls /ae /oe /oslash /AE /OE /Oslash
+/suppress /exclam /quotedblright /numbersign /dollar /percent /ampersand
+/quoteright /parenleft /parenright /asterisk /plus /comma /hyphen
+/period /slash /zero /one /two /three /four /five /six /seven /eight
+/nine /colon /semicolon /exclamdown /equal /questiondown /question /at
+/A /B /C /D /E /F /G /H /I /J /K /L /M /N /O /P /Q /R /S /T /U /V /W /X
+/Y /Z /bracketleft /quotedblleft /bracketright /circumflex /dotaccent
+/quoteleft /a /b /c /d /e /f /g /h /i /j /k /l /m /n /o /p /q /r /s /t /u
+/v /w /x /y /z /endash /emdash /hungarumlaut /tilde /dieresis /suppress
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /space
+/Gamma /Delta /Theta /Lambda /Xi /Pi /Sigma /Upsilon /Phi /Psi /.notdef
+/.notdef /Omega /ff /fi /fl /ffi /ffl /dotlessi /dotlessj /grave /acute
+/caron /breve /macron /ring /cedilla /germandbls /ae /oe /oslash /AE
+/OE /Oslash /suppress /dieresis /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+] def
+
+%%EndProcSet
+%%BeginProcSet: 09fbbfac.enc
+% Thomas Esser, Dec 2002. public domain
+%
+% Encoding for:
+% cmsltt10 cmtt10 cmtt12 cmtt8 cmtt9
+/TeX09fbbfacEncoding [
+/Gamma /Delta /Theta /Lambda /Xi /Pi /Sigma /Upsilon /Phi /Psi
+/Omega /arrowup /arrowdown /quotesingle /exclamdown /questiondown
+/dotlessi /dotlessj /grave /acute /caron /breve /macron /ring /cedilla
+/germandbls /ae /oe /oslash /AE /OE /Oslash /visiblespace /exclam
+/quotedbl /numbersign /dollar /percent /ampersand /quoteright /parenleft
+/parenright /asterisk /plus /comma /hyphen /period /slash /zero /one
+/two /three /four /five /six /seven /eight /nine /colon /semicolon /less
+/equal /greater /question /at /A /B /C /D /E /F /G /H /I /J /K /L /M /N
+/O /P /Q /R /S /T /U /V /W /X /Y /Z /bracketleft /backslash /bracketright
+/asciicircum /underscore /quoteleft /a /b /c /d /e /f /g /h /i /j /k /l
+/m /n /o /p /q /r /s /t /u /v /w /x /y /z /braceleft /bar /braceright
+/asciitilde /dieresis /visiblespace /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /space /Gamma /Delta /Theta /Lambda /Xi /Pi
+/Sigma /Upsilon /Phi /Psi /.notdef /.notdef /Omega /arrowup /arrowdown
+/quotesingle /exclamdown /questiondown /dotlessi /dotlessj /grave /acute
+/caron /breve /macron /ring /cedilla /germandbls /ae /oe /oslash /AE
+/OE /Oslash /visiblespace /dieresis /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+] def
+
+%%EndProcSet
+%%BeginProcSet: 8r.enc
+% File 8r.enc as of 2002-03-12 for PSNFSS 9
+%
+% This is the encoding vector for Type1 and TrueType fonts to be used
+% with TeX. This file is part of the PSNFSS bundle, version 9
+%
+% Authors: S. Rahtz, P. MacKay, Alan Jeffrey, B. Horn, K. Berry, W. Schmidt
+%
+% Idea is to have all the characters normally included in Type 1 fonts
+% available for typesetting. This is effectively the characters in Adobe
+% Standard Encoding + ISO Latin 1 + extra characters from Lucida + Euro.
+%
+% Character code assignments were made as follows:
+%
+% (1) the Windows ANSI characters are almost all in their Windows ANSI
+% positions, because some Windows users cannot easily reencode the
+% fonts, and it makes no difference on other systems. The only Windows
+% ANSI characters not available are those that make no sense for
+% typesetting -- rubout (127 decimal), nobreakspace (160), softhyphen
+% (173). quotesingle and grave are moved just because it's such an
+% irritation not having them in TeX positions.
+%
+% (2) Remaining characters are assigned arbitrarily to the lower part
+% of the range, avoiding 0, 10 and 13 in case we meet dumb software.
+%
+% (3) Y&Y Lucida Bright includes some extra text characters; in the
+% hopes that other PostScript fonts, perhaps created for public
+% consumption, will include them, they are included starting at 0x12.
+%
+% (4) Remaining positions left undefined are for use in (hopefully)
+% upward-compatible revisions, if someday more characters are generally
+% available.
+%
+% (5) hyphen appears twice for compatibility with both ASCII and Windows.
+%
+% (6) /Euro is assigned to 128, as in Windows ANSI
+%
+/TeXBase1Encoding [
+% 0x00 (encoded characters from Adobe Standard not in Windows 3.1)
+ /.notdef /dotaccent /fi /fl
+ /fraction /hungarumlaut /Lslash /lslash
+ /ogonek /ring /.notdef
+ /breve /minus /.notdef
+% These are the only two remaining unencoded characters, so may as
+% well include them.
+ /Zcaron /zcaron
+% 0x10
+ /caron /dotlessi
+% (unusual TeX characters available in, e.g., Lucida Bright)
+ /dotlessj /ff /ffi /ffl
+ /.notdef /.notdef /.notdef /.notdef
+ /.notdef /.notdef /.notdef /.notdef
+ % very contentious; it's so painful not having quoteleft and quoteright
+ % at 96 and 145 that we move the things normally found there down to here.
+ /grave /quotesingle
+% 0x20 (ASCII begins)
+ /space /exclam /quotedbl /numbersign
+ /dollar /percent /ampersand /quoteright
+ /parenleft /parenright /asterisk /plus /comma /hyphen /period /slash
+% 0x30
+ /zero /one /two /three /four /five /six /seven
+ /eight /nine /colon /semicolon /less /equal /greater /question
+% 0x40
+ /at /A /B /C /D /E /F /G /H /I /J /K /L /M /N /O
+% 0x50
+ /P /Q /R /S /T /U /V /W
+ /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore
+% 0x60
+ /quoteleft /a /b /c /d /e /f /g /h /i /j /k /l /m /n /o
+% 0x70
+ /p /q /r /s /t /u /v /w
+ /x /y /z /braceleft /bar /braceright /asciitilde
+ /.notdef % rubout; ASCII ends
+% 0x80
+ /Euro /.notdef /quotesinglbase /florin
+ /quotedblbase /ellipsis /dagger /daggerdbl
+ /circumflex /perthousand /Scaron /guilsinglleft
+ /OE /.notdef /.notdef /.notdef
+% 0x90
+ /.notdef /.notdef /.notdef /quotedblleft
+ /quotedblright /bullet /endash /emdash
+ /tilde /trademark /scaron /guilsinglright
+ /oe /.notdef /.notdef /Ydieresis
+% 0xA0
+ /.notdef % nobreakspace
+ /exclamdown /cent /sterling
+ /currency /yen /brokenbar /section
+ /dieresis /copyright /ordfeminine /guillemotleft
+ /logicalnot
+ /hyphen % Y&Y (also at 45); Windows' softhyphen
+ /registered
+ /macron
+% 0xD0
+ /degree /plusminus /twosuperior /threesuperior
+ /acute /mu /paragraph /periodcentered
+ /cedilla /onesuperior /ordmasculine /guillemotright
+ /onequarter /onehalf /threequarters /questiondown
+% 0xC0
+ /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla
+ /Egrave /Eacute /Ecircumflex /Edieresis
+ /Igrave /Iacute /Icircumflex /Idieresis
+% 0xD0
+ /Eth /Ntilde /Ograve /Oacute
+ /Ocircumflex /Otilde /Odieresis /multiply
+ /Oslash /Ugrave /Uacute /Ucircumflex
+ /Udieresis /Yacute /Thorn /germandbls
+% 0xE0
+ /agrave /aacute /acircumflex /atilde
+ /adieresis /aring /ae /ccedilla
+ /egrave /eacute /ecircumflex /edieresis
+ /igrave /iacute /icircumflex /idieresis
+% 0xF0
+ /eth /ntilde /ograve /oacute
+ /ocircumflex /otilde /odieresis /divide
+ /oslash /ugrave /uacute /ucircumflex
+ /udieresis /yacute /thorn /ydieresis
+] def
+
+%%EndProcSet
+%%BeginProcSet: texnansi.enc
+% @psencodingfile{
+% author = "Y&Y, Inc.",
+% version = "1.1",
+% date = "1 December 1996",
+% filename = "texnansi.enc",
+% email = "help@YandY.com",
+% address = "45 Walden Street // Concord, MA 01742, USA",
+% codetable = "ISO/ASCII",
+% checksum = "xx",
+% docstring = "Encoding for fonts in Adobe Type 1 format for use with TeX."
+% }
+%
+% The idea is to have all 228 characters normally included in Type 1 text
+% fonts (plus a few more) available for typesetting. This is effectively
+% the character set in Adobe Standard Encoding, ISO Latin 1, plus a few more.
+%
+% Character code assignments were made as follows:
+%
+% (1) The character layout largely matches `ASCII' in the 32 -- 126 range,
+% except for `circumflex' in 94 and `tilde' in 126, to match `TeX text'
+% (`asciicircumflex' and `asciitilde' appear in 158 and 142 instead).
+%
+% (2) The character layout matches `Windows ANSI' in almost all places,
+% except for `quoteright' in 39 and `quoteleft' in 96 to match ASCII
+% (`quotesingle' and `grave' appear in 129 and 18 instead).
+%
+% (3) The character layout matches `TeX typewriter' used by CM text fonts
+% in most places (except for discordant positions such as hungarumlaut
+% (instead of braceright), dotaccent (instead of underscore) etc.
+%
+% (4) Remaining characters are assigned arbitrarily to the `control character'
+% range (0 -- 31), avoiding 0, 9, 10 and 13 in case we meet dumb software
+% - similarly one should really avoid 127 and 128 if possible.
+% In addition, the 8 open slots in Windows ANSI between 128 and 159 are used.
+%
+% (5) Y&Y Lucida Bright includes some extra ligatures and such; ff, ffi, ffl,
+% and `dotlessj,' these are included 11 -- 15, and 17.
+%
+% (6) Hyphen appears both at 45 and 173 for compatibility with both ASCII
+% and Windows ANSI.
+%
+% (7) It doesn't really matter where ligatures appear (both real, such as ffi,
+% and pseudo such as ---) since these should not be accessed directly, only
+% via ligature information in the TFM file.
+%
+% SAMPLE USAGE (in `psfonts.map' file for DVIPS):
+%
+% lbr LucidaBright "TeXnANSIEncoding ReEncodeFont" <texnansi.enc <lbr.pfb
+%
+% This tells DVIPS that the font called `lbr' in TeX has PostScript
+% FontName `LucidaBright.' It also asks DVIPS to expand the file `lbr.pfb'
+% into PFA form, to include the attached `texnansi.enc' encoding vector,
+% and to then actually reencode the font based on that encoding vector.
+%
+% Revised 1996 June 1 by adding second position for `fl' to avoid Acrobat bug.
+% Revised 1996 June 1 by adding second position for `fraction' for same reason.
+% Revised 1997 Oct 1 by adding cwm (used in boundary char TFM code)
+% Revised 1998 Mar 1 by adding Unicode for Euro character
+%
+/TeXnANSIEncoding [
+/.notdef % 0
+/Euro % /Uni20AC 1
+/.notdef % 2
+/.notdef % 3
+/fraction % 4
+/dotaccent % 5
+/hungarumlaut % 6
+/ogonek % 7
+/fl % 8
+/.notdef % /fraction % 9 not used (see 4), backward compatability only
+/cwm % 10 not used, except boundary char internally maybe
+/ff % 11
+/fi % 12
+/.notdef % /fl % 13 not used (see 8), backward compatability only
+/ffi % 14
+/ffl % 15
+/dotlessi % 16
+/dotlessj % 17
+/grave % 18
+/acute % 19
+/caron % 20
+/breve % 21
+/macron % 22
+/ring % 23
+/cedilla % 24
+/germandbls % 25
+/ae % 26
+/oe % 27
+/oslash % 28
+/AE % 29
+/OE % 30
+/Oslash % 31
+/space % 32 % /suppress in TeX text
+/exclam % 33
+/quotedbl % 34 % /quotedblright in TeX text
+/numbersign % 35
+/dollar % 36
+/percent % 37
+/ampersand % 38
+/quoteright % 39 % /quotesingle in ANSI
+/parenleft % 40
+/parenright % 41
+/asterisk % 42
+/plus % 43
+/comma % 44
+/hyphen % 45
+/period % 46
+/slash % 47
+/zero % 48
+/one % 49
+/two % 50
+/three % 51
+/four % 52
+/five % 53
+/six % 54
+/seven % 55
+/eight % 56
+/nine % 57
+/colon % 58
+/semicolon % 59
+/less % 60 % /exclamdown in Tex text
+/equal % 61
+/greater % 62 % /questiondown in TeX text
+/question % 63
+/at % 64
+/A % 65
+/B % 66
+/C % 67
+/D % 68
+/E % 69
+/F % 70
+/G % 71
+/H % 72
+/I % 73
+/J % 74
+/K % 75
+/L % 76
+/M % 77
+/N % 78
+/O % 79
+/P % 80
+/Q % 81
+/R % 82
+/S % 83
+/T % 84
+/U % 85
+/V % 86
+/W % 87
+/X % 88
+/Y % 89
+/Z % 90
+/bracketleft % 91
+/backslash % 92 % /quotedblleft in TeX text
+/bracketright % 93
+/circumflex % 94 % /asciicircum in ASCII
+/underscore % 95 % /dotaccent in TeX text
+/quoteleft % 96 % /grave accent in ANSI
+/a % 97
+/b % 98
+/c % 99
+/d % 100
+/e % 101
+/f % 102
+/g % 103
+/h % 104
+/i % 105
+/j % 106
+/k % 107
+/l % 108
+/m % 109
+/n % 110
+/o % 111
+/p % 112
+/q % 113
+/r % 114
+/s % 115
+/t % 116
+/u % 117
+/v % 118
+/w % 119
+/x % 120
+/y % 121
+/z % 122
+/braceleft % 123 % /endash in TeX text
+/bar % 124 % /emdash in TeX test
+/braceright % 125 % /hungarumlaut in TeX text
+/tilde % 126 % /asciitilde in ASCII
+/dieresis % 127 not used (see 168), use higher up instead
+/Lslash % 128 this position is unfortunate, but now too late to fix
+/quotesingle % 129
+/quotesinglbase % 130
+/florin % 131
+/quotedblbase % 132
+/ellipsis % 133
+/dagger % 134
+/daggerdbl % 135
+/circumflex % 136
+/perthousand % 137
+/Scaron % 138
+/guilsinglleft % 139
+/OE % 140
+/Zcaron % 141
+/asciicircum % 142
+/minus % 143
+/lslash % 144
+/quoteleft % 145
+/quoteright % 146
+/quotedblleft % 147
+/quotedblright % 148
+/bullet % 149
+/endash % 150
+/emdash % 151
+/tilde % 152
+/trademark % 153
+/scaron % 154
+/guilsinglright % 155
+/oe % 156
+/zcaron % 157
+/asciitilde % 158
+/Ydieresis % 159
+/nbspace % 160 % /space (no break space)
+/exclamdown % 161
+/cent % 162
+/sterling % 163
+/currency % 164
+/yen % 165
+/brokenbar % 166
+/section % 167
+/dieresis % 168
+/copyright % 169
+/ordfeminine % 170
+/guillemotleft % 171
+/logicalnot % 172
+/sfthyphen % 173 % /hyphen (hanging hyphen)
+/registered % 174
+/macron % 175
+/degree % 176
+/plusminus % 177
+/twosuperior % 178
+/threesuperior % 179
+/acute % 180
+/mu % 181
+/paragraph % 182
+/periodcentered % 183
+/cedilla % 184
+/onesuperior % 185
+/ordmasculine % 186
+/guillemotright % 187
+/onequarter % 188
+/onehalf % 189
+/threequarters % 190
+/questiondown % 191
+/Agrave % 192
+/Aacute % 193
+/Acircumflex % 194
+/Atilde % 195
+/Adieresis % 196
+/Aring % 197
+/AE % 198
+/Ccedilla % 199
+/Egrave % 200
+/Eacute % 201
+/Ecircumflex % 202
+/Edieresis % 203
+/Igrave % 204
+/Iacute % 205
+/Icircumflex % 206
+/Idieresis % 207
+/Eth % 208
+/Ntilde % 209
+/Ograve % 210
+/Oacute % 211
+/Ocircumflex % 212
+/Otilde % 213
+/Odieresis % 214
+/multiply % 215 % OE in T1
+/Oslash % 216
+/Ugrave % 217
+/Uacute % 218
+/Ucircumflex % 219
+/Udieresis % 220
+/Yacute % 221
+/Thorn % 222
+/germandbls % 223
+/agrave % 224
+/aacute % 225
+/acircumflex % 226
+/atilde % 227
+/adieresis % 228
+/aring % 229
+/ae % 230
+/ccedilla % 231
+/egrave % 232
+/eacute % 233
+/ecircumflex % 234
+/edieresis % 235
+/igrave % 236
+/iacute % 237
+/icircumflex % 238
+/idieresis % 239
+/eth % 240
+/ntilde % 241
+/ograve % 242
+/oacute % 243
+/ocircumflex % 244
+/otilde % 245
+/odieresis % 246
+/divide % 247 % oe in T1
+/oslash % 248
+/ugrave % 249
+/uacute % 250
+/ucircumflex % 251
+/udieresis % 252
+/yacute % 253
+/thorn % 254
+/ydieresis % 255 % germandbls in T1
+] def
+
+%%EndProcSet
+%%BeginProcSet: 0ef0afca.enc
+% Thomas Esser, Dec 2002. public domain
+%
+% Encoding for:
+% cmr5
+%
+/TeX0ef0afcaEncoding [
+/Gamma /Delta /Theta /Lambda /Xi /Pi /Sigma /Upsilon /Phi /Psi /Omega
+/arrowup /arrowdown /quotesingle /exclamdown /questiondown /dotlessi
+/dotlessj /grave /acute /caron /breve /macron /ring /cedilla /germandbls
+/ae /oe /oslash /AE /OE /Oslash /suppress /exclam /quotedblright
+/numbersign /dollar /percent /ampersand /quoteright /parenleft
+/parenright /asterisk /plus /comma /hyphen /period /slash /zero /one
+/two /three /four /five /six /seven /eight /nine /colon /semicolon
+/less /equal /greater /question /at /A /B /C /D /E /F /G /H /I /J /K
+/L /M /N /O /P /Q /R /S /T /U /V /W /X /Y /Z /bracketleft /quotedblleft
+/bracketright /circumflex /dotaccent /quoteleft /a /b /c /d /e /f /g /h
+/i /j /k /l /m /n /o /p /q /r /s /t /u /v /w /x /y /z /endash /emdash
+/hungarumlaut /tilde /dieresis /suppress /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /space /Gamma /Delta /Theta /Lambda
+/Xi /Pi /Sigma /Upsilon /Phi /Psi /.notdef /.notdef /Omega /arrowup
+/arrowdown /quotesingle /exclamdown /questiondown /dotlessi /dotlessj
+/grave /acute /caron /breve /macron /ring /cedilla /germandbls /ae /oe
+/oslash /AE /OE /Oslash /suppress /dieresis /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+] def
+
+%%EndProcSet
+%%BeginProcSet: bbad153f.enc
+% Thomas Esser, Dec 2002. public domain
+%
+% Encoding for:
+% cmsy10 cmsy5 cmsy6 cmsy7 cmsy8 cmsy9
+%
+/TeXbbad153fEncoding [
+/minus /periodcentered /multiply /asteriskmath /divide /diamondmath
+/plusminus /minusplus /circleplus /circleminus /circlemultiply
+/circledivide /circledot /circlecopyrt /openbullet /bullet
+/equivasymptotic /equivalence /reflexsubset /reflexsuperset /lessequal
+/greaterequal /precedesequal /followsequal /similar /approxequal
+/propersubset /propersuperset /lessmuch /greatermuch /precedes /follows
+/arrowleft /arrowright /arrowup /arrowdown /arrowboth /arrownortheast
+/arrowsoutheast /similarequal /arrowdblleft /arrowdblright /arrowdblup
+/arrowdbldown /arrowdblboth /arrownorthwest /arrowsouthwest /proportional
+/prime /infinity /element /owner /triangle /triangleinv /negationslash
+/mapsto /universal /existential /logicalnot /emptyset /Rfractur /Ifractur
+/latticetop /perpendicular /aleph /A /B /C /D /E /F /G /H /I /J /K
+/L /M /N /O /P /Q /R /S /T /U /V /W /X /Y /Z /union /intersection
+/unionmulti /logicaland /logicalor /turnstileleft /turnstileright
+/floorleft /floorright /ceilingleft /ceilingright /braceleft /braceright
+/angbracketleft /angbracketright /bar /bardbl /arrowbothv /arrowdblbothv
+/backslash /wreathproduct /radical /coproduct /nabla /integral
+/unionsq /intersectionsq /subsetsqequal /supersetsqequal /section
+/dagger /daggerdbl /paragraph /club /diamond /heart /spade /arrowleft
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/minus /periodcentered /multiply /asteriskmath /divide /diamondmath
+/plusminus /minusplus /circleplus /circleminus /.notdef /.notdef
+/circlemultiply /circledivide /circledot /circlecopyrt /openbullet
+/bullet /equivasymptotic /equivalence /reflexsubset /reflexsuperset
+/lessequal /greaterequal /precedesequal /followsequal /similar
+/approxequal /propersubset /propersuperset /lessmuch /greatermuch
+/precedes /follows /arrowleft /spade /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+] def
+
+%%EndProcSet
+%%BeginProcSet: aae443f0.enc
+% Thomas Esser, Dec 2002. public domain
+%
+% Encoding for:
+% cmmi10 cmmi12 cmmi5 cmmi6 cmmi7 cmmi8 cmmi9 cmmib10
+%
+/TeXaae443f0Encoding [
+/Gamma /Delta /Theta /Lambda /Xi /Pi /Sigma /Upsilon /Phi /Psi /Omega
+/alpha /beta /gamma /delta /epsilon1 /zeta /eta /theta /iota /kappa
+/lambda /mu /nu /xi /pi /rho /sigma /tau /upsilon /phi /chi /psi
+/omega /epsilon /theta1 /pi1 /rho1 /sigma1 /phi1 /arrowlefttophalf
+/arrowleftbothalf /arrowrighttophalf /arrowrightbothalf /arrowhookleft
+/arrowhookright /triangleright /triangleleft /zerooldstyle /oneoldstyle
+/twooldstyle /threeoldstyle /fouroldstyle /fiveoldstyle /sixoldstyle
+/sevenoldstyle /eightoldstyle /nineoldstyle /period /comma /less /slash
+/greater /star /partialdiff /A /B /C /D /E /F /G /H /I /J /K /L /M /N
+/O /P /Q /R /S /T /U /V /W /X /Y /Z /flat /natural /sharp /slurbelow
+/slurabove /lscript /a /b /c /d /e /f /g /h /i /j /k /l /m /n /o /p
+/q /r /s /t /u /v /w /x /y /z /dotlessi /dotlessj /weierstrass /vector
+/tie /psi /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/space /Gamma /Delta /Theta /Lambda /Xi /Pi /Sigma /Upsilon /Phi /Psi
+/.notdef /.notdef /Omega /alpha /beta /gamma /delta /epsilon1 /zeta /eta
+/theta /iota /kappa /lambda /mu /nu /xi /pi /rho /sigma /tau /upsilon
+/phi /chi /psi /tie /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef
+] def
+
+%%EndProcSet
+%%BeginProcSet: 74afc74c.enc
+% Thomas Esser, Dec 2002. public domain
+%
+% Encoding for:
+% cmbxti10 cmff10 cmfi10 cmfib8 cmti10 cmti12 cmti7 cmti8cmti9 cmu10
+%
+/TeX74afc74cEncoding [
+/Gamma /Delta /Theta /Lambda /Xi /Pi /Sigma /Upsilon /Phi /Psi /Omega
+/ff /fi /fl /ffi /ffl /dotlessi /dotlessj /grave /acute /caron /breve
+/macron /ring /cedilla /germandbls /ae /oe /oslash /AE /OE /Oslash
+/suppress /exclam /quotedblright /numbersign /sterling /percent
+/ampersand /quoteright /parenleft /parenright /asterisk /plus /comma
+/hyphen /period /slash /zero /one /two /three /four /five /six /seven
+/eight /nine /colon /semicolon /exclamdown /equal /questiondown /question
+/at /A /B /C /D /E /F /G /H /I /J /K /L /M /N /O /P /Q /R /S /T /U /V /W
+/X /Y /Z /bracketleft /quotedblleft /bracketright /circumflex /dotaccent
+/quoteleft /a /b /c /d /e /f /g /h /i /j /k /l /m /n /o /p /q /r /s /t /u
+/v /w /x /y /z /endash /emdash /hungarumlaut /tilde /dieresis /suppress
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /space
+/Gamma /Delta /Theta /Lambda /Xi /Pi /Sigma /Upsilon /Phi /Psi /.notdef
+/.notdef /Omega /ff /fi /fl /ffi /ffl /dotlessi /dotlessj /grave /acute
+/caron /breve /macron /ring /cedilla /germandbls /ae /oe /oslash /AE
+/OE /Oslash /suppress /dieresis /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
+] def
+
+%%EndProcSet
+%%BeginProcSet: texps.pro
+%!
+TeXDict begin/rf{findfont dup length 1 add dict begin{1 index/FID ne 2
+index/UniqueID ne and{def}{pop pop}ifelse}forall[1 index 0 6 -1 roll
+exec 0 exch 5 -1 roll VResolution Resolution div mul neg 0 0]FontType 0
+ne{/Metrics exch def dict begin Encoding{exch dup type/integertype ne{
+pop pop 1 sub dup 0 le{pop}{[}ifelse}{FontMatrix 0 get div Metrics 0 get
+div def}ifelse}forall Metrics/Metrics currentdict end def}{{1 index type
+/nametype eq{exit}if exch pop}loop}ifelse[2 index currentdict end
+definefont 3 -1 roll makefont/setfont cvx]cvx def}def/ObliqueSlant{dup
+sin S cos div neg}B/SlantFont{4 index mul add}def/ExtendFont{3 -1 roll
+mul exch}def/ReEncodeFont{CharStrings rcheck{/Encoding false def dup[
+exch{dup CharStrings exch known not{pop/.notdef/Encoding true def}if}
+forall Encoding{]exch pop}{cleartomark}ifelse}if/Encoding exch def}def
+end
+
+%%EndProcSet
+%%BeginProcSet: special.pro
+%!
+TeXDict begin/SDict 200 dict N SDict begin/@SpecialDefaults{/hs 612 N
+/vs 792 N/ho 0 N/vo 0 N/hsc 1 N/vsc 1 N/ang 0 N/CLIP 0 N/rwiSeen false N
+/rhiSeen false N/letter{}N/note{}N/a4{}N/legal{}N}B/@scaleunit 100 N
+/@hscale{@scaleunit div/hsc X}B/@vscale{@scaleunit div/vsc X}B/@hsize{
+/hs X/CLIP 1 N}B/@vsize{/vs X/CLIP 1 N}B/@clip{/CLIP 2 N}B/@hoffset{/ho
+X}B/@voffset{/vo X}B/@angle{/ang X}B/@rwi{10 div/rwi X/rwiSeen true N}B
+/@rhi{10 div/rhi X/rhiSeen true N}B/@llx{/llx X}B/@lly{/lly X}B/@urx{
+/urx X}B/@ury{/ury X}B/magscale true def end/@MacSetUp{userdict/md known
+{userdict/md get type/dicttype eq{userdict begin md length 10 add md
+maxlength ge{/md md dup length 20 add dict copy def}if end md begin
+/letter{}N/note{}N/legal{}N/od{txpose 1 0 mtx defaultmatrix dtransform S
+atan/pa X newpath clippath mark{transform{itransform moveto}}{transform{
+itransform lineto}}{6 -2 roll transform 6 -2 roll transform 6 -2 roll
+transform{itransform 6 2 roll itransform 6 2 roll itransform 6 2 roll
+curveto}}{{closepath}}pathforall newpath counttomark array astore/gc xdf
+pop ct 39 0 put 10 fz 0 fs 2 F/|______Courier fnt invertflag{PaintBlack}
+if}N/txpose{pxs pys scale ppr aload pop por{noflips{pop S neg S TR pop 1
+-1 scale}if xflip yflip and{pop S neg S TR 180 rotate 1 -1 scale ppr 3
+get ppr 1 get neg sub neg ppr 2 get ppr 0 get neg sub neg TR}if xflip
+yflip not and{pop S neg S TR pop 180 rotate ppr 3 get ppr 1 get neg sub
+neg 0 TR}if yflip xflip not and{ppr 1 get neg ppr 0 get neg TR}if}{
+noflips{TR pop pop 270 rotate 1 -1 scale}if xflip yflip and{TR pop pop
+90 rotate 1 -1 scale ppr 3 get ppr 1 get neg sub neg ppr 2 get ppr 0 get
+neg sub neg TR}if xflip yflip not and{TR pop pop 90 rotate ppr 3 get ppr
+1 get neg sub neg 0 TR}if yflip xflip not and{TR pop pop 270 rotate ppr
+2 get ppr 0 get neg sub neg 0 S TR}if}ifelse scaleby96{ppr aload pop 4
+-1 roll add 2 div 3 1 roll add 2 div 2 copy TR .96 dup scale neg S neg S
+TR}if}N/cp{pop pop showpage pm restore}N end}if}if}N/normalscale{
+Resolution 72 div VResolution 72 div neg scale magscale{DVImag dup scale
+}if 0 setgray}N/psfts{S 65781.76 div N}N/startTexFig{/psf$SavedState
+save N userdict maxlength dict begin/magscale true def normalscale
+currentpoint TR/psf$ury psfts/psf$urx psfts/psf$lly psfts/psf$llx psfts
+/psf$y psfts/psf$x psfts currentpoint/psf$cy X/psf$cx X/psf$sx psf$x
+psf$urx psf$llx sub div N/psf$sy psf$y psf$ury psf$lly sub div N psf$sx
+psf$sy scale psf$cx psf$sx div psf$llx sub psf$cy psf$sy div psf$ury sub
+TR/showpage{}N/erasepage{}N/setpagedevice{pop}N/copypage{}N/p 3 def
+@MacSetUp}N/doclip{psf$llx psf$lly psf$urx psf$ury currentpoint 6 2 roll
+newpath 4 copy 4 2 roll moveto 6 -1 roll S lineto S lineto S lineto
+closepath clip newpath moveto}N/endTexFig{end psf$SavedState restore}N
+/@beginspecial{SDict begin/SpecialSave save N gsave normalscale
+currentpoint TR @SpecialDefaults count/ocount X/dcount countdictstack N}
+N/@setspecial{CLIP 1 eq{newpath 0 0 moveto hs 0 rlineto 0 vs rlineto hs
+neg 0 rlineto closepath clip}if ho vo TR hsc vsc scale ang rotate
+rwiSeen{rwi urx llx sub div rhiSeen{rhi ury lly sub div}{dup}ifelse
+scale llx neg lly neg TR}{rhiSeen{rhi ury lly sub div dup scale llx neg
+lly neg TR}if}ifelse CLIP 2 eq{newpath llx lly moveto urx lly lineto urx
+ury lineto llx ury lineto closepath clip}if/showpage{}N/erasepage{}N
+/setpagedevice{pop}N/copypage{}N newpath}N/@endspecial{count ocount sub{
+pop}repeat countdictstack dcount sub{end}repeat grestore SpecialSave
+restore end}N/@defspecial{SDict begin}N/@fedspecial{end}B/li{lineto}B
+/rl{rlineto}B/rc{rcurveto}B/np{/SaveX currentpoint/SaveY X N 1
+setlinecap newpath}N/st{stroke SaveX SaveY moveto}N/fil{fill SaveX SaveY
+moveto}N/ellipse{/endangle X/startangle X/yrad X/xrad X/savematrix
+matrix currentmatrix N TR xrad yrad scale 0 0 1 startangle endangle arc
+savematrix setmatrix}N end
+
+%%EndProcSet
+%%BeginFont: CMSY10
+%!PS-AdobeFont-1.1: CMSY10 1.0
+%%CreationDate: 1991 Aug 15 07:20:57
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.0) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMSY10) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle -14.035 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMSY10 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-29 -960 1116 775}readonly def
+/UniqueID 5000820 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA052F09F9C8ADE9D907C058B87E9B6964
+7D53359E51216774A4EAA1E2B58EC3176BD1184A633B951372B4198D4E8C5EF4
+A213ACB58AA0A658908035BF2ED8531779838A960DFE2B27EA49C37156989C85
+E21B3ABF72E39A89232CD9F4237FC80C9E64E8425AA3BEF7DED60B122A52922A
+221A37D9A807DD01161779DDE7D31FF2B87F97C73D63EECDDA4C49501773468A
+27D1663E0B62F461F6E40A5D6676D1D12B51E641C1D4E8E2771864FC104F8CBF
+5B78EC1D88228725F1C453A678F58A7E1B7BD7CA700717D288EB8DA1F57C4F09
+0ABF1D42C5DDD0C384C7E22F8F8047BE1D4C1CC8E33368FB1AC82B4E96146730
+DE3302B2E6B819CB6AE455B1AF3187FFE8071AA57EF8A6616B9CB7941D44EC7A
+71A7BB3DF755178D7D2E4BB69859EFA4BBC30BD6BB1531133FD4D9438FF99F09
+4ECC068A324D75B5F696B8688EEB2F17E5ED34CCD6D047A4E3806D000C199D7C
+515DB70A8D4F6146FE068DC1E5DE8BC570317AAEA74A842CFD26F9591866F5A0
+9B4EAD7395F5196B36997F1D59E88165C94739E74C2B40820F8C972B175ED79D
+87C9E323C3CDD5C2BEE6409017767534E19F45AFCE2C6687733451AD2E75D112
+42040BADFF90F5FCF0664A86925B2373EE15AEB68587D23AC7EE88131789970A
+11432A3FBB405438649148B0B0E75C2AED436094072C165CA5793A530D958629
+6AF7F77D20E3FC353CE32CEBD29A65C0278687FB2DDFAB5D53CC6B38B0363B15
+F7D5A0670C60C2D906A8F6A920F9513CFC9C76895A98DF6A2C7241D4CFF6BA03
+038A8A598AFF9D6AD411D90F0701AB670A7D7F64B0B4FF61EBB3DB20E86A0E33
+8EEEEC45425364E0C724A1F05057FB7D6258D88358227C1F99BC6AF1354D31F3
+2AEF8A98A24DC18C1590C1627551D976EC61761119FEFD8AA68B8AA9C79E62DC
+CACEA3B1716241468C5F9970F7C43F38225599500C73C0ACCD597C53857275F3
+E47EAFC2182D9038A15B4444DAAEE4DFE0A0FAEBE133AB28548603067A23478D
+A0C5E93D89BA0C9CA9849A2E4EAFE84A92D8286390693C12F3DBF2D8A1C8F2E5
+0BFE934D55907AD10417A36E005688CE59E1FE0B0DAE3F55796D637692F7A7B2
+6E1DD10CA6E9764DD54B25C9F00B0319277635F98BBBB4B883487B4FB9E47EE8
+8D5C2EE9A24B30170BFAF38CAAB350214B2ACE
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMBX10
+%!PS-AdobeFont-1.1: CMBX10 1.00B
+%%CreationDate: 1992 Feb 19 19:54:06
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.00B) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMBX10) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Bold) readonly def
+/ItalicAngle 0 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMBX10 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-301 -250 1164 946}readonly def
+/UniqueID 5000768 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
+016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
+9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
+D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
+469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
+2BDBF16FBC7512FAA308A093FE5F00F963068B8B731A88D7740B0DDAED1B3F82
+7DB9DFB4372D3935C286E39EE7AC9FB6A9B5CE4D2FAE1BC0E55AE02BFC464378
+77B9F65C23E3BAB41EFAE344DDC9AB1B3CCBC0618290D83DC756F9D5BEFECB18
+2DB0E39997F264D408BD076F65A50E7E94C9C88D849AB2E92005CFA316ACCD91
+FF524AAD7262B10351C50EBAD08FB4CD55D2E369F6E836C82C591606E1E5C73F
+DE3FA3CAD272C67C6CBF43B66FE4B8677DAFEEA19288428D07FEB1F4001BAA68
+7AAD6DDBE432714E799CFA49D8A1A128F32E8B280524BC8041F1E64ECE4053C4
+9F0AEC699A75B827002E9F95826DB3F643338F858011008E338A899020962176
+CF66A62E3AEF046D91C88C87DEB03CE6CCDF4FB651990F0E86D17409F121773D
+6877DF0085DFB269A3C07AA6660419BD0F0EF3C53DA2318BA1860AB34E28BAC6
+E82DDB1C43E5203AC9DF9277098F2E42C0F7BD03C6D90B629DE97730245B8E8E
+8903B9225098079C55A37E4E59AE2A9E36B6349FA2C09BB1F5F4433E4EEFC75E
+3F9830EB085E7E6FBE2666AC5A398C2DF228062ACF9FCA5656390A15837C4A99
+EC3740D873CFEF2E248B44CA134693A782594DD0692B4DBF1F16C4CDECA692C4
+0E44FDBEF704101118BC53575BF22731E7F7717934AD715AC33B5D3679B784C9
+4046E6CD3C0AD80ED1F65626B14E33CFDA6EB2825DC444FA62096FE53B3181F1
+34B6A0FC125B7E8B4447C8A5E11A7F414CE043ABAA584B2F67DE3FE1325334CB
+63B98D4A88F8D5306D7EA98B62723EA709806FC982EDF78271ED4545B07C4617
+EFA1A50D7E2D02E904EB093B5745BDF79F8143589E6296BF025CBC11411F348C
+E687D0E97CF4FA509B30E1E82D6E03DA737F760525DAC028AD08B70B6F14750E
+FC9EE46958A6FE7EC484B84DD4DDD8BF2C4162E29745A69E7717731DC3556B48
+BF53EDCE1499F3925DACEC43096E1743E2EC204EA0883B4272A2E6FFFE12A187
+49602C5F4EFEC4C0CBE41CAE0129E9F3CB9D1D32F10FC1198E32511F945E1172
+87AD86E517267E421D345D782334244B767EB7651FF0B70681E8AFCB58655A8E
+02FA0753A44EC9E581AE3691C027FB01BEDE9F738284B246BE4FA7493A92539F
+FE7664A8A8D9BF3903299A0C81E94A8380D89096E480D7B112A801A369534D3C
+3A0CC1CFCF4A01F9BEFA8EB263C089CE1074CC656155ED2C2E95398C0BE9BC7D
+C784E4ACBC3A4A0B6E6454DD3107E2BFDFA2EBC7A3E2A78C8927F24C016C102C
+FA346BF944CBBB0E7BABC0413F678204811AFB3C15558E4D43487B1168A0DDB6
+E2FC07E0D8500CE89652BE97077A2A8A987829B9A2644D426C007E5681DD3E54
+B888E4F1B7FB089DA26F38BC76823F5B4A040224BB155265E2EA7402BF17ECD7
+1219A16E5A1B12C66F3D1EEFE8ABB3D2BCA2CD5BA3CD63BF413466BFBEF9F07E
+996E67B1730C0D64D471BDD24DCEA030ACFCCC11C2BF0B27F6E7217D171A060F
+B78883EE20ADA450A38CAA7AFFE06A2759DA45FE05D46494A56D2E858A48FDBE
+B9631719EEA0FF356A43DA020CE5894DB7F72B251ED0AF48B62E66CC518AE40E
+C33AF485700B0A14F56ED1959BD60C7F7F5BFAF8497205D4BD5B2D21D1192D11
+0D083804EDAB0BDB4E39C6C5BE8EDCC80422A4362A89E46F7DC91B557A4C8683
+B529559CFA052ADB2122FB8822F3A8CF410007FE6521EFADF967A50CB3CDD405
+00DD3014D53E32719381936CB0758C1887C8317DDCF3E6A1999B444C14629A22
+823CB41CAD32FD53A6555535E9545B5C86A61A82876DEE62CC25EB6D704D816D
+0514181EEF76889F27EA5A3279621BB1B3E49E42E7B668D99299AAFC1A4965F0
+5C134B5DB88ACC9B262909DF0EE3ED7932BDD397597BACD324326E6945E5C127
+E9B03929E29CF2347AA6E812206EC7409A8676469E4D94CAEFECD0EA62D9FCAE
+BEEEBAB8F4A24AC76FEF40ED96B13D7A2879BDFB1FD63F95A63EC16D3930F6D6
+D553AD1E92E74BB357B511CF154C55ABEEF06E686815609452E5A8CB95CE253D
+43CE484A4988A8A48CFBF90D27163BD04BC9F480217C70DB0EA37529FBA4C99D
+0B4FF001F37BC1F735BAA21685DE134355E7A6E4B363B1ACB7E71B0855175B24
+9C8073BC88ABF4CDE24D025DA0C8BB5147344A9A6E0B02970241621860607A37
+CF58BC30E9159CCAAC907BCD692EF5D772EFE7927390F9B3700F5EBB389043C2
+0EAA26BE0889B262031CF03C37209CF0B591F48838500860402516C52B99B194
+5BD3D507F3D13A466443F30FA7DD0303F2197C794E9FBD18A2F97B9ED4FC8CFF
+C3938A750CE4B0AC4AFAEC3E976DD67A59BA718D29B089285E287B991CA481EC
+C04C9D6309225089F5A274C335F93D504826214B99F2EFE21DC5A03DA8B9F62D
+1DCD2FFB6F329BFF77533F9D15B1F50BE8B757E984C2DE4327720F4FFE8BB182
+D1C9BC5CBD65B6BE8DA278525C89B09BAAD3ED29E40D37DA32CF38F2569E6F1E
+F4ED062EE09D2222CEDBB8617F699801658433BD80ACEAD928459F397F870BE7
+05CC84DCEB5861B59D97EEF78C5F5B8DCAC8312ECA4DC76B008BA3F20F8B898C
+AE33E4CDF9DE78187E438BBD802C858C5BF5379915AFB7817834B69A2018D16A
+613ADCE996CA070B928BB08A903517837037ED32F085CFE6A20D7E76548FDF08
+7FD215D2B0ECB844D8A5D8102ACCE6603510FF14D40D6C4ABE124891A0376C95
+CA02341979EBC5629242ED728FE5E45EEEE46DED330460B0B34D664531A4CFF9
+C33E90D8C52043E38309B116EB71799267AC54FBC40FAF8596220406F09F45E2
+683781F048DFF08C6FADAB88A5F0C09CFC15904BEFED47BAA11E0EB382B4B8E6
+0E5A7A438F00D54727FAE1C73942135E42BC6A30EDB504D719AEAF78F2D03483
+A692A37A7BBEC502E9B8F4B328E1599CC501908CED367859F5E6C25464A61E91
+F2D2FA122AE6B2E096CD407D9C02FCA07429DD17E627ECBA06E1CE4572F68655
+C366D6EF957DD30BE76E5E8AD287655F275E9C8B590E21ADB0284D785E0AF8EC
+CBB4B47163945B28336E8F9C39D0FD49861E1DBB1746040CBCFD9C4548C000C7
+5DDB3A316060906187C82393175AC6775E1F5DB9E87D84494F679AB461B62B04
+1344F533A4808061050D86FC2BEAE4AD95244B29BF7F21CB632B266A40264C32
+71CB7734A07EDA9FC81B0DBFEDC75446E33B2291BF18FB3BFE8E6B2807232830
+757D1133AA715A16D89B663F7E68DDE14DB12875F0CEF9B25B33DCCCD31DC1A9
+EAAE5E4C68A13D4F7CE1400C287B09F7EFA0A61463F18D8B8C72C4DD63F69678
+4822A724E6F888B0BB9E1F9641B8C9AE666B3276000C80F2CFF21F07DBED7137
+48B89382ACE611BFBED7957098F9A8AA6D6F3FA1E6E0B18AF451B47D803ED05C
+18C8E136004095FA0A92A592D19C10D6936C0C553F93D3C0A446CDF0216BA15C
+3ABB4FCE6B3C33AD5FEA4427E9DA173C609C0515F899EB6EA85912E7A1E16146
+EC6CE1459E60311A7256A332F6ED3CF79BBD2FEFCC9FDCFA429DADC6D38296CB
+722E002690E552D94E55F004525EEBE25832267B06BE01D6E6A17612C1F5907A
+AEB53F7FA639D3B684B525041C0B9053278781F73257C260394BF5613DA9BF75
+7B66A9CD47DF3A4565B6502A4BC5DE8BCA232D1AC4B8A2624A4B7B6F1F20AC4C
+63AEDFA5AC0FE820EAFF6B07E364DBD1D8A381BC45B86F45ED9B8DDB64A3E4BF
+E23BEA9F78F8633A990E3C5D1412FA57F7CF86FD53040E1B04E01D2F3248005D
+3418535790DEBF01D9D615AA36B63BB5EE55C4AA6A72F91891E43E725941EFF1
+FFEAB40857EBD63CB6B16C14E493F98DAA67EB4AFF513BB41824B1470DF3226D
+19811AD733399FAD62D01507AFB711544D7B4DFD85ED1DF89E9B285F17E4EFE1
+7CAAC913B0D09BD2E0064E3CB8896552781E2E8155318FAC626066E990B3F801
+FBD9657B5A5D12010B616AABF312AA34456DB3D23A79BB223C15A6AB70724AA2
+BAB9E1295E57D4D0204E21079D140973F698182D5C3F143C1D034E68FCF85FDF
+9037D33D6906BD45D3233A07E33C50416C0528A6614B057B56F3EF67E124E4AA
+1FA81D5B9373310CAAA37B498D5937BC23B3E4FE693D9B002EF6233FD03C217A
+23836B41A23CA79D979727F48E610C8168C304188C85AE37FE874DA722D37860
+2A0CDA11CA4C1B78F1790CAF1C079576FEDF5E389EF163B55D2AE7F4DCEDF576
+0F6845D20D4755F79CB72EF277BFBF72E56B4AA09886613F2A62CEA5BA12C54E
+C729D1AC8187FBE2ECCBA7289E32DCB07019A8824A275DC7D56C177EDB932D72
+AE1EDE6D955A2D890E2400CF7392E4EA3A2D887483DED232A9C49BF60C463075
+7EA0E456A19C6CC779E5844D05D89FBADB0A1A8BA93E22ABC6691758A699A8D3
+6587A094D2FA7DDB4D8C0D74207A49334C7E874E2AF12C0C5ECC57594FC749B3
+6DF6CDB7E2E0F614738057E2502CBA9BBB7D8DC3995292E61F5794E969E1FC98
+3027B1D1ECB85F130EF5BE2DA25A8694DD47DAB9995BBEFC15519F5A613FA7FC
+BF37C9B4282B3788047F81680EB3C0844AEDFECC7F3A0F11E479C9D23E0AFC99
+87E551C0E78CEFCE891DDA32CC36097713D569D093DD9A8A07730B9418B36E44
+C12F32BFD3598850CE63115A5EBB83E4728E750C3FD5500091B46B4249154524
+297A7FF414939ED07F883C5AE3E13C3F10B8708B2CB23144025378CC74D4DD01
+5363CCCBC6FC008E8D8B7F52BF4E7F0C10A30E1C40C4B5DB1D716B046EB1B996
+B894989F6EE09AD3B46B46207F1C0A9EB021C82D17C8B19D38855CBB314ADFAB
+E955C3CE24F56207783D05F2858BDEFB9380925DA7660FDC1947F720C2AE5B5F
+596C92F2B7E6F6CE45C744915455B0C5DC5D45BAA653B8417FE4D2A16C82D12A
+A1B3A8536CDF5A37198486E8ACF9F64C38A14CE3A7CA60411CA969DFADADF18F
+609E283D71A9870D36AAEA057029999DF5543A6FB3CB4AC810D22F5E741D6B27
+07E645767D30E5DAEE61C7B24C4CCE17EB8EBACBB1509F130E7617167D31069B
+66D878ED97C90C23E67DC7E1A011B7C2FFD8EA5061E1517FBCA3ADFB7925B8E0
+5A80B9C1FD248C2F8349072F819CB200D83BF66FCC4B43B4BEAB96AF0C9F5B41
+74D9FB3F5C4AA242371BC051DE5527545EB627F86A3E547D57E96DDE9894DC36
+B5D5D3C8AC4A68D269727A92CDC69BEB304549D24D0C6023BA69CDF7C3505E0B
+AAD7FB1EE32D9759F1FE4B338A57534FFD2F90BA2F0DFF2E4EA2A81A5F2BA17C
+80773A61383D9B50ECD98CBB921156E68A2D26ED335D2588235AD12F3D9F5147
+4D603D84C82816E88601FD3ECEFE4D8CABC0555C5ACA59BC00B9B3301CA99EEC
+F9376B99B5F94790718F3D73BBE55D9CB22CCC846B926FCE493A7943188C46FF
+E2C3F0D89CC0607BFA553E413094BD2FD08FA54529D346FB77A1206535B22C5E
+2D2654CEB44E75EDC809BA403E09D512832CAA3EDB0BE65DF67BD2ABC1199C17
+290C10BCAD12C1A99C041ED0EC8F02ABEFA3E0BF58118D9B8D7D73D47BBDDB9B
+1C46E86F8E8437FFE4415E440A9828B1EBC2CB626DFBC9FE9943E01773830252
+6138144D0AFC7DA62E0A50BFAE27E5617CFD45E58893ECFEABD49FBCE09FDD81
+B22B0B9A4BBBE4D2740036CB577C95B23A10CECBDB04F490A1C15E87546F5BC0
+E816C6C59AB607A45A5DF306BD0C9079FAB04294D02391602F32BB161C09E340
+93FED799EC4399049317B931AACDC2189DF78FF767554C590B569CD8C078AE92
+9ACD26EB5B099C3ED9A7
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMR10
+%!PS-AdobeFont-1.1: CMR10 1.00B
+%%CreationDate: 1992 Feb 19 19:54:52
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.00B) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMR10) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle 0 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMR10 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-251 -250 1009 969}readonly def
+/UniqueID 5000793 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
+016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
+9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
+D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
+469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
+2BDBF16FBC7512FAA308A093FE5CF7158F1163BC1F3352E22A1452E73FECA8A4
+87100FB1FFC4C8AF409B2067537220E605DA0852CA49839E1386AF9D7A1A455F
+D1F017CE45884D76EF2CB9BC5821FD25365DDEA6E45F332B5F68A44AD8A530F0
+92A36FAC8D27F9087AFEEA2096F839A2BC4B937F24E080EF7C0F9374A18D565C
+295A05210DB96A23175AC59A9BD0147A310EF49C551A417E0A22703F94FF7B75
+409A5D417DA6730A69E310FA6A4229FC7E4F620B0FC4C63C50E99E179EB51E4C
+4BC45217722F1E8E40F1E1428E792EAFE05C5A50D38C52114DFCD24D54027CBF
+2512DD116F0463DE4052A7AD53B641A27E81E481947884CE35661B49153FA19E
+0A2A860C7B61558671303DE6AE06A80E4E450E17067676E6BBB42A9A24ACBC3E
+B0CA7B7A3BFEA84FED39CCFB6D545BB2BCC49E5E16976407AB9D94556CD4F008
+24EF579B6800B6DC3AAF840B3FC6822872368E3B4274DD06CA36AF8F6346C11B
+43C772CC242F3B212C4BD7018D71A1A74C9A94ED0093A5FB6557F4E0751047AF
+D72098ECA301B8AE68110F983796E581F106144951DF5B750432A230FDA3B575
+5A38B5E7972AABC12306A01A99FCF8189D71B8DBF49550BAEA9CF1B97CBFC7CC
+96498ECC938B1A1710B670657DE923A659DB8757147B140A48067328E7E3F9C3
+7D1888B284904301450CE0BC15EEEA00E48CCD6388F3FC3BEFD8D9C400015B65
+0F2F536D035626B1FF0A69D732C7A1836D635C30C06BED4327737029E5BA5830
+B9E88A4024C3326AD2F34F47B54739B48825AD6699F7D117EA4C4AEC4440BF6D
+AA0099DEFD326235965C63647921828BF269ECC87A2B1C8CAD6C78B6E561B007
+97BE2BC7CA32B4534075F6491BE959D1F635463E71679E527F4F456F774B2AF8
+FEF3D8C63B2F8B99FE0F73BA44B3CF15A613471EA3C7A1CD783D3EB41F4ACEE5
+20759B6A4C4466E2D80EF7C7866BAD06E2A1040FAF2DE1FD6AFD5FD97EAAB614
+956897A7BC784E9865B00EE8B49B918E886049F1F4939403EADAB83A4D8C332E
+2221AF8F6F4A4954501CB6A6268AC96F7091245F034BD65542DF47BC7BBAD667
+1EE6AF9187E298CB7AABA58E3FB5B4C7E86616C1A830A4A937C265CC28A83EED
+8F3C971D6DF5A50A615B713F5332E0CF05C754FD76916FECE4DB2807334C34E1
+E2418FFF1B4429A564AB857F1E23337C75E729645AEBE7F8967630A40E00F8C1
+3054F2BE2768682E50D0B43E3CE3897D9EE7257E77F9894CD4395C21585D16F8
+AEFE05217ED4F78C31FD635A00CE5D0DFC7B0A6BF9444B62C836087731D6D205
+24A45B3C8D80983A67377EBBEE171DE0B4A21368F9B83AF7CB286D8389785E93
+B11277C65D4D789AF99B1D7A3032947A51DFABA0DA3B94D8D4205BE243264127
+474D97F3572385018D62ED4B1A399B8E4AED8D7C329F109DBE3015A727DD70ED
+6DE4DB36BF48205C8CE0EC0A77491A26F93F7C0A036827625F115786A2ACF14D
+47E1891482164569F2F4629141CF756FAC27DACC81D3B0B0BBD8182A143E8245
+F2237340C9B13CB0AD872F693579FC079DA75B0DA63717FF25B09D18730914D5
+0D391A89E62429C64A27B4F8AFF96238AE378D90D6879BA5298871BF198C4EDB
+C5032F72E061762B22C9602799936D39D96375E22468D36D849FB67E41960B02
+276D5847EA6029CDB9E7F082A06010BBC1A15D62C9C752987E3442482844DA9A
+790D5CEEFF5C6D1DA27576073A4C7A0B4FB4F4AD9F9137E069386DFB3D814498
+8E31FCA3C13050FCBB42985EB32492161E32021DA6641D0EA06490B6B6F742B9
+B00B0D294FF019492B516AFEB3DE899606BA1FC553D4A4C7C5DA82B45677B81E
+40853399E33350DCF60CD324D23BC813AADF797F6356643CD391BA5E7D008741
+7C148FC1D89321784CF922F0C3E220C76A1AADA03AD75C807E736FC6CB0A287B
+C76BCE4B28EAD0C83459ED6ED2861A112AD0C33F8D0B29F48A06675EFA3052DF
+AC06AE408F93478F6E480DCD7D967909FAE2B8B3497B84B5A71DD8B1D990546F
+5236CD04734CD8A6AB9A0DB67B0F3DD5A0D280ED60F51A1B4A3BAB0766BE79A4
+90A466A8F06759A1C61265C33E7D9402419FC8772045317508BA1C185967E666
+F6C08929F13160B86251646C72C2CA97BEF4ABF1EE2C8158265F7579AEF49A3D
+4F2381DB96115BC1104A957DAD1B45D37BA2D6B0BFA5981CDC11FF8C34589781
+31E47F691F9E8A3367585E7C86D7C69616B5AB5AA96647E2215DD373B92D7232
+BE2FC3843093B06D0B80CED64AD6F37B002D720A8E6A49F3385837A4BBD055A4
+CF0589310301A6911651104AF42DF64FB16F76AB240AB3A935DA1DAC8F64348D
+C29B2CB6E71199BC3930E4348C9F38DDA0C5E5A2EF04DEDC1E3E5836349546C2
+97C3DC2CABE59E66B05A356572149DD2BC4606E23859DEE5B22D6B6BB85AED82
+C40B57D1DD10BEB9C075956210263DBBC8AE1D49305A42E02BE44FD203C10D59
+8937DE19421B5BD1D8D3DFD033FC93F0ADE94EA7417B731B52A5B5F387E70E30
+1815E661AF2D67BA476E122EC365EBF2535D86C4D6ABEE6720398F121B53F8F2
+14D51F899239E748AE77AE70B35014EAE4EA0E8CE0C40FF0C09510A5F476B4C8
+BBE13720EDCFA380820564BE959ED060DED34D5FA31B0B0DD6AF294ACA359280
+CC8F1CFAEECEF4B3F7F381E4C7972E7AECBA338AA6ADEC3836DADA122BA6940F
+F033D2C52E4DD50B126097AB7E644A63E6761175A03E7F12D889FB0A62723E83
+F82276EF53F0990B741E60A2A229527CBF24824A2B2DD8601456E6415443BDEA
+5A493E8BD5BA918E6A06D792641164B8742F07CC7C1A3705473CA1014C2B4507
+0641800DF6323C944C5309016A1185FFBE9F3F5594C50A1D0FC685C7AA33FAEB
+292A93E99DC59EB46C7C8989A0915A8653CFCBB762F2676474401B245F2D3C2A
+E0E4EB2FABF7D6D470BFE42B0F0CCA0B4AC1BE714D0D05BFC69CED32404D442D
+E3818CBCF636C55107DABC19E3B53C4E6435A82FA156CFBE7E373A3A4EB05672
+246CA4A5E42305B4102CC4FF6DCE7169B9CCDB9B3F498B01BDC068D043340D88
+A1E2FC6A06B95726B02AD39558EAA145DA64984C1F73B1D6EC78D83A6E497DA7
+31E87ABC3879E55DD81100EC6346907F9AACE1B14042C7791228F74761ED1F97
+298F4024D41DA1D1DE52BD98E23494A3B2B078E57B20BAEABC08493DD19CF2D1
+6EBC08684457E3134DDAB56760834A9806B95FA7692D6512B21EB08C0765DE4F
+83E543E55E965F3EBEE44D6AD691E4CDCBDDB0831666E5465142D534964A4F55
+D8B87A43236F46B5B4503FAD37DC2B80CE9087BE9F0B5A8D2D53F91EA7688F42
+75BE6DA52C0CF0B1FD80F9876F2BFC521378F02BC03DDC0472784E8255AF951A
+EC127548117ACD2805EB4E05B08129EA22464C3B2B44513E334BCB2379422633
+7F474D2F7D138D1F622C7146F60C6AB9489D5EBAC4F1056325B6C968A8FD0717
+23BFB225DBFCC41E0A33C6321CF69F06268FA9B320DEDC2F0A018DF9C8727144
+00DA64BC6EB9BDD4903505D62D3197233BB214DDD040DBB699EB61321EB84AB8
+36F73402DBC998E1E2E34060D25CBF43087586B3D8980948802D65201F3DF898
+BA7706668E114E9FB3EC78803A82F90AB54C297F1AC5F4D49832A7671F33E5F9
+E9102A8139945DC1DF1E9AD7D9A5877BCBEE964D2CF7E01D6E3E09ACE2EDD86E
+F504BD79689D38B64DC1566EA5A8F8B55465AFF32099017B62933FC101FEBF75
+274A7C56E429FFA6C95EA1F5BB55C610A53B251D8DBAA131E5FC409239502020
+E6807A3C282BB05D4B0AE10C8F2F31667DC9F4AFAF0481FF12E5C88C16A65092
+526C769F4A58E5B7079B4AA8BBC77124B14EDFD1A3B69A36A9B952F1F750383E
+DDAC76A243B408B6CFEE872D12617F4FCAC53FBA3D6134A58C093E0825043ECD
+4D6B32A5B7D987022EAA210985FF76E50955AAC91F07B8B44EF73E19F8A64AB2
+D00F1ABA3CD21A20095F6D19B68DB0E15400C0357AD57987CF7E4CB48E1AF292
+98C188A4BCF09189DE3E0FA43FC6A943DE24A5E3E4FDF81AC9D9FC96B4A07225
+0565F47B38A66BEDCA93728CB4E63D8C0F5A5B3E99594A1C79FDAFC2A9284B91
+A879B470A9A2D9059362F0A874BF15DFBDE8545432BA9E3C68CA9F3CC5A54D29
+1976755090120A4EAB6958C25B6847F09EBB6600BD0F66602303B863317489D0
+282FF553648702761805B1EA77553D6470972BA7EC507AD5D05B983A6C21071E
+A8C49311F5723472CFC0B9023ADCD80683A5A146179597A66D204517ADD33BA4
+CB2B971A3ADBED72231B5521B56E319A118F052EAA5383E59741392648F0BA53
+786EA7F9A0DF5303D80105083A0A06C93B8F4EDB37CD76E7AC047980094A73E2
+1E703987733CBFC00F42C68F77CB8885648D349469D6994D14028C84B9834F8A
+6145ECFBED055F6E0B4DB135866110575C0D462E81309DC5D88957628FC80C94
+C4F920A55C6390D1C3411B6800260C48BB6C4B2AD14632B6E870BEE9D29D86B2
+2693864ED03AE2F5F00D0686870BA67F3A485D75452AAB529061CCE2CA774036
+2F7D47166BDBA32B095933FDAA04F9CCA58E8D02E0587F60C5AC90BB69CE1E8E
+37AE561D17659B45FBD8FFADD45E4D3FB70185FEA6488B887413A311C42DB389
+9A0ABF35082D7B885A76C52B010CED98EAB8F977929B2604FFEF32887FD6DAB2
+D18A699B6F7D927C121399D0EB08ABF413BCB176B4753DE46B27E4D688E9C29E
+9DF3CD432CED51A2E6359DC442EAD0D3252D1484B6652CFB833CD0338A0F5ACC
+E14C2601CD42EFD84AAE50FDC5AB104C8353B0A68A9D3C62FA79A3153FA8C7AA
+43090497331A824BE1AB1C54D47F3E51A37F6975E299E393B3B795F5A1D6AD4B
+1DEB56661BD3AF3E81BD5F3E62F357350E5B1496DB33BA5231CBB8996C8A1559
+250478BAA94395AE3A9EEBA7E68A3E8D957EED47212121180123858D3823E838
+39C7FFE9C684E2A73E75DE97D20975D743CE708A8B607BDCB6E502A5240D2092
+9606D6CEC1E6C93F386089262D13B0B3C71A3D7107962F366E6221FCE957F0F0
+FA4E8506216D50C564196C2EB3675AA0D9BEB360C92E1D37D9E245BDED07FDDE
+D209208B11EED2EF02C93BF10E0F2D66B7B4EA49C182983F9A93C6742A2A0D27
+B401F3A7E4D5BBFBDF9D82C76D1A388FCDBDCB7CC11C834F9027A7EFC9137496
+44988602B18FF6F8B3ECC2A3C5B6523A9166BAB8CD11A92A4282C6D93C99D559
+4801644C178B105164AD7425BB04297578D2CF47E254DFEB0C5969B0365363D7
+7BDCD7EECA2A9ABFAA64E92483BFF34A4AA395384FAD28DBEBF146AEDA2F19B2
+FA7BE6A34412C50C1AB6AF28428C1C422CE8B4F99DA87BF5E8E1FCF38E33D9CC
+67734B805AF52C37E78D4F72F6226EB4C63D7765A0F558924D78231FA88A1860
+DFAAF112EF0D91A4290DC69D879B3A6859E7FFF74376F37C77C606979EC9A304
+8E8FB93355BB176875491B864D547B3F44B908385097BA1C0CF9A26FA75C1234
+B93332C793D0993F44613104A5C41C6BDBF7C92C813CEB3DFA1B33E1E80C08E0
+5863B0095796E39ED0A11F61034CC8FDF3A18E228D2C43E114128360F888DA4A
+015FA44998841F2F445E4BB88FF9056911DF3EBC6745CB8E28CB1B4468F05D44
+544232827A220528CDF64720AED307947680176ADB7AAE9A7DFA29F8EB03324E
+194D45D9C457C9199228DDBCCDDE56D8BAC6F42B5A86BBED53F775477DD6B219
+CED71BB21641C9C2AA8EDA5CFCAA9EF3B18766D2C070214FB63E34481C6ECBC7
+0856B339C73BF6530BA18CF75C858AA6693129A060406E1A296CDF0E1FF96E40
+1716649B6873AFDB6E6B10CC63BB6B516C861B0B561A06E5BB0739736A485AF2
+03D387208518904D7FDE1E655F2356BA7FF711890A63C1D42DED4871D71F9A30
+848B26D2B120FD8173B65E7F0E0F4D1D953BA33E290AFB1E538ADA896BED27EA
+837EB68EC02FE19330FF28A564B9060CC92AC6CA691E95BCC0EEAA1D074F884B
+BAEC5841B166E5809CF82E34C8B005AF5BCD797FF4F7616BF184E516197775EA
+0858F708BF20721E965005825D6195F064C3BEE9CA3B7468456AF84A692F55F0
+934F3D07B8493B274A5C82B8DBF9E895381108B657D1D15761C18E83A295D519
+4D4E485E01808371531ED457A74D5BE41F3C60AFE7196BB427DB2F5699F54527
+5D179C080736EC9EB48785F4D2D64BBCF8568AA5F53C5B74C021D4FB275C7B24
+4AD4A0AA85D519929FBE5786211A301C47802FC7E19774133C56A67EA9339FA9
+A6AE3C1EEB754C8707BD4FE9FF20C4962087691976081D36292A3129FA306644
+DB4C2B2F61844A334A91BF4828236F882C8ECC4547B2D7339BC235BEAF3A54D5
+9BBC8A4332815C07144F65A90028FAF989D2A0F2E1B9623DCC81F92D01C48C99
+CA9875D1D207109BF58FA2B89966BECDD4D2BDBCB5E68232BCBBE0279B5C4532
+D848BF0FEA357C8F40347C4F4AA09B57068B91558D56412506A20C19EF1C4644
+184C41724005C26E996C28E8F523F68AE3A23C1C64533720CC76D156E1AF6D5F
+40BF943C477E517CEA819AC85CB88D6759E90884555E792347926E11E7059C11
+35A2C6BFD556FC3F87CE8DF2A5480B00A911C9C02D8B6573947AADCF35D65706
+2434D209BB975AD433A342CD072451978DC3CD6CCDC387A9E7605C1BEA0847DD
+5D9DB8EC8F3B330F1AE84FCECDAD88A771F9399A1B13B23F9EB220D789D2FD61
+009ABF8F4FAD8CE5A9F4A661ED4BE42E65E62E1F09D3020925B6917C00CE2D03
+F05E096B68F2D9A0E0A511130F018CCE7C7E1A3C82A6F903C1E03AE83E73FE8D
+AD9C1B07C3810F3A9E94AE3BDD2316A9963A4D8603B9862C23F5064F9DD7BC1A
+C0E456FA5E823CC26DCE46D756CB2B00C928C356E0D280B21A2F4AC19A0674B8
+B6AAC04F8AC377C5D0512B90B6A3F4F369E11308398B391D40FC945E4E61E62B
+CBF80F4AFCCF93DC0BE5F9F2E68F272A1D18205F16019633F23CC5126411EEE4
+F4D88E5E81C38DD47404C4CE100850DDE45998A30D59D0497CF139C9ADD7324B
+CF36A7DC1BB2668E8C46E977DF4E2DB2076C909639D868782E6220A2C76EAEA6
+138EBB931B6B5D15E8E126B9956CD8B4633314FF30629DF05C22AF9464423406
+0B7A5B696D2267736C835C2A674D782E4B80C4C4A05E6C0B4FB844C377A2289C
+CA99D683841C7BB4915796259893EDD7544CFEDCE87FF240379E89AB6CE3C1DF
+7F0CB8CFCC399485BF57A6F4E9A04936907A4780E1446C8DE8AD2EDFF857DFFF
+15EE01C19C8D6E9AAE2CFF6062E9D822350747B697F0B623CB81F6D26B2359AD
+DAAC17D362DAC85B10DCF02AB04B09BBBD2CE915CA87CFE2E24770F7AE9671C4
+62278DEE7752E42A26A2034BA7C8AB30DAD08F88EA5CD5DC3A14B6A431888BEC
+AEAA5F8CD33846AC133A345FAB7198E4F8952F8DC6A19E484BD03B640F76366C
+AA3133E9DCBF8BC6C8480FEC078A408F77E1F0F869EE38F3DC2FD37D8D4A0D1C
+8233752569D822449C2B457C321A42791EFA9C6BCCAEF0508416ECBD63B161EB
+FF1F178EA3C69471E0F8BF4B6720902C374CE450969B853ABC0AA813BC18D1B3
+DF2893C3191B78CA793E15AF1831D7BDA5DCB8E448B2CB474E1F14BE2EB2AC39
+FDED04BE18F0C61AE25A2E5AAE3EB06DF8089598242268A03F2ACC14757057B0
+B5C0139334B16EC0E3B1EA0199185A0908BA6192A2D4DF726B11B6A367BBEB93
+61E133AFEAA59FF38BFA66588B51583932B0E64CE635D8461D2B7A7AA5EF0D5B
+41ED2AD65959A55481DE935748DCB116F919418291354727A92DB4B51639BEEC
+0991C6D514CBC9343BD2FF4ACC8CF427DFB09D9166DA1AFCD6231451E521F17D
+AED6BE2A75B97138F5879F4BE866FAF5FA1C5856E11AE1732106651BD2DA6418
+C22273980D419591CE0177BA0553CA9B173E1AF11BDDB59301AEF2EC6A14B443
+8B587D1994B9431A8EE17BF52F8B81BD2430AF3126DA7C59E1F48B8FF434A2A0
+1541551F48C073D861EBDFC72663368FEB49414C5EFA4E1932DD50B118B7F9A3
+8286FD198D070D9E14129B44539BA40F343AE542C19EF8715B146A9908156A5E
+03632B569AD1ED53E596EB041A9B27417EDF8C710C25FA642B1A1E1D355700A9
+501185BA7F2F147975E6D86B89D0D77C0984FB3AB5779925A32AD2C9EC0FF970
+DFADB511D247B53D0038CCF6256809DFD76CCC242276B0B58A5421C3FB9D87E6
+7237D7FA6DCF0B1FD82AEA82D57FA9BBB4A04FE5305FF829C26982A1B40C2E7A
+2377AA6A06DA4CD21F3D284AA43CC56A99E4EDBA3AA6B362B573D322DBB38B20
+7CCEE41D941C1883E94ACEB25730389DDB1A366B84234882B44C632BF3CAFF42
+5177C7EAE52E57ED8C0E43EF9CBC9272AD46D00C04B7930102523C1878FDF3E8
+D92D9F23029497B0F4F387E7F7909C1741B6458358A59DC8AF05161D8BD56C7A
+5261E4CBEF0B2F2FB32437AC7DDD0433E668721F98AFF3D178984DFDE8878CED
+6A41BF9C05586358BAEC8FE32FD6C631F02252C9810A120E59EC9C6A8A83E118
+90EC0A133EE94A210D382A2758C8D5225878DA8F091D02EE4F8E9B6AB36344F1
+5DDE845CE485F957195B6601F19570A5150AACDB4B71A852D0978DCFC00EB2C1
+CA1784FE889E1A936B4F4D2C05115AE0A4F0C934E71CA6650AA3525E083FEC4F
+61F704A0ABFC7BAF3D172C549250CF98307B2D5C872529CA25C803203EF1DEC7
+810515E0E877FF83BCA3DA113D1A88541D82A4187C01A47EFD19D4A86D30A4B1
+8A8420D813F801D1C24BDC06A89FD4924BA7BC75EEFD466F1218C17E051A9BE1
+B9718C4BA8F65AD5EF4B7BE8F94DC6F6531D015FEFCE5335C1BF0A60321C1076
+CC83534B2B9B0EC261E4112E5176ABE2F67585F77ACB026ACF68D84362AB6397
+8065C6418E026AC7CEC89B1132C00A3FD1C230D6A62B7F4308A8E723C753163E
+71949D38CBEC572A02696D14346AADD1E3272BB87DA7744678E5CA8DB297F652
+950B3F9458172388BB7AA741FCDBC88C240D003F45961BA3A65ECF8DCE93D19C
+0DE0269F34659895CDBAA21732DBA72937C99E075BEE93B83B34FDD792146D52
+4344A448FB3514AD25B20E6E3D5934429286E528AA753C0F9347FAC0A11498CC
+7406AD883A3D2A0055760ACA7D155B7E45B9FA8E02FDE969E393728D8C7B5961
+E7903C9097F5D7D471C4F61A2E4887601F1A6CF02BDCEDEC8F6A22421A3CB10F
+20BF5ECF61755712D9BCA88B123383F25932EEC8A61F56EED1C69673663DFDE4
+318481FFB98F211511528889A545BF0FC1493FC0E4A295B36103A91A25C79426
+23481577865247C0C9ACB1CCF33249A1967CCE23B41B8F43133D9D6DB7937D62
+3C3519DA3CB840413878788F8A86605197D050D4BBA4F906AA20E774AFCBBB66
+52C8B63E005D3332BC44727964ECD1C0DF6F127F6F31DD85C35EEB3188A85ED7
+5D493F31D11170CB90CE8082F30703186063D8E571E216696133E9CF0EAB89E3
+3E8BF06E94403A3CDBE4BDEADBD675393C16F9A675C169D2C2946058AD475453
+9206B08E9A7568B4B46AABC21E2C8CFB2E54870AC32F38A6F8D5FEFCD4939E1F
+8B01FC555A7AD6529EDB9BA779D44CA3F7BC50A6A1BF13AF879B54653A116DFF
+6C54738FA42DE56D885289165561776941FF58BB4C0104EA01311ADD8472B884
+5AC1B91782A362F879A5F096094053AE17A797DF5F37CAA09C9E73F6393BE719
+44DA8FCFA11B0FFACC7E927E5246BDD323E4D72925077F10C3F86259C21EA09E
+81AAD19F4E71AD4AB8E02270D91815A319AB05E1D2DA42357E4BBE4C4B2EBB95
+1A9BCAC36FC554834BDC49CADDCE9C7B6B866A5E585B1D8314052BBD15E4159A
+5D5C86FE082B09CA37797C423D7FD7476BC6CFF1FC9F67E684062806782AC1B1
+8B4572D845562AC402AC7FFB9CF5E9A48E9E2920D7E772DAD4155DB7562B091F
+2C3E273E1FC1A8470C114A86660C03CCCFC41F9163910E96BB1A6E68C606FD81
+F2BCF8D494CCAFF3272AE7DFA22691C893B60C69EFD5932FC712BD2036FC082F
+95AAB664240FBEF812A2BCFD9DB48449697F25184C515857EEF248483D7E263A
+E8D1A72284F02B89552390F03D1CE52B99BC806BC27554373D44EF51FE58FFFF
+01259033CA0A0CB20C3E03D424B85904F98159588D02D8E89670A8D8C5BC9F7E
+9DFBAAF9EB239E43DAD44F62249B3711AB029D3F2AAC1B1DE56F3241492A462B
+90FD30CDC80068B18E385814D76134AA9FE0F83DE60C463F4B2734760A3AA592
+E323C3414A11C972B30B1FA630591E257CF0D9184C35AFCBD08000870119E704
+D13E17F45B2E6BE7C4CF975526ABE1785D3623350D0474C15D9FF017E4906F86
+E770C32168925BD973E6E62BFB7C44A331AF5FFDA80DD6C6CEEA5E26FBFD072A
+D3B67A0F5C7AED50F3A85D8DA5D11A5AA542079C34C64F60CFE920F616C0F7B6
+45048B7CDD30C32256A3081FECFBE75B2ABDF00AD493DFC103D096F7F08E20D1
+E2F53AEE90478B8A5DF0D5E51E588E9CF03648E0C7D478735C8FDD652C999A6B
+3C7D95F858882321AA67DF00A50CBCF58F1887EE642F70F693B05A44AE65FA80
+7DD1CEA49F0AFC10E34868884E79D67FDFA0E09A0DC93ADB1C0DE79E35009424
+B78A598CC1976151393AE0E1147FD4F3B9846BA121F37D57ABE9A0DEFC97DBC3
+816905E43A82B53828E42FA9AFE19F914FC0652312AEADA73506778C96095240
+B574581DE35B4384ED11AC4CE8335AA68A8B5C61E4E901150A6D80F41275D86F
+C83453C739E6D6F21E9413FE686D6F3616E96F9C42B9B0B615DC03F2EB98EC4B
+8021667FE1A6165DCA775BCA6A1AF1F8EB9444B3A7D2A4AA778F05964D428A26
+FC9F4606066611E2C90B1FB2C17AE60003F5E583C369219E491A3F892FFE8E95
+EA4D595551241EFEFCB13816FE2ABF9B2A69BC63ECA4A430B4A12039BAF97FB9
+FE29B024EBD8E41A27BC54B0F80ED222735A1D8E9FC9FB27CAE52F6271617420
+3278A1B125890177E1963382DF5CAA4D7A3E67A239EB202D4C6B3521A7170144
+66CC1989B8CE353F700F0CFCF1A8899052D1587813DD2B5F1BE4DC92780C5752
+86A23FEAE35F7F57D74C9751B61CB4BE866805CA50B16EAB7D9BBFC18901C4F8
+F4310792FCF466369CB0E4DCF42795D21286D248D77D823BA1A1F67C24CCF955
+FC28106631E9B473B60E923140A18DDA4417C7FD64B3576E2AD7A6CACD2FEE7D
+61A1AA56563700E772669E9710E14F1EEC90C24874CE89DB1E729B04639ED440
+33A8EA987E9ACD2400203031DC9C48AB10AC09CCF5002FDF90C0A88A508CE5AB
+5656AAA7FAF4C4DC21CD575ED2F2B336377AA9C63EE795E08EDE0B04E6192619
+6BB8E20B47DE0BCCCD869C8FF15B850573ED565B81565C98D1419AAFE1B9D829
+D2E7EA2F05A17F9330B2A9D056352D6C1A3C5AD694C725F26629B1E1E04FE8E3
+90D415AD4F0B56D6EFD1E808D647E719A2D5CD108875C9241A79951CBD483208
+B1E3056A23D498BB93DCBC9541D177EB6B24B5C0541226B7681A367ADEB4375D
+9AC423A87802B5EE5B6D00005D14BDB6F489FC6E4974E6E589739561D75FB2C0
+0D6AA61932B63F36200315463CAFEDF5CB349659E5E10EC5C3D08C6455B1F8A6
+C7B4058C6758E226CE0B1D5C07141BABDCDAA7957EC332B957E93ABD051EAE70
+BDDB9AB92899C717B6A7C7D677E854BA760F922354C253FD71A4522F8AE97E62
+50343B7D95434EF34A7BB1518B826547E95B6D8C3E62765518D232B59E8A9150
+D126F9257BCFF5123DB1160340C1879270262B2CC91E30C00B99E92C313FE1FF
+2772F6D50AD1AA8B005A44946E4EDB66615C9B4DA82FC1E2B7DB9FAEF0912D51
+09B7DE474192D92B14BD7C56B496807C6444B02FACF98E04AAC0548BA407E4A7
+5912F569F1ABC182303F89F77FCC74FD25F7943A49808D3E0DB85C428148E024
+6CD287F1827EF7C4FE829EAF2D12C04FD47BB7758702076BCADE0FF764AC8AE4
+1E0C6BB9A70B49F634F12D43BEB6E9C690AFC16EDD597E0065BF6D77EC59B780
+EE97F8E07F69E77B7C7BF9DF4B695D8552B238CED407970A8A4EDA45EE913F1E
+8F3C9987D7B4B287790FCD81937CB176201BF15FFD9A2155A056FED470887116
+4169A7156B44B3A759AD6AC9F6AC914FD12D86D33E56541B4C2C13CEAD735E1D
+BF8017CDA7825C6852CFCEB2477AB7679E328B783EDC057A442F9B52F363423D
+DA18B2223E999E3CB369FDFCD625CE9F4CDECCDEA32D4F8C7AC1799B2D35A399
+FAA8CBDE161F8A874E06BF31EFA645CECAA99334787A43E16CDD0E733F691D1C
+EAFEFDD4B13FCBF2CA2103EFEA8F49AD2B18EA360E3A1C566AA531EC4BFEEC46
+D316D13A0EE9F31194DE41FE3FCAE5438016E4E6154BD7A3CB7EA65D39ACF483
+49D1747307865354077267FDE537D98AF708F1F584099C74853E574F455612A9
+7A3D3BB3054DA33AF560E9020CCAA343589846F036B80D413BECBC4D896FF18E
+416F9A3AA6AF59993EBF3F74EAD51B7E39D9FB3C4896B0DD3C023EA0D1C887E4
+59B45803866080E693AD3351109C14EF84439DE19E2DFE157CE31FAE2572F953
+2BA0E823A4965AB8C2B9DAA48C16A8CFBFB17688CDE1AC20F0BC06863F794E84
+F261D3B18615BF1E6FE0AC261F018F4A1C001756B0A83E484B27154AE4C5A9D4
+CDA21CA900A035CD60B5B657D377E3D7CBCD321121B243CF704F7370DC6FDDDE
+CCBBED24A3A959A6922CA89142CCD005E4B5664A81644ADEE52AA4A4C67E9D50
+464AAB49325AC1E45767EF4EA4750445F41BA23715FCC0A7E1514E3D860FDCEF
+49A94075998AB89F3967A2B39A22BC885DD0ADAAB5C1BC7314A0C24DB5F478C8
+DC733E33CAA5C0D4C4CC481E6FE63622809D68FFBE2E38B26A4C8445606F2F50
+0992AB9F76EDB46E7BBC3544F79D9645A7664117CD1C25D44802BC897CA33094
+8C25DCE814453FEA5B8037ECA2221180113C71154820508E61CA862B9EEA4C77
+45A72D58EA0197B824F713769CB9B7EC3BC18456B9C9F939EFCC83E0D91DC385
+8095E84A86C841FA95AE764EF57EB3C26358B8172DD9D0087E4A6E263AB97387
+C6B53F5244A926B8D226083790475A32366C54EE1111534B1C5CBFC8421E30B2
+7E29C3AF381DBAF920217664C40441451E613B5F2DA8359B621571D4EABB98B5
+C180D752AB94E2B7EEE4BE5167A501DEFC95ED2FFAC4FB1ECF85872F1FAC934F
+176713083E2F70390AEAF05836A855DEAADAEDAC104F9175ADB0A4F36671242D
+84243C26342D54AFD1777ACBD392F6EDBBCF199B9EE5BFF86C8BEDB4ABCD2612
+622817DA587D23E5E48CECF301AB9D6560FF00655BEF328E90202B5D48C7B4B7
+BDDF3FF09859C91BFB279C073C27B3B1BE9851DF41C80F03A406E45E8951A6AF
+10B6111804C173B32F6CF2CA070B3EE33E3C2D712440D16EA7CA39C7192F8DF1
+BA9B364925B06578E4F6A2881AC1E72E8D60BFBD25516599C08B20E85C9CCC71
+2059F1801D32829853CB76B493E0726B86A606ADFC35AB288B4B794E1FA8F30A
+A80AA4D3C81DF862462B572AAAB1313FFDAFB1F4611FE017E42892B40D6D3382
+ADE67FFC187880C1DA517DA8C9E62520729099F93E07FFF4A62EC2487444C029
+25D871D26139E22050EC8F42FA118CA312789681571043C25F9838787AFF1DA4
+2E5B778C14E008B395662AEDBB4C63A8A62A9F277D94E9658697C5D8B8122E21
+D6BB71FA3954608850E7A50F0EAD705A5D64A79E468A9CD2E164C5FCF94624EC
+C8FAE867FE0F1E17B6189084785ED27AF5399CBAFC1661B5DEBC796A5500C26E
+AC430727653E7BA521BE44DB587B167EA8A2C95CE0BF233EECF303FE843C2335
+5ECFA939C9D2FC1B87C751ABB75F57132C9521FEEBECE1345F795334B43E8309
+9502517290BA5F58B83C131C6BDD9CF10FD4F674BC9B644ECBA566517676072E
+D02603E3CD447D93E0F28EAE1FD7E3E7A890BB2B05155A583C7A9C226FE1AAA5
+690B32FAEDC47A86230E817237DFB8724CC3130093EF209A7DE202B023D81946
+D8AE90C1CFFE221B3F909B30ACA1ED5BD118EA48033D6D0004EE70F15038257A
+6F19CB6C393F1AD61BE50E8E338C4E0AD836DA1A13D11B74CA7326949A94C8B4
+387B830313EDD071C801D98EB224D2388D5C5DD63EB09897AEE299EA338117B1
+5CBB57CAEDB801F0140A92F32EDB824ADE27C81CCE4B4571D6097032D4FE4684
+88EDCFA11E854A339765A57EE66CC37ABD45BF2978EBCAE812B7459A557BB1B6
+9D13B8BD4D94632E29DE26AC4E781A4E8126C541D8E6E18606763C8D898273B0
+DFAAA8420702F1D82746143DBD6B7ADE7118D0488727A1CBFEC46C6D569BACF9
+4FCEC56084E386AF9AA66AEF182219A4904F792E7C86BBE2CFE6305B7BEB1F78
+D4525E86CDFF9FBEA831AF1E468D69A9833CE5012EDD7CB514E7AA507F54788E
+7D793A80F9B2C1FAB1B350B4130AEDC9D29F4AB5C0037D6A362BAF7844AE699B
+0B8FCAE7BCE64FAFCEB4157DC41C3D1C7A6DFA3F82BD3CF656DD0FBC63CF7824
+B4ADCAC2BD15B839DF0E72074675183828146CFA3144320609D07C927BCAC730
+2FCBB3636E57D4ACC83AC408F1D05F1F0D996CEEE226388F36BE799824764B93
+3B839CBBB8BAAB270EFEAD0B64F94FEF7B9FCDFD72AE3A7C80790AABDA10E4F7
+FE21B52A893F59D23A25D499024D756D23ED00B1865EAFE5BE6E0F045955E103
+DE74C906B9D3DED9828C3AA1A51BE71FFDC7B60E4ECC3B9D9542782754C35EEF
+940BEF9B5E5C8BF4C3DD9C2C70AFE46845B9A6E3285F964BBA42526E6D7A0661
+4A152DB7D009F5A7BD9EF3892F1F42CB6CD59A4C48C7C5E61F6E9E85D00533CA
+763CFCD4751F8AD4B85AE7F4879A0CE41EF02AB76C90A2CD21264012237B627A
+C0ACDFEEE2D0B541D80A97B1AB452CE6A9305B688A4A197173810F03E6546C67
+F00F0B6C5EBDBDACA1E947BD12A34B991A434CCF46F9B8ABA5D3C743F1E79976
+B21DA1F4011C58FC0D6D57628C973E4406D8C95BC0876E8EAE3E05EF94E223F3
+4D6681DB6AEB112A962434073251579202C3BE80C8E843B7A672342FA60165FE
+29A14BD9934C25240AE53E636391460C4F3D9E5B7900A68BEF5EA6BC147531C8
+5007D5149278B0532869F55759B06107C3148BC8EB10ADE81841903C5E881022
+3D366380C3A430499E0406EB2F16DFA1946DB336E3DAB9D6DD7FD5E8BAB6FA2D
+060341DA4D5CCAE16D536B4D0859D88CD2B989C2C4612F8267E00CE02FFBF81D
+FC11B97610067A6EC513DD7B6130C17EC1AE90D44F0FD4C16C50C84B74FC7149
+1D6E2055614BA3F4F42FD05A6756BBC26FEC68E7C29E4F242F7152E30C4E981F
+A528F6AC3713D7C16592A4D531C040BD499ABB0C0B5AB4F49EA0B4D79C8F346F
+5042D8817A67903028EAAE5DFFA6185BE526EE0873DBA193BA8AF264F2C2F133
+FCE8729B486EB2A9941272C2ACCDBA45CEA7A57F42DE8EA3CAACDB5A4BF13338
+F67A9F47EA1F940B7573D75CCC9F06F120F269483438E5370B41072E4333AD80
+FC7C649FA2F2B40A69905612575D75F168953CC2606ECE45E295254F422A0F43
+EDFE3761EA6DE4F8AE05424854A57C943ED77368660B4CC8F6D1116832CA0220
+4616865189D718DF4F84BFCC6DFF7959FC759573D59167BD761B703D05610FAF
+18F96BF136986C5EB502DA2BD0DDDFF7E03B42EAF1688FA501606549451104BD
+EBA48AE261C9375D9D782060170029B43BFB0A949BB87A0E6BFE9F3E7047767B
+FAF753496EE3704511C7325FB4A3F6D62B913E37B7425C5743D19859F01A46E9
+48710CA8D437E92F4C5E35D2AB13006C2354319A54F027AF870163A156B1B62A
+D9272F1572F4B4C8CC0E68CA27A1A0F671ABFFE172F9FA7E6961C55137CC4A34
+D379459DD6A8A63B8F7FBE16BF2F77AEE01060C67D7AF26091DE85D4700FB4C9
+05EF3254FE265F0E66EE2CAD57B63C34E35D35262199E5A31E9B414A0AF67118
+6FE9F940AA25264AFD0C35E4643BAB15AEC670B8C7396836F40168D05A23CFD6
+4CC426E81F84B3E5031FA46F1BDE4C638EB267E96C62170398D098FEAE829537
+363A187F0E50509360B67BA7C711295D192FC1A221482C60F98056CE462CADE1
+2F74B2A49D1BBEDDCA3FCB957BD493766B4BE9EFD29ABDE35E539129C641E03E
+0FA83086D9EDC3887A5022594255FE39440DDF55F34A42C7892C56B68E2A19DC
+6380520BC9952CC445E4E7C64006A33ED1C0628E270F9C742E7B97DC75543C7E
+F7B23892617211A97A6D2F43D54608EAB45F1DDFC203B66F95E12E422CDCDFD6
+29A40BB2F3201B8903F5356CCFB8174F1BC1EDD87961E052F71AC144FA71F1B0
+51DF1529F52DF6A1396FF0BC57AEF88B655779C9FF83D483EBB3DFE26F43AFB1
+ED0AF955B3593B2B7C42403F53554E91EA0A32C4E85A8A79399F9EF272BE2B36
+5D0FEF58D15A0E8FFB7276BA2D6FF261EB4E1D006E32AEDE2D79B022EA39EADB
+80BA238BAEB859E64FE436A199FB835FFB684F8D05EDAFA60B3219A7C921166D
+88345DB47A896283DF02BE43FF29E4440AFFC85C47B055D3E4291C80C19658BF
+820840313984CDCFF3377A36FF30CD46D903339F3F61FDBC9A645A01810E2D28
+16F808496894C0EE571BD32B5AF8FA4ADD23A72AAB3C9A637BA489B74DF6F917
+FBE810CDE964F172D1EED578F7AA341D412EC4A8D5CA59997843718CBDBE961D
+BF9BC82B6714BA2C9B355FE59C0348AA393DD0A9BBF02A1E64FDBC9370DE8917
+7CB11C5A652195484D7DAC328A624FF5284876E86BC8FBB5779E1FF4E71C5BB5
+46DC7E799EC63BE084CCB10471C6951CD768A0284988EE3E658C9DBEDC296300
+229759FA81CE67F6C3907C9DC0C6751B828A70E6EE28D1C22FA665A8559105AB
+1621EFA3335B4D4E5C412E8CA060C79AF00535CE4422A1FA74DD627CAFB31DEF
+B87FC5DCAA0CEB640DBEEEF9998236D373856507635192104F29BD1C992A1D8E
+A2F7EFFD01C2DD2F49749D7879C2705CA363633EDE46C007DB1CE387637CEA5B
+058BABA8A08F88B1D9E0DF81834675F472AFD13753F77E2992B5B5C820872AA1
+F5E47DBBD1DB5E85630AC2AC084113BEF271E8E98231FEF65ABE1FBD21B6F40E
+8AAD4E8285F5D0F8B77688C889A02A3D645EE94B9A7B4E7F379D3BEA340E25D0
+89BA3647F73471FD0E1F6B8B202245F3FC55AB652831E56DD96D0E8886E0DECA
+3AA41637664B8057922B24FF001B662A0C0F8088C19BF66A729E72793316FA69
+98313FD1573DA4640466D11BE0C530D36093EBB9A8D70D75F7F8C154DBB57162
+201B305A8037CA11623E786C99ABC1A4017B7DF560C8724D9021FBACAC1F5B01
+4CC686448A8E8FAAA4D41E32B96A2B2EA69CDA3E79F6B87BD27F8DAEE3D9C3E5
+CDA620A1D6F9FEC03E5ECCCBD906200A14547BEDB6D47598CB0553335FC7CC44
+6CA81E60E2D105C4B60516F845E0F795441C962039D31CC15C6E0CB65BE8C079
+8B93AD90ED515FCD0A4439C5C1DF6E395969B4CF9685D9462B9E8B281E9CDB17
+88EAA9371138A380DE395CF4A8289C5D54C5D8C02FC58FCC61CD2D19E96FEB35
+C5F7EFBF32D87381F2B396E823A5B4D4AD68929F2D55C7B5EA93F1ED0D24DC54
+1AD7A5EFF97F998608BF7BEF29C3ADC76CC1C0FD3D1BCE8CA25A1DAF3E2A049A
+E43294657E7E5661D0976A2959041F07AF32087F300A7451168DBC6FE495A215
+E50BA9D473ED5602C07CE9182792E5A89DFF1F6274386090551C4E02F935E806
+C3CF97E9386AECBB786C691B59EF47243B7F6206E718CBF18FC8754100A2984E
+586CC321F2DF90E7493115B0EE699574C07082C113F1903892A225992C6806D5
+A052B9260057D6D683694047F48B89F3532F8041ADA9EEA60DDC4C4F1CEBA573
+761472A0B6E23D96B08D2B8FD43638E04312FA3CC33A64A8E5197E15065729BB
+08023560C507769A084286B02D42D92A3FA79201D63903F124BA2E0692C18FE9
+4B9056DD6CB0D8084CA71C5C532FDF63902892578E188782C26FFA3D2B4557FA
+68495223E2DBBCFB02271C917CC0EC2CF05D7BE4B075163859EEC017698361EF
+A2A5E1BCC7311D4F86D299DD7D00AE474CE7D98CAC1448396F30AB83E745F045
+33054DC6CE1D2AB72A5EAB6EEEFA1179DAC4DA4EE5CFBDBD75AACF2E7E311734
+C33131E3B1B92D74D220F8C7A14C93EA46F4DB711C5A7D7D9ABDCD800817C9C9
+5EA04E9C83D08B528BEACDEF57EA27E6E876541D5CAC5BFA5F725F39323BF893
+4CB13CD1D90ACD0337FD0B4675C8015C6F836902E2CACBBDB3947A9934B0F935
+3B220DCCDBBE47AC2A6DADE69D8E59D603A7C4AFD0D3E038418AD27111472DF7
+20D3CCD32E2F0ABD680AF97046831E6ADD765CCD990AE6F783DA01C3DA0E35D4
+8BF49D8A4FF408DDB532C8A44380320DA246CD2F6329B6B612C15EA4BC531F30
+574795E0D6B1EFC4FB59909B9FCF71B1CDA7907E813112BB07A1FD55272800F8
+6EAFAC1B4E9FA439B668675F839120D15724A9E45A9494
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMMI10
+%!PS-AdobeFont-1.1: CMMI10 1.100
+%%CreationDate: 1996 Jul 23 07:53:57
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.100) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMMI10) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle -14.04 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMMI10 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-32 -250 1048 750}readonly def
+/UniqueID 5087385 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
+3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
+532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
+B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
+986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
+D919C2DDD26BDC0D99398B9F4D03D5993DFC0930297866E1CD0A319B6B1FD958
+9E394A533A081C36D456A09920001A3D2199583EB9B84B4DEE08E3D12939E321
+990CD249827D9648574955F61BAAA11263A91B6C3D47A5190165B0C25ABF6D3E
+6EC187E4B05182126BB0D0323D943170B795255260F9FD25F2248D04F45DFBFB
+DEF7FF8B19BFEF637B210018AE02572B389B3F76282BEB29CC301905D388C721
+59616893E774413F48DE0B408BC66DCE3FE17CB9F84D205839D58014D6A88823
+D9320AE93AF96D97A02C4D5A2BB2B8C7925C4578003959C46E3CE1A2F0EAC4BF
+8B9B325E46435BDE60BC54D72BC8ACB5C0A34413AC87045DC7B84646A324B808
+6FD8E34217213E131C3B1510415CE45420688ED9C1D27890EC68BD7C1235FAF9
+1DAB3A369DD2FC3BE5CF9655C7B7EDA7361D7E05E5831B6B8E2EEC542A7B38EE
+03BE4BAC6079D038ACB3C7C916279764547C2D51976BABA94BA9866D79F13909
+95AA39B0F03103A07CBDF441B8C5669F729020AF284B7FF52A29C6255FCAACF1
+74109050FBA2602E72593FBCBFC26E726EE4AEF97B7632BC4F5F353B5C67FED2
+3EA752A4A57B8F7FEFF1D7341D895F0A3A0BE1D8E3391970457A967EFF84F6D8
+47750B1145B8CC5BD96EE7AA99DDC9E06939E383BDA41175233D58AD263EBF19
+AFC0E2F840512D321166547B306C592B8A01E1FA2564B9A26DAC14256414E4C8
+42616728D918C74D13C349F4186EC7B9708B86467425A6FDB3A396562F7EE4D8
+40B43621744CF8A23A6E532649B66C2A0002DD04F8F39618E4F572819DD34837
+B5A08E643FDCA1505AF6A1FA3DDFD1FA758013CAED8ACDDBBB334D664DFF5B53
+9560176676ABB71BBD0EE56B4CC492C0652750227CEC70705209555AF57651B4
+2E6F62F4E75D68A882364F7DB4B647C489B46E0677D3AFC159A2E79E4EC4F6D5
+C92F528D4B79A73A30A8322518DB097D307D25048DFFA5D2D1C60BA5FA590EDB
+6564A9C890549CC4D9459ED5BC94191E7327E0DFD8002A501C0C611093EDD0CD
+C4AE45BEDEAC39AE792433001E424DE29CBD2E3D57AB5E51F2C3CB657ED44B2D
+D66A47C06A0C219618CFF1D11F7041077A243000646DAB8528D5946E66383A21
+DD4070ADE71687BAD5F0D2EBB80C2D7F68F7FAD136F7B6B67809917243DF769C
+1BAC8C4D9E26D4935FAC978E86A1D1CF8FFFE4990C930DA1F2FB2A0988E51CD1
+281CB61FD92CC8EBCF
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMTI12
+%!PS-AdobeFont-1.1: CMTI12 1.0
+%%CreationDate: 1991 Aug 18 21:06:53
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.0) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMTI12) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle -14.04 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMTI12 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-36 -251 1103 750}readonly def
+/UniqueID 5000829 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
+3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
+532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
+B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
+986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
+D919C2DDD26BDC0D99398B9F4D03D6A8F05B47AF95EF28A9C561DBDC98C47CF5
+525003F3DBE5BF07B2E83E66B7F97DDD7CE0EEB75A78BD9227BF359D002B6ADB
+8AC57A33FED4EF021A7085B1E2B933DE602F0FF71467ECD501744AE338AF29A0
+26F7D368AC6F25CCB882DB7B7343566192BD687E1349225982823027D3B66703
+3B0DB7A7E680A682B98023D39C7FAE81A5D5B867A0A66C8AA0DBC83B1596A84F
+0436AC6A7900B767BDCCE0060A4811003C79FDCC71D73F7F2D0A6675E93AD21A
+56B4CD8EF75EED3DE8C0A18BEBF7B9D1BE72504872D56EDB272F1E97FC726CB6
+68C85C713059DA19F6C2E0F3E12710A59B6FC4699AE883DE8C8615B7292AC25C
+D5714B6CFB14EF0EF11EB13009BEBA4F345A5D3D6D9926ABC2BAD7DB1328651E
+437BFB3C46DA7B62219660FC368CF3D3704DAD3AB461C28F711665BF484BF61C
+052093D231CA65618EA463D63E406ECE858D180A6C0589B2FEDC321371C28E77
+DE974D655DF5FF7D41ED01FE717D928A885F6FA6CFE4D2C0807F8E7F937916E0
+96EDD1A3BA67802B1F4A49100E75613BA0356D9DCBBAD4DAB3C59E70A47058F5
+2163D1730F0EE4D1F87C3A4AE723A23CFD7986FC4FBD399347E9F5946354E013
+D860FC446AFF0B0744F5DA27CC777C96ADB388D1E835DDCBE123FB517679B9B7
+EF696E091A9D51510BE264701A41C04FA8125A48F306ACA7A83E35D5BA0C296A
+BC594ECA2CB27E92FED95B595C21E5BF0DA724D40761CB377BDE5FB98C9D152D
+6C0DC98C4083E9656321BFC445CD6FCC142DEF16E27DD6FAD0B3185223B1A7D6
+779F39C70793184F2C3B721FD0AE6D8E063BD47804785DAEA74AF8C75483B713
+650616523DE85176FD0FE136F29D51414569AAA84C411B9124FDEEDE26FB86BF
+2FEA504B02C00EAA205CFB2420CE83166A4C643E5E5F3AE1C060260B49753FC4
+F31F1732FF6C966460657C3A9D32C4E1F361859311B1C03FDDA18B1D08D37E62
+42FBE301B5DA4F93193BB52571064C9E5A60945535C25F47967D80D9038C59ED
+91F4E0E6622F775A08FEA912D0A2865EBE8E1A7EA4773D1063F2621562960826
+2E18CE4FACA7DAE9688948CE5D17DD52230B8561D4DE82D7F94C7F27D327BCE2
+1030E1AF5D15CC2263327976CA7F6FD70F61BD065845B318A3FB0772D279C376
+C97D99F08F933292D4276FBF1C7DCC547A2CFB0F6E0B6FADBB180D25C0A51520
+AED24D5C49B3C45EEA2D45A1863DFC2FE66D6676E8C457422AFC659E3F39B25D
+A6FB5678A92E11E58EEEE2F0E8A10928917BA1B32DB46F4FC5E910BDA33722D3
+305B5ACFED5BB6E77C61B4BFA6E97B2DB7D098A3F7FD6D12D1C6AD8445A359EA
+AFF23C24C61A564ABE303A4C7A76B7054E9ACF84CE8A59C79D0FB1D75E7F0E9F
+4FC4D74D9E3AFA5482FD770B615B56BCB2864728D86AF157862CC49EEB7BD23C
+B604D0BDD94AD5CCD62CBFC5C0D1B948AC6F4F554CD064D53B3CD17CF36E912F
+8517D8CF23E3FF07DD0BA3FCF6F1B35C20FCF8B4D2273B59BD42F078D1EA276F
+B1022F39CBEFF2763EFC6DE5A74ECE4A841A00C626BDDBC2876AF8ACA97087C6
+F813D98DCEDCE02A0CADCBB0DCC891D040F779F02242FE5FF98B3A0A089E6BAD
+061411803C9283986104C38D54EE72ED65F903D1ED2FCBFF846ACAA36CB69A5E
+775ACF8753F8B1FDD9CDECB9E202E0849931D3E328F21641EA0C70B0F4F93A7D
+14B02CC241426B6148F6B03CC21D985468B3C5C24F646DB215717D82077EFA1A
+FAC5C2696000FC2DC6FE9ECC575F3774736DD07057E68192C88A3A61E11ADA02
+D5E589D3FD6821B585FA3532518DD0AB17AE3F66BAB2DD8B06B49CB914ECCC2C
+158FE3E1D4DC966931447C66D4969378B61767E448055933B7D10FB0CBF92D66
+7F68D4529311C608237846FE2D86F68AB670B42540C3FE0C75D3070B3D63D694
+62FA9A826BCE0B6969DB03585FBD2195242A85230AEC9F71B8C5DEB1064F59D6
+41929A1D293650D1E4D1629247AC0E220B2F208EB32F72F6220A00EB6B192FB7
+41D11CBADFC3D7F7DA1AB113344593CA50BD08CC00AB26E5556711FED9FCB35B
+72526171B019AB0F2FB31D45FB7E4850D5C43C873D903A2976E14EEF1B30E0D3
+3E7F2DCB62608D853751FC0E333B9EABA65E283521312A4A4FE204C3D4FA9E74
+DA83441CF0670226E5CBFFA07D55FAB36BFF80927154B6C5F024C82ADCB624DF
+29E27E614F6FAFFB66C1075F4B6E151270B6C5EBC4D342A37B2EBD00B3E032D2
+0443C9DB2B10B7998249128998E305E1508418E6F12670935911A4E4D7E4CB0C
+707D6AAA344F9DA21BDA0973CD82AEFF026FB759FAF0D39F5A2B146EA7129F63
+D2291CC5DB4C227A9A5B85AE3C820EE2334A47E610720D262AF56496D923DE06
+F574FFD266793F294416F022E8273EA43E4DAF52A4AF8729AC2094AB6A65F8A8
+7D868DAF00CAFF2C84EC18967784DB219C2CFB50C6197E77DF508216922DEB81
+A6365C3A6028B765C1664F33F9651D8B7DF71FA20AC55D63F7543C4E438F2E2D
+4A8BCF6AA5E4791CA38ADCE2199EE63832A3BF2301995FB31089E08F4C40A4A1
+2667F8A3668E654C89FCE642E99FCF998BAE6AD67AD693B5B057AA3AE9D235C6
+30D8C204BA1F77DD96D5B443ADF967A0548B551AAA2DAF67159F648A2081371C
+4F43E460CF1695B71F416AE27EDC1D0F47E0CD0178EE3BE350380B6C720920DD
+34320515608428D168875E32F33E5FB2F2EEDCE419464A6FF8055AFD5ED32E42
+F557AE27349AE7A2A1001E5D886513617783E080023F48CACDA1FEBD70BDF119
+970B066B8179ACD642FAD185AB2EBC90391ABD407A21CC031CC70EF860DB9162
+2732712C24ACA97BC7C91863A5E7D4E2B0DA0EA92594E274BFA64C9DAFA817A2
+07A0BCDAD3E5E30584EB19453608DB8EAE528CFE79813C42B23C173DC526AD40
+D06A72EA4F69C2D21B691782D851B960E5380CF2F22969E525F891930F0E6666
+D7AC5E414B5AB3557C28F331AE1DF2361A3E9218E24CBB20619D43BD239AE536
+94462C6C5AF6D73FAEC76DB0E55ED84BB21A30A336E947664CD103E18516BDC8
+9CD7F5916671E0CFD0E2442682D51EA907EDA6890F1AB8A32054EAC29C7FACBF
+B7258F32DD7F38AAF4743DD71F9CBF9E99F0842DA803A774C0FE89F596A639B3
+58679B7888EB78120A61EBA3BEAC81317C0098267EDEC418931D0988FECDDD29
+55F7C4D314E86EA5A2D00BCEAD30F42D67CBCC1D949F44A261DAD75A97D6D9BB
+77C7D9D5E43B2D6B787681B2EEFA5CDA794E42AA887908D4CB80A052D2BCAB1D
+0BAFC7AC0D3B3D9F603A0516019436B11A84A0C03226AFAB0285AE575DFD5178
+0F45C7DB117B5E245A6F15CF8BE47AB593F736CF5D40FA5DD065D0DBBE29AFA8
+C14D83C14CF067E2101E3639931E1F4DE793C1865FDD561EAD27BB5F0951D189
+3FF0CE21E0CA0D13E7B436A66FEDD0BCAB30D8E098E510E31E607122C777C395
+B6078C964ECA07BED6F9A201D284228DA68B0458D0C6FF4B0F100A3C51F516D5
+DE28D8041BC915AF0AE3EDB538C14E29CC5FC0108A4D71A28D30338A4E32252E
+7D3AFC525A80F2C4008EDB40F8C83EA04181045B1F25870FCD635307FB1D21DD
+C98959F94736E5C40488F2A4C1E70A1BBB6D7D857A7F0AD5A0A44BF5A1A4D086
+BAEC60B8833587CCDF9A59CB1764735BBEB1A82E903A5FEF291543491936C8ED
+C9612C4A6F45FC0819839C78EA1B75867F09E66B7883C25A6ACB6D42236F491E
+35371A01AE6772F97158232AB3D01BC1A94E729595CE517340B86EAB21315167
+3605EA7C68DE115CCAE2C54DE9BC11F4E55055C68911EF367B056C2CE7936A4B
+002B66CE5668CCFDF39D1F85FCCEA3D1CA35DCDD893A30AB05A774CE4269C9CF
+CE14177573CA0EFFF58571E1B78D0ACF6B503F01CDDF88A6FF6C000E1CF3A73E
+669CF7284C07607327689B80CDD4FBBC71FE972623204B1DCC092301B0E854BE
+51782187C58A70B45B3AD886DDFDE47F3B6D2E2D98236339A85BB20CAB3C6A47
+001AC4C5DA919BC14FE7719B00F74F4A2E42EBD4A362579406F98A72FA61B741
+A39E1A6617DA0A588CA915DAEBA121F12518C28D1EADF640BA0D8222AA5D1D1A
+257EF9A487567D82B54A50CB8DAFD0FDC41C565A70A82335A2D0755BB54145A7
+DE74FCDA0C87D9426A6518AF1C0140550C25D7C1FF515E7895DEC488621DB278
+617202313B100F00FAF49A6A10A578197E8987D0BCEF6034D70EF30B85BEF432
+74C089E7459584AE9A1734AE3CA70BE3CCAA7FF9AB88715F0214B168B7CE9863
+17E228676D00CFEE47240627BA9DE973EE097C29041FDF752E9D94D843568E06
+AA8E5F200E4C8FE769DBB87025568056C47C9F64016193C3EFA10C19A764294F
+CECE19AE4BD54F35079A89945035F38EE87571038C89F4780784ACDCA8F6094F
+6B9AB80E64AC0720A4A7DFF99D901628EDEA5E7EBD164C12142BFB899941453B
+03BAD13E222A472CA9C678FE8A7D2C3436190142AA6DAA78995B63A0FE5EA639
+34F30129FB531CF8400FB0ADDBD6205CF6F88D90FED524EC195D43B2CE9B35B5
+1CA7FCA14C3698127A9B06D306B2B595DB51A3DCBCAC92C2108C313E1D257E79
+FDE73DA559D2AC804ABF2678E74827DCC0380AEB8383F56BA11D815F7E039017
+25AFDA6DA2673E11F4ED85279F4387AF11F8AD4446774DE81F60BC91AD565139
+49F350E1B6E063A9832E3946EF528BB23A28AC2286B840DE8855D2DA1568F89A
+B57ABF891CBCF39B4AF1B9BB670C6BBE194E2F3EFD523B42CADAAF0846E5190C
+000F0239955C43B7F51A9608E8E30D2A31583D181B9887F9082BE8B84D806DA4
+5D5E528847CBC53B1284C485CC3C97AF469EAA330F70A389E891FD08AFF7FBDC
+6AF3FB3016684DF0BFE39E87E89A1D060A1468029452E9091017A86BE5D15E66
+1F5D48D966E2945C7F3E94D49AD21BA55D72DA84E026920C966F6A4756399D5F
+56FC7FD54DB142E9911074E0BF4398872149B1FB3F1DE19F6C82BEE07A4540D0
+86CBF545C8499E1173E369B2374AEFE1301650E009419F784F210FC1CDD9D75C
+25C342AA7CFC6382E230396A08B70B615C8012D94D4E6B6E71F497177D12D687
+52240B2F5271FF5C63B6362770E71F73D3A6F0E9C9EAD804A3163503949819AD
+6B76AFEED41E63EC38F73007BD45E6B9FCBC3FBCFC2D6E6F8D249D16B3F57426
+C2E01B113DB17E0A5FD0223803A4D4144D6BF6E8B322FC7A9235D839941EC34A
+0D8A56BD0B471DE1E42A6F38AB772BE764A8EF00907C97F996E231FE908AF7DB
+841FEA29903E8CD9B7B6C8267CDFCB928BA350FA0D54DB289E4A3645E1A25610
+DC18EE8488B3658003A1087D73669067871A52EA39B5F40B181EB29312EB7135
+EB9AC8531928B5E7BDFF3C041C4F0F9982C06C014658502CF022A67FA115D0B7
+BCB5D7754AB9967B9C49F80FB1223DB6FD25C08AF9A92B112EA05E42FF9C2A3C
+EAB44044A9EC1A34783428ACFDAB6A9D976BAFB1EF17347353762BBBB68A8A5C
+310C2D9690D24024643E4D6F49EB9014577DFA34B970E77C3497937021FBA2FF
+6925F732DD61ACE613964A5178B4ACC8059A40612CD136221F8A8EF8120D7E6F
+5827FDA07AB69DFC73D280D35112772C12C7895EC71873707D07AD875213136F
+D3622732739EBAD97778F79EF47F80CB49D05D29875755EB2D2237F713027C15
+EC5C19AB8C93CA551859DCE2E944D11E2F96A6E50AD66D98CBFA3BC657B6523A
+8E092EF5BE36E66190643EEFAF0D5F0CA2E7DF086E9F7976C08E972B984816DF
+F2D911952720F87D9D057857BC310F3EF5103564878B880D22F22FB232CEF2EB
+957E60A9B28821F3A6E4A9AB29FDD0937E319A9F4583392B5D7ADE21070C027F
+2CEA30270C34FEE0EF9886F757D618243EE9B553643E4225905FE9DC38D75F08
+6CDD7412B7865528610208D3195A8BAA3C89C7EB799B2A0081098FEB28ED6780
+61402CB8538960E4B34B0F502BD0400D2DF3A7602A865194208E53D70F93F66D
+C0D4FBB9701DFB5C15FA0BC00D3601BBCD0EB5B1399F847227E1C49CBF80BA07
+CB9F6C7FB4DEDFC205985DEA35D5BE64E83A5C0E26ED070B10A3B56DECC3C568
+9BABEA61A597825F11705F68249F9AEA8607C91BD72E656080B84649EFFFED1A
+9DB26BAAB356C52280F872DB6FCF684959D8C68306328BDDD2832862DA557950
+406400E4B7B2E4337DD47CDA36FF4E7AE2640C2CA6BD12D915ECE9B24B33C04E
+3343E8A28A4A5A915E9E9A6FBD111186A0D3BD049EE25B6595528ED43A46F33F
+A37FADB67FFDC8D21DCB08BF9640D21C5800EAA0B296A0D1B679278BE205EE02
+499C804AC037B7AE5E9929DD85329DFEACFED69D5B2056B1C0444A66B9E0114E
+54A151981BD06677CF70623B2E4E24B645AC8BCD46998921B8D274A2297218AC
+E90C762DBB906B13BFAB8FAF4A4CAD9FDE5176470332D772983CE9A21C07B516
+DD8EB810BFB4D5C1A489C6FEF8C63218F919D4AED6E01AB5D2CBAEC5BF31B96E
+A24AE74CEB59DA00A965E5EF6A4937BA3166FB8B0A5B4FB998D2A366AFCB371E
+5B351AF98BF683498ABA131EBA52C39E916FFB210472F8F9534DDAA726DC228A
+7BC5F4DA3C78A7CEA6A0C86DBB7F110D4336EC55DAD42C2AEBE51727E9695D8E
+558040BC4638CF9279DFE3270715B0FAE079E4F742015110E714F96732B89879
+2BF3FDBFDF3AC2E320274F7BA6888DD2AD003CFF30D12984B3AA47CB0758BC0E
+25263A4EB428F93D2963CE1BFDFA06A339DFD9020E41C3F89AADE9009A5C16A6
+8CAE714520D6F576C9B97AB35C01B43BCC24385C665800A6992690AE6B317FB5
+FC2517F912EF72E2F89C672466EC8287547D48C000F3899EE267281129DF96E7
+01548FF77074C9D51F1598032F5B38B84B95B24CADC47F8FDD10CC48319D4C04
+BCAA49D49CD80973FDEDD115B02373EAABBD2D02245A3C6BA3FDC533398A6319
+DC4B06367E6B1ADA2E55BDA4FC6A8B0042D7BD065EA43278553F913B63C18DF0
+A8481BD36FACA43331D801213EC17CA4F1185D415989C3A7BE756A28084DE7DF
+7971EA4440F5D8F9F4402202D94C32A85607247961DE1937B7C4181BF04DCA2A
+CAAA80C956079BC5732E1DA1EB33F7FEE6F13BF2D67A24532284862A0D5D1305
+144A48391BE4097459074162E04CD392ECD5D7C168F9A3CD7BF0BF0E5E2B83CE
+3263A73FE93630E5AECBD8580BA1B2E3D4479FC24815B6BD5600E0645F11ACBB
+FC00F65F2F4C7B91DEB251F2F8BDFFA38D39DCC7CB38A52F5183E6E17DB99D01
+A6F4B26A51D1EB8A8F1697BF2B9F09F8162AAAD929CF49A2FE5175511DD5DE31
+8EBA101ECC7A8AAB6C2BB276A2D6A3378736C11B234F16F3B4484183D86DDBD7
+D8C5B3712BA3C93CCE213B092E34D85932FA4DF230F6DBCD1D965364DCF11C48
+5D9149FF6557909F169A357E1B16E30C0F18F220C52DB6DEEC6A9E33FA43E374
+5AABF6D338D240F34FE4D137A0BE56E0F1E79DC6AA5D2190CAAC339953C49628
+41561B595C05EEAFAB06B9A73E4BC00A7463D763548ADF6A4106930715A44156
+502986C4B340006BC50FD9A8421675F2326F004C872FF7286D0A753D041F2D66
+6757D8039A7F1B6CC555DD1C84379B4F6CB7C27D9C5A124BD3DA9603DD24E7D3
+37E1619D60D4228C0B79E649A069EB94513CCF9CC57EC927980892AC5D74D16A
+7845DB1530FE75C606F0DDD83C5E541FB621B0DB403A7B39BC3EE668E4FE8463
+FE685C591EA7826751C1A88B804E79B5AD26FE21947A3F45EEDBEE4188F5E45E
+77C4768E2D998842EF28FDDE2778CF4F901636B86CA27FD442FC98BC5CB66EDB
+B8EBB7156BAC519EB47520FD7C2030FC3A85DA57E5BCA52962147BAF685924A1
+E8E77D3DD01DC75B675B1E3CAFDED84732E0BDFADA3E3EBB17ED1301D2FAEB84
+0C57B8A7BDCA807EF276A69994CA955F11B48CD5B08E44FE9689EEDDF9780BAF
+8BD20C2708D41E015DB91CB7A1A1A6559A4AB6D461F6DD87E59A7B155E46E9B9
+C1B4CB43D5889159FD634493D9E537B721EC18ABD8A5B3B909F2F05AEADA94E2
+0B57BFD144E8E1E4952A5A4A46160B1D207C841FCE6FC85DE94B63C96BD04289
+F23C05473898ABF2CEA9C1A79508502FAA54604E52DF0B66E1EBCBE308C0094A
+12C3F9476AB01DFE949DD28A3B36A664F72B3B0E0A60D940636FE035360E6C8B
+C64764DA7F988CAE1AB38718E96F6510A62A4CEB7E37DAC26FBE105DE1F2C775
+E5764AF4E811159FF34C0F6F853E210A4C1E5143A4922BC3C3F2D0ABFEBF3156
+F7C4ADCAB99C10426A0B5C842EE93F3C5092127AC3C2E067800C39D96EFE85B2
+E152026B5195F524DB3EFBC1A7881333409A82542A6F66E5B261007C2C131888
+B411CFE939A84B5C2F39635D426BA4E7BCF91635A66B1CD1C609A7613178B82C
+B5ECF9D364E0A2236900B58EA25AA192CE48AF549C8DFD93815D109DA66387B0
+E44E1667609D44693677D75A16C3F5F5A9593F11FB4B28AE995FC457AD180AF5
+E40CE4AB35051C2C24EB2C73745FC892608684CF3B71771861EBBF33A4FC138E
+0894B608E99DB4B873ED8E94E41DA8F0A408B787D2113F078752D950CCC10D2B
+45D3DD0F8FB39ECED07CC35FF2F20B333A4449AC7AE6074140FAECBD60555445
+BE6D7582AE19F41B40291F63FD30FB383A9522826FCBB6761CAD0DE648E3F093
+432AE2D8B4F83D9FD2BCFC2574FAC8CDA0AB760BD2F87DC75859F9DB001AFD35
+6089ECA91934990E46F71FC0B3B78FFA10A67EAF1685240C16D34A7CDAD7B7F8
+A605916B22A54716909F26581707B33DB742A5942189AF034CDC0C8BFF0B60CA
+AB5B260EE203F154DF63FE1D804A335B22598C97A61E18566BBD8A0C8C72D4C4
+96FB92CCBF0E05885051EAE0229D7D74A4202866B476F814B65F37E990DB2DFF
+04692B2A53E9C00C7E760488B6C8EE04C884F2F0208928E75426449045F49FE5
+6A64FCBDD9E7A168E178C428C6D0C673CF8D9FA9D4F0A7A10F28156BAB175F0C
+71AD758C9714A70442B25615DF519EAC5623FC2F158B26EC4CB2D826D9D9541E
+282513E0FB5890429493BDDA707A6142C9D9C1ED43B5CDD364E9C1ABCF985C1C
+248FDF035DC7C63B95A8ED0FE238EA5EA2672EFD180376059D54D24D8CA4D058
+725AA5D11B56559553245903BDE021390EC1058F60DB4A162771AAB962150783
+23CD775F36757B0AE0EA50E3D4B5BDE75808B8F4BE02046F68EE76CEE1652367
+784133C26BE97D3602EE420CF637BC669F437F57DD945EF3545B5341DD77254E
+D42AE5BABE605F2B850030E681384F5ACCD15F41F7A061A9B516A3BC2C5771C8
+DD0504C742E3470C8813723FF08E1E24F8F5461C40FE20BD6396C70DECC86B28
+2AE906106473A9C965455670E23E00492916DE9EDBC222558149CF10F4CDB100
+EC1405DE05F4336E5A422140FFEF48E6B1C331654882AF0887E2840E6D103C6C
+B98269695D67DAFDF533E37C29B65A19A108297336AC4B7CCDF850FF0FF9591F
+79FA052C998773FEA71CF7323716350AF5A17DC932F821450A626380054017BA
+3E245EAB8B2AA6BCAD50E6A4BE215433B7C7500797F5C62ADA399F30C987007B
+7504DE599B97CC28F9177489EB5CF58FCCE93908B0DF7DA4E8E15D01D8246619
+1E2AFD0B00E484C6CE344593B1C7D9BC4F34AEF86F35EBB66F48384846ABB6E2
+32E6692F9B814279F284DDFB45A692DFDA54B1980154D1DE879459C1F69FCAD7
+29C541B85475FF51589853D4234870B84DEB6DC23C4FAAEF00BD923705CBAE49
+F385D135E528E03D98DEA10D0B31A86B6AE45CE735A42ABFBEA73AAAC52B8145
+B10573F1B4E9742306550BD9E05F9859C270CBD62908B042674DB146B7A0F4A8
+1756BECB6F6017CFFF497B07907F6AD1C8ADE015488C3FE72E0992E672FCCA8C
+D1B2B7FC726D263E4C2C3F8768CD8972D74BE0A878A8F164898C6F9FF886C0E2
+863BF2CAD41B6EF9C437BBE3B3DA172A853A2A82BF3EDA4840CD655B022AA5DC
+7845DA2233016912E384E0BD85837BDEC4911B46F9B727DD2F3A439184E61D38
+C66750819D14FE73F503E8F829D1B03C0794713BDBEE0A6730B70A6CA2244243
+95D01D42403A3CEE6C593A79047F0B9535F595734B69350B72248DB0474D6B01
+AB26D2D5A2CC479430A09F9ACBBE5766922656390CC676F7BC3CF9B87815F703
+1B7116DAB19F09248172BB1465058D58E90399645FD47955E15C082A75E5F1B3
+1A7834DB6654766546DFEAD70F98F620131BEF9C2B5B327DC302A0C580876D11
+8A2F5E87BFE62A9EC188AF40EECF31C4A439745A51EF0DB70BBBEE11DCB0F5DB
+E83DBEA3BB13A813AADF98D9A8F24436C0ECFACDF86F837808B793D81183BE5B
+8DC8CA592C79A16E5DA3034A340AF6CE636B50DC791349AC448D315646EAEB79
+F1BD9E9D3005E045E733BDB6F71F2E92DE51C7F36C72085D486078A3E00A11CB
+1ACDA7F2EC37E5687FA0543746DB765AFF8D6A2CDDF1E2CA681A0BC567FD4784
+F5CE7C94F6322F906BAFF0578A1E72784F1BF633FB89CF94F5B4B4BF1E6370A4
+A064B560DC0E03C8FA33C2C4A91D91C6D426F264C275C364FF0F5244627282A5
+58D34E88404C9042B314DF94B9477D7EB781C1FB4B259555EE5D6DEC91F6D2BA
+568D80FA9109FAE38818EBD408F1DEC7733B713551B225A67469CEC9F4B2272E
+99D211EA5CBE8A63854C65533A622D0F49B81BC64ECEAF88CA8A79D0C2AA7C3A
+D490CCE61EBD9F447E89D7B2866EC0AF4932384BC6F82C919D890963268BCC8B
+D750814DDF5118BFA6A39C54BA142C783DED366A70B354305FE5F6CC79E117CA
+950344C3F0610F35555D97E354981B76371D371F75C7B7D9B7C67BBF830742EB
+0304FDA404DA8799722997D4E82EAD7A17FA808AC6BA5B26F1ABE58AF3E39EBF
+FDD7E95886897ADBA77B453A37D1EBBDAFB3D823FA536A85B3AABEA7F707988B
+888E42DE658D0C4045C9DB4808AF29F5C947E73C17A182EE96244A9EFBF72CBD
+33D4872D48F0A810E90A51B9EFFF04D05F02A2C197475C1D8F8E3285B936E383
+FAC956F55105472D3A62B8A3859E4D9595D78F334B93DFD34B5ECE453F
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMSS12
+%!PS-AdobeFont-1.1: CMSS12 1.0
+%%CreationDate: 1991 Aug 20 17:33:47
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.0) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMSS12) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle 0 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMSS12 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-62 -251 978 758}readonly def
+/UniqueID 5000804 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
+016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
+9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
+D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
+469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
+2BDBF16FBC7512FAA308A093FE5CF4E9D2405B17498276F99362748F6E97327D
+7CDA3F5773E01FAD12B7339D4A0993D40A82FA42AAB119589F1D7D60A8AC7A96
+BF8C5A08AFE6D427A6FDDEA2FEF0B8ABC37C6DB62C8B4074CD6C385419CC66E5
+A4B4C5F902900090EBBDF7AB524205CD9DD9D8B9CB522B8EA97203F0E8FAF683
+09750B6C8286AB341F9C240CC02CF7F3E153C3498F16159862CD74C0B6341D3D
+57184AB9036EBA94B432D0CAC32240DD569E639B4ACF0BEF07EA19DDF0606551
+C8EC84A7A67F3C3F58D3335D7273B51CC2602B63B900D24A6D5A8E766D49EEB0
+693796781F0781FF13C5592AA9E071E39034E0742E804ADF14422A734917F0FA
+8973A1B9269EA354F8AC75B7284AF48B69529167E55922A20C3106EB6C559E97
+7CC1A491C3B41AF834804590554742E742A09A5228F71DAAB9BA2BC3F00FD5C3
+B4821FEEDC8B65732409A9C4663FD4C4BC7C864D71F6A6D354ADF71675042DA1
+31DC2859AE00363B3EF589B4DAB98D3515FE8176041A332A5647DA8FB9718975
+9D0103074531756594D5DD1AF3A9A20F1BE203E28D24DEDA7801AD1CDF96906E
+E7049115872C82DD177C3BD765F72E7C15A90CAC968198A38EBA25054D99E7DC
+A349E6502C98F894994EF7A0AEED79D1F12EA1B18BF8BC3B5806141C82B201EA
+0275585110EA202D7A253F1D6DB449FF2B25F7B8385B1427453717DB07ACC21A
+9F5D5DF4AB9D3497C382B1B9761FD0693533650CF014F5D56201767E4CD18A44
+A4D912E1A90EF1BEBA702F806652672ACE37D40B4705A4725AC38A8B7D706E84
+6D22D811AFF8C8F465D585778EDF77B600F65E332849ECE66FB0EE108B30103C
+BDEDE7AEAD0E3A72472B218310D9228AE0BD49120DF3345B692104A4AB8DD184
+9BFF43CBEB81ED9A3106FC37313D999EA370A496F4641297A0AD46AE9EB096B5
+0AF904FB665477A01A82FF8C5688FC440F19605CBE79C4C2A1C486B38FDE1BE6
+9B97FBC8259F5C04E05194B3DB310179EE7B9DA254AA95B84009C690E7CCC345
+A02FFA0F7A93AFAD513DBA70252670302B59F7072E2BB8B777EC21A77D414C57
+924A89A75B4695EBFCD6C5FA88133B86D1CF1611955E3388D4F7B021BAF41316
+B3D36E78CB9AF84FC2A7DB3318F6E3190C61A833263AC922BF23EF74335CAA14
+787F43C508C7A34292BEEED00A3FA72BD0D5E32A6B13095CB83A5DEDC585F3A8
+693F9EF463FE957CCF8A49C453FA652EB7965FDB2DFA27ECB4B045CF5A780DAD
+D3B34310EE042288D2840F82A095267599D21A58F2C8867582673EF18A548882
+A752B8EAF40AEC32CE7E8D8A73F5EDFF2435FF4F81F20C75EA42DF564DC8E6C1
+DBE75F7C54271544F4114E1F4193C4FEBFD035E3F4B34767338FAE9816487D1D
+CC98CEA8A4780537AEBD28B8D72973CDCBB6C191E849087343D946DB1B852925
+8A212E809DBE1603A23CBC55149E702F0A90CE17650112F3366E4F8DCF18F210
+3260E6184247C3BAF00B5273A4E27C79F002427F29D62C67B96A6AED0DE2C7CB
+196C5C422D490567B579210D9F4716CD80E8BF93AF508FA2740A926F1EBA598F
+2B0DE0CA18452807DD731B888A23675069ED353FF21188BCA446DB9378BA1E83
+C41C6AD44052F6205C1ACFF638CA89B701BD57DB927A87150CCFBE68FD2BB193
+9896FD030F7E7EAC02CEF78C423B3B1599BB2DCCF668167DC30E33A8BAEE560D
+B4224E2237ABDD83C8B6300F399D0AD0D395687F88CB380E17F060A6166514D8
+5033648EB7F6F662BB87B2DB81F71E4E75BC00BFD99514FE1240F497F3C0F27C
+C44B4BD620D3DA02202AC0F2BB46A89B0CEAC76655CB9DAF2F4E00D4D7DA46B2
+300F73B5472CFA8E6C6A79B5D56C39D2358963DF68AEAE5D63AF5E1A1E66214F
+80220C2F40DC5553BAA66845E19B1EEA43AADAE70F8992A96A351D856841631C
+3802E2CE1AA9917BD64C7F7E73BA5AC9951758E028B3673BAE3D22FCA93D0109
+6DC4937041069971263E4EB241B8160B4AC676E950032E6064D7274647BE01BE
+C29801BCCC575F56DCE6A334DAB8389FEA66C3E05FD53C54A804F3C78D025F2A
+8226D9C34B6F7CAD422D0C0BB828A566757E38105100227803567509DF25A8EF
+0D17AB083397DC0314B4F958DCF54A771E80F75F7F5D8BC8654165074576558D
+5040045C0950B2B46BFDB032BA97A51EA3EA76D830406C5626524ABEFFE6490E
+042763BD2A3CFA00D102E7068F7E91E84AE7EC12E505829EF9765D07DA2BFE47
+19651D0B8A0F5656DBAC91B2F7D8960F37562FD40582CB0F24ED5B6E98ABEF6D
+EF52BB1BC688419499DA7C70B3B8319D5ED65559A802DB82BBC903ED89BDFA76
+8948067D45CDEC3FF7806AF1F6752741FAC05FB4D568BBB6F6E02545A044D7EE
+4D743B45F25C223D4F6D8972DC3A65D4D27DB252333C3D33CB3442A025FB0CB1
+58AAB3610C9E83C0B59264F07047A9471366C980136E76E6871893D3B91D7172
+AAC9EFAD7F0849132E9B5F9E18ADEF2F8554C84190E305A4572F01FACD2978CB
+973317E9A7AB839CF384D7F0AD35F20AACF16872E81461AD361B24149D1B4194
+BFDE543A5BEF6F6B0FB6E03419497FD16ACA2C472B7A720E42ACBBA159C985EF
+D51CCCD9A7A35EAA0A3AACB285D7F85A8756CC7554FBFA889684E2994B32777A
+1F60691B638856208617672F61279FDC0CB77E7D22A93565E7A78820FC3D6360
+95ADF71648EF5A0139AF18FCC0027DBD4252B47FEC6CC632C7E7B4B7866C08DA
+3FD28178588B5EE12F67E5B1AF907D20A3B99B197A7137B3DB433B8D20963CA7
+AA213C126A86C36FED4F3D381FAA2D62E3138DE1C43BAB523FD0114B8939EA0D
+C7F7E3AC0A4D8A97E1B2F2926D834E611B177254BA3B1C461A0EB8111325569F
+DCD8D557F546DB3D7DD6E3868A635615B354DBA5E22A7A39DE9F2C4E0FCEE250
+0F535C72176DBD0A0AB29668CCF535BA186FB579B8D7730A70B173CE18CAB6E2
+FE59C252F347315FBEDB363D4113EB1329F21112940938B5523E7B15C5397510
+404A6376572103992457A3269B8467BC889EB9B5FF5D7B6BAE36720D7F07A5EF
+354AC505AE51AB1AD4A805CE2152CBF29CE8345758B58E810678E05186BEA711
+59209FF23EA2F71FEEE3F2B8BFE12E84E1E14E96C0A2E54C28169C4A3DE59073
+00DEB59914190A6E140E6D354DE6DA17BCD6A0F29A55BE409F970B7C12017905
+D6E921400734BDB07990A6F8442AE9029AB4644A20A643DEA33D9DFADA766982
+DEBFC879BE8D345915E3A8F6A1A2BEB74F09DC36C07DD47F6F4070C54C844F45
+C532BF3D1C5A8DA5F593727A70FADAB33E4F3408904903AD09DC205A1BFC1BFF
+C776DD25B603E953DAA435D8ECBDE19F3D080E24C4B43E3BF6D64565F152143F
+D682DAA64B6B2FDAF33660F48623E7A838AE35F19446277D7ECECDFC391F1CD6
+702C30D2F40372DE1BAEE8C97E4591717C6EEFDC1359F33719E21BC4DBD0324D
+1472D7D86C4240D3BF574B583CE2ECB83E2F7A7A1F4E34694BD77E5A7F3A51A4
+2322A36FDE5F72D4DDF51909A7611989BD0EB53F663075747765A7BCF6D3D43C
+81BFE4E6B54128818D721F5EDDADACA2652BAD70322AC0FFA00077464D8B0EE7
+51A71370B59DF968F5B9A9C092CA32B571833D42F968579954C981242834C9D1
+D906EE885A79C59520D118F3B1376C2720831C6E05BD5F9A28E06A1D47F7A266
+1E1C7CBEC3EC297190AC3951A5022E8A9168D4ED19D01C0D3441126E66B740F9
+D49B3DEF0661D28B6175C9568A92C6B010B22AE36BE779359A120838A740CC69
+6F17B3026D96978D357FF0BB5C0A71861BB3807AA8FAE529186084B65B95D8E7
+90D5C1710E9E3D701BBD089AD7C46920B5B30FC269005E2E8D37F7A006C1B73C
+A53F987779ADD9AA256B095E0A0F52E391B51FE23B86C01137C1274D2766CF55
+907DD5E0BDF2C448B117A4E9BFD7CF5301DE48B32061F7CA367CAD5B37328869
+C54B386699CBF86755CD211D346AE63ABA29F96BBC97AF5C17E3C43D11EFAC3C
+26F235C9DAFABC199002E888C027A55642EE968EA070DCD5A1896288B8609D79
+632F8E552AA4AFFC3CAAAF4951677989C9F90F1EF6C7DC613316FE79902E6CBC
+E1EA81CB313203A79B99533A5DAC3502AAD3BBB4E98555500BB138B3D8E2935E
+B4A391CC9966863FB817C546AE6B867B0A7FCF44AC88AD8A83031BCB2BC0ACCF
+954E18D1868B7F25FB883770A7E8BA3843EF3DE2007AA4D84E664534A1F8E532
+DF8575DD428CA374CC77F7FC3A6458EC94053C17C0000AB34F6D74BB61869B2B
+34B3DE4C86ADDB9C4A633934021098481B7906ED632185E6845787DB03C7FCCC
+258FE0C53C65E4D6930D51BC79D33A0DDD3850CD38B4C3291BEF0C47BA63B1C7
+E6D1870594163EB654354B763767BC0D9426110AE30CDF35AA188943AB7E7E50
+4B21B0B7D0028BA9AB62EF574362C87E4F7B8ABCE48757D70D5F658B3DF02FB7
+C78C03B718B7AF729F5A25EE6A6417D2AD3A7C0AE2614FA5D0E2D19F7E689B7B
+EC582923819FED5555A38DAF0837388EAB0503225345B6AFA6B8647B367DD932
+09F345A747B4A2F2E1C71D2FEC9168A592C25EA7334F5D369EE1AD6A2BAFDC1F
+AA85BB41EC36279752FA0F0729D6941F29CD275D8B1239299EB3B3F09FA33094
+EFEBFC2E3FE12D774C7824590339CF3744015500D64E9A52AE1E9F82AA667B2E
+DFE2B286F86BDDB4F4B49A10009F68C5058B10A016003624EB08D5229E89866C
+32DAB2D2703ABF5915899A105C4CF7ACF0D84DEB0EB23BF89B3785A780FC57A1
+5EC167AA62BC3F7A6BF4C12D4B2F1A7B7C371F146DD75FBA48D7A01E1CC9AABE
+7EA5620F304AD16F365176FC093AAA1139811B555421851D1391CA34DCED9157
+C49E090A5E7A7A58E4D580E5692D70A594DC808EA1FEB2E4B93A3EC4ECA8E211
+CE69CDA536229B536C4041961C1A3A007F0275F8C131F0410DDD99E5B491AF2B
+E04B1E861933435507332236DB0B61F1B32DA5CA24C963EDC3BDE033014856B3
+5AC904D7502CED7F7055511057076FAA7D52A174BC81528430871D44F1A89077
+0B39F60A63F88DC1B0B05E8543681B6F9C31A9C9D866A70A855E266D4152C476
+926844FE291E061F8A9690837E49A3C09C582E19203A78152328E120F1ECE4EF
+9CE7E1CA40B1678DA2BBB3963EA2C3C76E39DC540EE93F0FD89F4139D7972EE6
+C87DE98EBFA8E23CA1696399CC577B4088B00A131D841461A947BF0DC2BE31E3
+996421DB0C767F3642709D8D1B410B306118B66C48FF40E566B4477D1E5EB993
+EE166EADF2B058474E0D7D01FCC92E401EC0AA0C18B8C9D18E3ED48FE8F4A300
+D0FBE645ED053C05EC7CFFDBC04F7019B456CBE5CB9B5DB27CE52BABDBC8F95E
+68A22B51078396C5F96FDD404D23AEE7DFB98EC1FE46A5752530E952EACBC663
+F15D3097C354A203CF2DB2CA187AAA10AEBED406029F4049EEEB184C75C90610
+56A43FB0D51E6008B326402255BC10A595F62B3B6A03F6483A5B4862BD170616
+7960B1131A7124DA4337B48494DB4BA55B1F7E31C2447B0BEDFAFCB72195A196
+72C1E568BD52DF926247D1C5D0259D285403C5D2880FE315E1B9936170FAEC07
+25EAD056F0C79E03D1FA2A3251F08E5AE3414C7C0E030F8158BBB4E69E9254C2
+712BE1FECEA8C3E68585670BC8B5CC36FECA9EFAD05D2F355F420BC15BB4E508
+4BD88C7372B3BFA4FC6E1335FA00A1ED4C9553B11D7FD5423227C764791E539C
+EF23E961D386FA73A4F65BD6689110884D95F90852030EE3345FB6879730163B
+45C2BC62B81586D3AE6D70E489799C230145668ED0B70CF5DDDC20B539696A3F
+903EBAED0A8EDF3F6A28BBD080C450615A4F4CFB78A2A1BA0D772B9D4834BF70
+355F18D4901694D00CE161EFF8DE55E633661FEC732D62AABB31F4F542CDAC35
+2963DBAACBA34166AFB6BBD3A533956E86E332646D0CCE49B08A24D66F754347
+A74B8197F617F4EA6C28BE7E355D0FAD4900B36FD24D0F08630ADD71707BCB1A
+273452A80D5B1CE2F3B5246975886BEC0147CCC04B9C0846862DA51DF53DCCB5
+1BFA7DE375D95AB585FEA21B10AF81611B39106C8691C41A19E1249F84D3DEE3
+A2090D4C5B81FC8B22C42A57E57144D67C94F5590C1A4CA53E765AC37FE0D4EE
+8AD7C008ED76505CD5B7D319E164B498E36ECD888B02ACE9FDE2C3277075010E
+C3C92B27F6D436983231137F5DECB28F641F0A73EC9D2B9865D7957364DBD1CA
+F8B7304C99CDBC5D54772FD02F77119343340C4E16738829FD15F647F9A7510B
+FAF132B147A8ECBAF21DB60AC2B49ACCDB42D0BFC1905327918FF0A45628207D
+8F0D620A36B2E3D147B40463A87818C8FE7E9D881FFFFA5E4B29108FD68FEDF1
+93D5073835B94ACDB191602DDEBC69D374F07CD01308C22CB2D710E4C412608F
+3B15C0B711298BE34CC1F0DF3AF56AB825291CBADBCF5421DE099961D4660EEC
+8BAA5C0D5754E854FEBC24FA7064AF05F7845E6171ABBF05E1AFF5ED836F25E9
+7DAA2B81623C7FB01AF1E03A2596199FFB11D0C9185BAC28112A7EDCD51304E7
+FC9EF7BCA0462BC200D03BD000D9BA6F5EFBB4A219C6D11D98BD19035D295B40
+929AFE6D935D32A498DBEAC0C5D2CB62A8397839AD72A3FA37364265D02EE470
+35C95001F084EE42B46A8AEC939D6B18D0659F73A5A45A46327F41D154450815
+5F5541AEB056D041B5F2E7205F05DE4620E364CD7BFF8B17DB04D4A4615D1C7F
+689E189F81D28415F43BFE2449BFAEAC3478F94771E4F64EC193481353950A9D
+2C68866DF4CDAF0D328D7F5DE9D9BE98A161F78126D4365B1B4F743E95F28017
+A535EEB56CB8E0F759CD211F9831529D03AC51B93CF868CC630BFBE18DAAB0CD
+134B4D3D24DD73260B27A1390773BF4C39EE13F0D53C4DD6D263E9BD99054898
+936AB42AC8F1B51A76CA8EBA236E3CF6FB22F979485C2039AE3F0F874BA8AB00
+AD80299F0847EC82810B49BF944BD997C16714565407C2D95E4AE343CF7448ED
+82C59AD1B4D949C4788443B903290F35E4F45BFB37C99169344B820D8FFD8E74
+EA03EE65922CA2E3A4461C7C4CA3EE5902ACE0B180C3B8EECB43C93FD999E99A
+3FC74DEA405F32D35FEFEA5D6C9F7D9781D3DC39D04223AC98C4972B3C3B3C56
+FC99922E33E212CF9F4E51AF654DA7888DC44EEBECB4C32AD5F113D4078B4812
+23EEA47A7B029B870A26845DA4806CF9984159F146C7686A1C064EF0E2308EA5
+EF15575B94B65D767E915AA8E2F6DFBAD9A5F270AEE49D627C719B52BF797405
+5CAADD41C20B18D33532AB2FFF13BB7F43CD7887E54D01BB39D7CD21C16F32B3
+D4BF3C0B2F1E594BCFA052A94AC9A0B6C02187CC7780E9E06A1DE36744D56FDD
+724DF5A896B9704845ACFC1D843D3DD77EA40AD3DB3DC4D9FCD05C07AE91DBC1
+DABC563F3AA79B572CE97B5F5016F5FC014DE6814C283A56C6A419C73BD3184C
+24F87169FCD7F3705B154863C0ACAA786A6B2CDC5DE0BA29ACB6B7016CB2A923
+4993E5F7EAC92531C48A9538AEE9EA4429BF71FE4C84D0F3C62E39838FD2D9E4
+3FCED52F5EC580C5EFC83BE7D254575980602DBAE4BA96B7BD66B742795A9949
+F76FDE891A15520114FC60C8D5887519E772B936B2792A90D41AC83A0451C64F
+D2A7A43B07804A99276157371E5F59D0D24D799C3DBE02B507D763479C630A6F
+C136ADD78FDB3CAA4E7E1E14F4538F9C395045CD5EB82339893B5F82CBE41F4E
+124442545E83F9FBAF61050B6243D8C28B40568799C751C516EE9E2D37EAF4AC
+C6F06FAB5F2B60806FF7F75E2A210610C0EE5A37EB927E6596125ED9403CA8F8
+6CF1BAC24EC84A1B154B6B9739B0F649AC0EA18A1F036418782631FB1C8BD838
+9150A304A5B9485A9C171B75ACF421201D74C0C2908DD2C08D4F1C2F12BE9C71
+89EB718F2CAC46CF2F1FAFE01D3A83EC5FB66F5BA1FA8A295AFE8B8D65A6CA97
+2A4C0061F39744A0A1000C964884B92E0DE16D09CE7A5755DB4FAFA94041A6F8
+181A2F548D9AD56458CB841B80D47AF0249EA10144CD1F11A7D9757106AAC861
+3F8C884A366A78BD4DB4C46830285BD02220E6A6E2B8F10A4AAA35A2ACA759D6
+61B0C7FD6431521E3AF10F7720EFF73F18DC16A9B751428A8C84FA7607E65818
+B7A586D5D347384B33FE07B13FAC8D09CFE2DAB15148045A8AB6BF5B3BE6B3E0
+1BF1110DA237E83664D07FA74838FB46447A11EDAEDCE3917C94DE1C6DB0379B
+0DA979D0EFC9FB12210534A8C6A0DD49C764337F4A6DA8E8FD7C43412DAE3361
+C0DD68560870A9126C0AB5A84AEF17EC23B4FCA71247B6615784B41D201CD774
+0BF8B3BB823A931F73E5A0A4781850954AD61A06507F23879F629382D7DE61C1
+AB726216B3EB1C91098BE8CB00F9957DFE7D2D38305C2BC54E79381F375B6B48
+D2078A66FAA6F3A87CC64A63D6A993F1195432E0B449123A4313C5D9A105F125
+1F3DEFC76FD8A6E4B5BD7865C64AA28B93D13918895B51F864B81C816E71E20B
+EDB283F2C4F45AB2F2253FB95B7C0CFE1C41D8E89B14A8F3407AB0B4457287C7
+B85EBA529103C7941D972DDE81D4706AB3CAD200E7B2BF262384EF08B7DF467D
+CFB7FE2DA32ED1D4DAF5160819EE64EBE26D462743E3301B674D37585D8A5E4E
+DB6110376E76132FBC05816009E48A73AD0D0893F3683564C8F55CFFEB4E96DB
+F68D0605A8BA5FC7EAA9B43DCA5955FFDFF840438FBAAC732970A1DD1007B9B1
+5AD712CFC74CCC98D64D681CB9678EBB0A6D7CC19529827E85A214A3A765EBD5
+D07D19EB2122BA8A5D1AE17F8632B022ED235C14B801439DE65D2A4AFE2A4062
+3E0C66F76C720FB77F3CB876DCEC40FF2240A4AB326A82BF7BAB0577351AC0D5
+3A7F2B255ED34030D3E3F478880C0E8F8C0FB114C07E4F045F424CC90CE5A9BA
+70205853B5A3DC85443814B413F6B0735596A790EEF95C703AF0A7C29DD1BBEF
+C9076B98C80CB7AAB8785984FDC0E6E2F7F0CCA11D34C116485E067FC0128AB2
+C62629F7E22AC3E9A497530E15819398155905AAB92BBE77DCA4503FD0AB8E08
+27B52387540C0276C2E43D98C3579FFC2EF324653F59652411DC87432D0B0BD6
+308106D746E21AD0EB51796DD976184736D50662053733833383AF5FE6A8E1CB
+811B2D8F1C88A7C3A26C1F9D1CD04A758FA6C7E8C1C5C6DCB48A4F3F861CFD04
+779E62FDDF9CD4407081616AEB43DFBCBC3678A83B4B89296FBEDA8D5007FBE1
+614C6BAB2F21DEAFE3B7A00748C18621C9986078DAD7804D00B1CE15D97CBEDB
+7E2A4C612293DE734AC5F5E7A63F1CE5E051DF5CEB026BD264AD25584C1D0AC9
+E1C08BF92FFD551B2A82ECBC9F9191C7F0F40D78F1C1F041FFB80FB4D0E9FAD9
+53060E8482E1C656AAC28BE1A0A42B7784D44B88F798754A6F3B5D35205A40F8
+D10868090412585EECF9A7747DF330BCA1458DC12D7D8D89D3FF10C5F9B8BBD0
+5E22D8E318660382748A539E9A694545094D2006E9AC6601C5C52C256BA1CD5D
+96
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMTT10
+%!PS-AdobeFont-1.1: CMTT10 1.00B
+%%CreationDate: 1992 Apr 26 10:42:42
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.00B) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMTT10) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle 0 def
+/isFixedPitch true def
+end readonly def
+/FontName /CMTT10 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-4 -235 731 800}readonly def
+/UniqueID 5000832 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
+016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
+9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
+D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
+469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
+2BDBF16FBC7512FAA308A093FE5F00F963068B8232429ED8B7CF6A3D879A2D19
+38DD5C4467F9DD8C5D1A2000B3A6BF2F25629BAEC199AE8BD4BA6ED9BBF7DABF
+D0E153BAB1C17900D4FCE209622ACD19E7C74C2807D0397357ED07AB460D5204
+EB3A45B7AC4D106B7303AD8348853032A745F417943F9B4FED652B835AA49727
+A8B4117AFF1D4BCE831EB510B6851796D0BE6982B76620CB3CE0C22CACDD4593
+F244C14EEC0E5A7C4AC42392F81C01BC4257FE12AF33F4BFEA9108FF11CF9714
+4DD6EC70A2C4C1E4F328A1EB25E43525FB1E16C07E28CC359DF61F426B7D41EA
+6A0C84DD63275395A503AAE908E1C82D389FD12A21E86999799E7F24A994472E
+A10EAE77096709BE0D11AAD24A30D96E15A51D720AFB3B10D2E0AC8DC1A1204B
+E8725E00D7E3A96F9978BC19377034D93D080C4391E579C34FF9FC2379CB119F
+1E5BBEA91AE20F343C6420BE1E2BD0636B04FCCC0BEE0DC2D56D66F06DB22438
+452822CBEAF03EE9EAA8398F276EC0D92A7FB978C17805DB2F4A7DFBA56FD6AF
+8670EB364F01DE8FCAFBAF657D68C3A03112915736CEABAA8BA5C0AC25288369
+5D49BD891FABEFE8699A0AE3ED85B48ACB22229E15623399C93DE7D935734ADA
+DA7A1462C111D44AD53EA35B57E5D0B5FC0B481820E43222DB8EFCD5D30E15F9
+BA304FA879392EE0BCC0E1A61E74B3A1FC3A3D170218D7244580C7AA0DC65D19
+741FA5FE6F8CBF60250ACC27454BBF0897CA4B909C83A56672958752ED4B5E79
+E18660764F155E86F09EFA9F7685F2F5027EC85A775287B30E2069DE4E4D5712
+E7D033481A53A2702BA7542C71062173039030CF28D8B9C63B5596A9B42B33E7
+D922944A38713383D3648A4AF160A3B0C8F3379BA4372BE2E7EA49AABA75AEEE
+C5DDE1D8BF68483C3D21271280ABB91D54CC819680322EAB72E1250A760BC8DC
+FF798F2ABFC4F3539392985C4CB324B00072295FC160818BB0355FDC4F12E39B
+984826450553E3D271F03D8DC2D12A92A4D32034FD16DA13B876D88C8C097384
+46D8D7E41CA1A8979F9B07EC3337E70CBBE3A377235B04C79BBBDB66CE1C1A41
+89DAB7CE91F2FC0CAF6DDAD09992D56F72299068192610EE3DE5DB7CF6366B4C
+D74F414484DCCDBA449BFAADA39D0F27574E604E31CB513B18E3821A33076151
+C2BCB6E957C77A0AECA48C587ABB5E8C7624D56B32F80BBCFDC874AAD6EA5119
+C9B06886F08CC7DE5400E0F52B07483FD4BAF26C1556CA27B259FF3DDF71131F
+DFC05D8B14C28F2073C460B5011B76D84F7917E919E50FEF563B5DEBC5CE6923
+ADB72392C98D03CD978D3FC207A52B91E267E7ED8BB4531E8BBAC113DA68765E
+E23FA502BC71CFB91E4FDCA39BDAEB7FEEC3588B1108CE4A1652B770375724A6
+508376586216289093485CDDBBE68956210B6FFF3953D097D66BA31D19CEF2A4
+35A33AE97547B81426E58F9FFECAB633C6433E86C32130665210F44F10F3A2F4
+EA31540D0BC08EA4DA2DDE3E8CAEBE52A3E8B037632B235D4ECE3CB797A5A939
+12C45C282783F675060040FFE2676A7ED903798EE3B86644EF30D3B461D4EC3A
+A1D2E95C02FF1531D93180F66A13E868C9E1FF1722FEF6C4F304921961D4A10A
+6AE943157B1B0E8871BEA71162E5246080618A96D5B23FFA8F420F2AC74BFB60
+BFA3BAC4AC3A320887D4090FA3EF7071D2E1DD5D70DB98A01B6D315271D10F2B
+3D9256D96FFE8D8BA0F4781B74490C63686397241640B08A08FBE7CC9B1FD0A8
+21CECF0F994CC97AB18411EC8745F5A6AF56010C22E73CFFCB45B82DB68E6552
+2E57A4C06B96C55031442EE1F53373C50E14657ED320D9EB3820144C7EADD2B7
+564578EE778AB577C5BAA6CB7F9884D91F1EB53F032AE4F0A8F47A7636AD0573
+00083304E10F77C0B5C7C390F436CB4C0E68CEEE4B1DECCA113BDF28F21B61C5
+432899378C52824F854212F8B53B75ACBAA50F74868CEF45E8807CF574DF2B71
+D37AF61581497D87076740A67F6023199F3ABFD651B2944306176F7AB6659154
+7AED74DE897275A2033C35108B1F9153B113B15926004A87B2E9415DC4E3FF43
+37E1690D9608655858EF65FC29E1909B2FB2EC1D611A14B3227111E903F1534F
+B37C2EB3064720BB08497C43D8C0D163A9C07E6B8574D344B27920DF3978B879
+308CED51A761149CA2ABCBCD1503985786DBFEAFF4EF1AF192A501D5BD5DB977
+4A7BC14EDA6C1E3FA39FA44F19E0539CF71B5229EB6501F9E72123EB775F85B5
+AF01BB9AAB4DE2C16801062A3210C30B49B828C38FD6A0D3ACDA395BA8918026
+8FEA28EDFE0E7C565FB808072E59E324123CC6B10BE7B3CAE2A2602AE3B5D2D1
+9AE01B70C880291107F65D0A6D6AB7EDE053FFA668817550FAF5B24487C0ABC9
+DAB06CD956F1543C4722F4272BBA8D587D35E5953F67AC1EE717ED6E882B8A34
+DBD7DA4CCEFD909FD12D798D328283295C2F226945BC6AEE697D5401710A6EA2
+264D436BBAA8A0CCCD287F286B1FB91498F9BF5A033141D1A0E6A7787DBC2CEE
+44D96AC5DFD4C7CEC23798606233CD4549BA0BBB7B07282012A7EDAC4E9387E3
+9247A698B61860E3C6BD286C4F05B64E8122F01D9483D01F616B39353429A74E
+6B6104E2541620398002CC98BA5D83649D285914EDA94105105C247CBBD9832A
+F480D7BA6227C7740855EB20A000C99E438519B8527D004703198F284D52E67C
+980B48C0DD7B1A623B2C614619AB23490D7A76C39023F943BCC204F7B355D5E4
+CC0599C2EB8A14632832DBCE06F67DF4227A32D476DDA2FD50F1F7856B1E3038
+ABB60C2F411DDD3DF655D4D8EDC4C6DF1CFCF2F5754727067F6468371A1E6385
+C46E473CBBF1DDF793B22AEA87339DBD90B78DBFDC7A41195FA3B3E922CD95C2
+9CE17AD5804E3CA5D0CE164170AB55ADDC62535C1A4391714A68E173D7FDA177
+AD31AFC7671C4BA088C2B784BFA9E6130A73F2B8CA776185C78896227FB72197
+5F1BD6A52A074BF981B316F3F0573D66A10EB4B1B8351123BA1CD2A53956C4E3
+DC03516C866B190BFE022BC9349167F49CDE6E9E69D1F4097B0EA09537D5B450
+CAF31043A7B2A7A02BB01646FFE20063670DEC9CF494E31A2569ADD828A75A0E
+00F8DA5632E683E7FABAE69F56AE73C90518C4B966C8E5D9B603EBB286C68D22
+7791B58334A3D5B1C273C801898FD3DB0B6B0F0BC2AE350D5BD43626B41C0351
+4F9E3D7C715459911D9990E8CF7A6B841BECE6A95DEFF4E4BDF72F6DD0B59FA0
+1C46D962C85740713722F389E0CF482522AC25ECAC8951482CC068ED806A3093
+1F89EF7AEB5CFD39C3C56B3ED29EDFB54BC054E96CF402B41F11AB6E37375A72
+B95BC87906B913EFE489200F477BBE8E81B2355589B8DFC2CB367D9269C15F1A
+F26A891C3D766B273EF7E739378D4AFC370DEF8B2746F13C8B6094A18D5C9F0D
+73404A4507F2906BBF4679A4010B7CE6D95F3E8622F139655EBADF99D416B9E0
+FE285CEB091A49AFE8D461AA6CF2A588E41B81D372AFC6AFBF37E7A5C6357E6A
+DF90DAF5422AF27B7C84758413785DCCC55729BEEE4372E873D25D8FF4665D65
+E4A7649AF044B816EE19E5040E050C410E77A8E34F7B77D534E87902098DF392
+FB0198DBAC7354DDBC1491CA12230D36843AE4B096182E66E88AAFA35443AAC7
+447B087F70309E56C789880F4834794457A7135FD2D371E68AA2ED82D13ADF7D
+5C15FFA92A1FD7E71D72782A17DF39B5C12C24E725C18BD96CF6CB1603B9C919
+AFCB34F21797202A05DDD93F574190B67FF37499BB507E85FA94C6BA314A803A
+4B783A3FF0E1909FAC1B8EEEF916F607A413FAE8FDBC031B37D09A26162B42CE
+2B77AAEFD746DC69C641E772305F2A226475C82E27047473E3FC0931982E5021
+2C54D0F2FC683CEFFF57EB722A80A361C325389351E9508EA6C0966A2D474CE9
+10D90AE95B8530B79A1A3B2456AF8AC350A1DD2320C3E65F482DFFDE29D08F22
+B5B8B48B0CB9715A2CE513A06089B62BD546C3E3C7D356B2B84D40BE45338801
+5E7453E3C126BB04D4D73E4C37951E2F02AC49BE337E0D8128033469DB4068B4
+AA49D688C95EB90C209026B14297F52650242AC83E894D6F5D41DE112E87F28E
+5D5B1048ACEA3D1C547DA6FC04E017590904FF767A85A53170C14DA62A75EF5B
+35BBF0EA636CFE401EF6CD36588940E8E467F0D86665F7823B1DA1DD4BE48B0B
+A0D06D72FA6EA4BE6A2825FE9EA69091A54E0BB7EFF480A399B413663142D344
+A6CA52A96ED61DD2E7B82524F025461703984E6C405B1C8FE8966E37CBA8D953
+5CFDD1A54641BD34731A54538806B15636069C0A0B81864C9121EB3E37FC4FEE
+10971B57CF5FEE257F679D104FDE8ABD63863699DC14392D8D0A63F4EEC68356
+3B3413AA6AF705E23A7A5C63F0CA591E62FD7C1A4A187649261317D3636CEA99
+691D64B1BC399759E25835914314E0B06B0A31DE8F9A769A18601FA3EB7435A3
+B2AA9A1051069CEECCEB2854F6E6F7FEB662639349CE1D52D1F6AB3E90FDF3F2
+89DFBEAC62B982801074E9D4CA93F501F9A98CD4496AEE04EB4E9B04892315E8
+9FF29FE9F0FA5AEE7C9C0870432F941E75C9ACF7E7568B5DDD26921205FEDA2A
+08118AAB1FE6887D813C7DA76837743861846E7F4AE6D3D8D67B6BFD93A04C3C
+18DB4C768C783E3F1E6D2758205E915755D4FD717098CF5150FBAB7598D4BE5F
+07A5F289BF96216D7A80EDF4255B6394D5994AB214C29BE92007B6574B40A82B
+054C4E038E0678B30FFC81385F94996F8CF0B8BC3E6DB963F3CFD69AF7154DE4
+5C7A1EFE6914065D398A6E04670C7E7D5211FD2291397938920C9154772623BE
+CA7FB9E6832E42A52D5FE74445B3AFC87E43122AD2E11C488AE3596FA2812892
+711B44F10EC6A936548221F2D51BB487A9DD0D5624A58985E440BB76095D3FAD
+F99C958F560F39907335F62C119837B0F432554BD50CCF1F0ACB5E77341E4277
+EBEB5BFE7216492099DBBDF53AC7773A0B8572B7CC97CDC6C4D35A5B59609756
+41248A719F44441C10FC8A3312391E0E274601E68893DAB4F622BB6E9F08087B
+8C59FD2AAA7B16B722F0E933E4DEEEEEC1450F03223AB9F95FB641956AEDBDF3
+83933B2BC0E0758BBDE38E12265277839829A3D36B5E63C318477DFC348F7522
+94A4ED86E72C1C7CD9EF0FD4E7748232166E48CE47D99EEA02A49ECC63C3C094
+DA480A66B43CA1C94759D7EFC3172D6FC71D658D2B6DD79395EB6563568733EE
+11DC48B6E337B619411700933F5BD5E9D669911B9D0A51127F799A33D965360D
+45A3BD0AF43A3AA794270D0A43BE363A76B3FE75C60EBF24608F9463E2F7906B
+F6A44622EBA71F0A6A0681D60A05AF6C739380813E1A29B2D91C324E5B8E048E
+6BFAD6A59C165801465801881A537517C8F867618991B762A792974158970FE5
+E4613A8BD4E3D2FC11372BF5A899CA2152616093D1AF1E67CBB4BD34D67C2E11
+57A0036494E96D85AD9D0ED18471065E2E3BB4CC5E069607845C4792988F054E
+2988AEB02ECE5E12C956E4C6318833E6BF54771839C634CC8EF786717B3968C6
+692113EC62C6FAFD2B8324F57D334B371BD483820DED629B42BF3312D967EB55
+64D75B5F0A0B271E6FD03708E971FA6B9CECB028E7B14BEA6A3F77069FCD189F
+6CF03A77E2D2DA5466E9318B885FC6A29A35578D49902F3DC40ADCD71D08BCC2
+C498E0301F487022F9FF4EA48A6836EEDBA4561FEA63E9ADF4700DB9AE46591A
+B950EFB9EA1C844AC7913CBA63A190549E0596DDFB05C2193F80B32651CCE017
+D05D1BDB19F710000C135ED041254341E2361E45814798C2361C83EAA646F48C
+F7C9F3C8DA51A078205C9A9811AD35C6DE5999BC0C0F971B2D0E2CA158173BA9
+31096283233FF0A927E3BA0CAE184CF94D90E243275F0D22D2DBE4473B60CF55
+AA9565B9019FA10104B8D6BB8286B26DAEDDF72FDF7F647924C355BDF89DA83D
+015F6781541CA60EC430509966C98A9EE3A27B69F6944CD055300CA2C8FC325E
+38A6C3F19DC6D04BC8814472D2DB061BF454D24212C8C861536D6EA0FAEBA344
+8DFAB4585440DD8F128733D38E25AC89846A26FEF8E0E41FE38DFEDFC61D6857
+FF7487705E583DF137FF3EA0F879CFC1E9B7C48266B226128AB8DC3163E153A6
+6455A92ED457EB25B2844E1C146BA9C3EB1F53BD6E9F470AF10231F5E4B7ADE1
+0F9A0968095ACD308B13DA73D2D174FD52C358232FB50ACB8483A7E4DAFF7ED2
+5D2CE7CC5F4E4C0522BBF83E873B1EB99A7CF7B2179D5AA64A86B974EA701856
+8794FE1E725D4E164BB8C0FCB4F4961CB6852F95D564AFC69623FA2E386722C7
+7039E45DFA863DCED532C099D0A285469286B3D7A6BBE9D1FC3ADED2759ACFDD
+7844CAAA7AFC361DD73C086A05113F57B574B22F58818144ACF8C214A0526202
+2FF457EA1E8A806F7A953D5488EA18FDD4A02DA42DFA8D7481757F34F4A09FC2
+0D384FCEDEADCD7A72BA23363905683CAD1AA6C887B21FF905873738BFA77FAC
+C4473D40059C37E87207A5CE6EBD07E0289A1ADA418D8963C07A912B6A7BE1FA
+43A0A2745DFF5AD54BEC598E89E4F64D4B14C6A29D67A3080E47FBA6BC910BA0
+29F8FE56E36D616CCF38CE82A9FF4010092243A87BEF63C0B9E1BE2DF7532F34
+AF05549F98EB90B98A5E007D279B3E3BEA315211F153DE3864BE53B371F1F690
+34675743E3E92D7DBD817E3DDA9CFD23DA14157FB1F9C8A465A141BD67391B3B
+CA9238AC5A9DF865916D377A84995224AEDE0B05D32A5429E6FA5D167CEEFCE6
+A047AB4063651F064B491AB370F2BF8D3DB5D7FFC8C776D7B4AD0DCDD203B7F7
+C2A4DC329B07080AC2A585DF681CD56EF8B1DC5F3E26D59FB2C7CEC23E4DC9B4
+26ADC43C61CEFFB75A20D81C55A125636FFE2993573966247DFE7D4F80349AEB
+5AD93974E91F868B21042F2B6DED3466EBF083D00912DEB65C45EED24CC7CE15
+3EBF1B21AB956446A403D7C2D05C36E5C81C0C41BF46752A98B5237ADD6F54A6
+E3D623AA6CC3DE9A46B85105DE9D0FCEA1E912199CF84610D6FD2418C1AA1F10
+3F714B9A68E02711DA034D7CE9801B8054DC62743B35A28569B7092072B79DF2
+72B263F7BD63D1213A7485CD244E8F4ADEDA511AEEAA5DA0C438D5B483326DF5
+9D6B6C29139C311D79BD0DE3882217E26E892DF6DD95631142B05570383E7F0C
+DE41D502B9C8D8577C0EF169B92DDBEF0101D67371024099695EDC4E800B51A7
+9518F44F6AF390E425018AEC88605C6DCD7171E549CD53728C14D55145B92585
+32DE57E6D8496A2048805D90D31A40AF71DB76E205ED8241C2BD4D6F9285686B
+10EB4D7191FD9D62108B3839281AE5FDEBDFCF969AE9EE628A33FDC3CAF04F21
+9BA1FB49DCBA2E55E54FC0E731D52249413AD01F7A76FD5AD9150C67B016E0C2
+B71D5B2CC286FF56944EA8FC38AC3F5123E2D41F146C4B4FF1467BB29A91AA97
+993D7977A34F4391D10B340A4FB652F1CF35D7FA3444D23381E21329115B3FB5
+403458BF53F1C2393A84318718ABA1C171A817132FE1D54D04DE271089A35DC7
+AB3A28E6F190310F278F8AB3C76991CAE8DAF6D67BA11CB12270ED9A64808880
+11023C606B17AAAD2CF549A6052DF5A953E4032D589856FC6AA7BA76F7E7B95C
+1207ABA1FA19440096D0C284E4C3A264CDD273B91819FD53F2F5309DEC032FDC
+BC47BC249ACBB17A1850A0095691FA2C6C38695C25EBE34AC4990A13C4C9748F
+72509344B729B9D0C1919E5CA9FC5126C41B106123C6DF13E53B7A9230D5A4A6
+0AE1714618E542507A807E61DA4E3CA39CD2F00446985D604E14185BA5FB5062
+866D1057E2207F30D0D4F9EBF00440050A0D775D7FDF8ED42E92645F8603D07A
+75CAA82AA648D88E583E61F8E2AB6427B5549D5468E4D32224281DAED46EAFFD
+448291DFDD8A363F8F0CA99C74624BB7DFB05692F2C4BA36A79ADAE7370E2F04
+89FC3A6DF3477A8087B158265B12B0687CE00715E0806EB1BB2206CE0670F4D8
+6527396AD71D13573395891A98D2CEB15245273F0724FED081F6C3233C956BB6
+552A597C9F918C4EDF59C90DC4C06A6EFACABA90EE060643C6D21B5E7DBEAA81
+ACA50FEC773F74DE977C8436181A28C52E16FB03CFBF2218EA577E4159F89D86
+E24546365BCAAD0EE70FAB21200C3F8BE2C17303DE60F84BD6DB807B9EDD1D48
+0AAE32FF978DBB80E953DC5872A2485ABFFDFF25E4F958AEA0AE124A8A1277D5
+B4D7C8C611ED14DB217930350F5E1928A70B9FEC55CAC51F5585C46E31F95DC1
+7EA81388D849BDD402CAC1CA9D9F92D7D622448DA89D2CFE455F6ACDBCA80642
+EDC0FEB9DFA3F1EC8E32BB4FDC73734B6ED3783A5DE9B02748CAFF9BD0D6C44B
+70B92BF071F5796BEF63BFFF906A948A4995A2DDB2895A3ED6EC60E928871030
+AC4D1D47D275F498741C695D1A1339E201E5E2A0741EF711056B6879FF5EBA24
+1520EC72A9E2F12B3E08C1777B07F3A50EB308509018CAE629A328A35FEA0D3F
+627CCE4580C27BAA8D3FB9F289AAF9569868296FC3E6F3A220EF52511A5D4B93
+76E252EF0BC47BB477557CA0A429E6450840E1FA3EC3528D110C3CAF494DF0D9
+AC213052B6EF6D2CAEDF0E06D9B43204D7EAA63838D018CA2BEACC2D796B8678
+994A96167D1D0C1DAE4DD744EFEF9FD659A7C1F5D07BE0AFE9AD4C861F1767C1
+0508516E60610EAC86BC9FBD774A788AA663836669C8B9814E5019593CE86FFB
+03249ED026DD1BF05206CD8BB87FCF618C2CF046AB29977B6D3833409B2C0A5E
+0D5C10A86FD588C2DAFF001A4945E8B6E08CFA1215ACB03B84A0EF286810CCD2
+A431EFDE90E7A01F34935D8962741588A05724E57B25423D65BC982442AC3BDD
+AB383B282C76636065F34F741B84CA3A4F28FC6062D2F14903921CB83A29E170
+0FC092350F38ECBA3A9BBAD95CFF4D813C76A3B5F59DA5DC7CD86C9291241E6F
+F7608EED25E1FB7A1901161295118605AA0B2649543049110EB0DA04503F82FA
+B7AA814F110084F08EFFCB70D8ACF7408D33AB8E5F64C5022B693A634C8A67C1
+F16C20BED6EE3ABAB551C008D83642BE5A1D1BE1D270DF90EA01DBEC96194421
+A280BCD4CC583761211520732BB5878B6F2120BF8F61729E9026D59C83A1EB73
+15F926FDBFA260C7E93DB3439E383B6098FB6A9ED7E2DCCDFDFAE2E825888044
+47777A167ED8585FE5CAD9F01EBD5F46693F76B51615763F4538B7158F8A6026
+B3539CD0D1DA89E1B01682E68B2ECE7A2C8269E54768B4EC4F510F7A8AB29439
+CC25672A108F880699B53DAC12605B689AD1A2EA28375E16731BE2DC91D4F8DF
+3B6936B85DCB9868A15FA1153BAA4373ADB6940C349A7B620B67382AEDE7BC77
+334E675221332E83260E9E4431FE6A430EACCCFFCCE33E3033AEF6A4C751D90B
+F271283440DFF17E4EF0E02749201998D2C6E84279742CAC715FD800CA7723BC
+A66EABB7880253B3DC8F3E15FA94DC07FB95E697D25AC19A368CC01971981288
+F772BBD45A247767B2F15F002696EEDEDB4CAF83503713EA8FB85CC74C1D7DBB
+4CF54A571865613124AB85D8A20488933E087873ED72D9EDE15347E000A07B27
+A8899B88E8E1CC67F5297380B30256399C9A2795BDAFC387CEE3D61764447BA1
+17E71E47946CB7F2213F0B6D095F7A1310B302B1CEBAEE032BCA2EF9B1E2F448
+94ADBBF5A7C14577D2B5EA2405879603C698D31E9F6512E1569A3E83DB8F7AF9
+860E728377B7C50A25319E4E193EE9CD4B5634341E16319CB86D1039F9A81E7A
+0417490B72DCBD10FDB771F3AF6C2F7CC9FCF24D72B7622AB7AD12F28C1B9BF3
+0794E75A8E9C0C55DF1E576C4302610F093D4C9F39702E490055E5D877BE9BF8
+7E53CB5FC2F079D318AA092ED90B3D60F5841AB08C486C653801F122C9A0E9E3
+0A16FE297955FA721533A98149B0CC062CE5FC1EC7E2A47A3DBD8497B1F667FB
+5810113F30CE1DFAD019A7DBF1F9813EFD2AAFD0C58FB14BF3223E07B159DA90
+073C5569A1097D6D988B475A4D0F36D4CDEDB4395480E90C8DDE32398AC7930D
+718C25360B57FB534D6B36AE0E43A3FDF660E82649C1B61DC473581D1A95FEC5
+0447161D2C4C4D07DAA5DBED16E87A846C5E48C9566E32DAA2A533ADAB49C0D1
+42EE78306565E7E5C520E0DD31862ED3A590F90A392791AAC5B338FB0294B8A7
+5001AB369814F3BBD1DC46C265A5E105396838D491CDDEAEA1C42CC7754F452D
+952CCF6BD5997E50478BA7376C080EF00C782B978509FC1D22CA745A6837E7B1
+0478683DCED3E0F7AE950257FDA4F688CA7B6C016B0E32FED54E010347FC4F6A
+95345857F2382CB5DF1815274090A02F0CF7E7F8436EA031BFAA92F7A71982D8
+34E8A6A6B7309FC61DCF999328E7DC99FC2192CD609785D6DC5B251125DF14AB
+217948A53356ADEFD298B5134990EF0FBC9FCE565CB51CD8B783C043D85514A4
+77DE9CB34C4380CE464C16AFE767D5E4E3F96133F99F10BDB9047BE3C2E06325
+5A68E2AA5EE14DC74CAB71757DBA9D192E3B8684908CB1BF229AF62C121B97E4
+D8AD0EC1ACAAAF5E500A08D81733385AA8EEE8BAD9FB2317F99A2FBFFBEDCAAE
+79A4C5BD747DC1B1A409BB979B02FB91C69C79641BB492B8BC30BDD76789D1AE
+50EF235C661E66879A975285B8432D520B61647A8ACE7B12A4557D8CF8F6D841
+642E66E07CFD6FCAD324D1131DE37B9E62221D78599CBF369DD9DFF8837922E6
+D7C029F1AC567A938650C6FFF98845FD5748D0C77F56E988CD5BE6A95AF2A21A
+C378B519CFE7D39C4A071435C5D656F761E910EED11E65323D80749C2DE539AB
+D34B538618594676C4F25C00B9BE137D4FCA9A6D39144E1375300B36C81FBCEA
+05F550354C95860486704CA4468C7E1960585D6312A06C1769A53E09AC0AF974
+B8325D53B99A3236905B457AF14287DE2BCB87ED51E0E1BEE96AFCD45334A3CE
+AF16E4E07CF6DF78034B92B4B94BA6BBC0FA8387A26C9F1BCF2DCC5B07B202FF
+3197F88E9D4D612DF66AC444FE8D916FBE0AD9EE1E689FD9F5229B60889BE47A
+F8B0BDEF6DF156D34801056636EE94DEF1872908C713613C1B0E7D32DD48DFAF
+BCC1669CCC2BA69BC0269DFF0F6C4CCF9568B9F45339C1A6631FBD841668EF0F
+899C2A0B012643AF414B48C2E2553C3EC12B6B4F610657D123018D5EA7EA8DED
+86F1A185502C985197AD0734FFA314B9481295C33DA891FB32DD922288C2DBFF
+A038100D1CD61C266064D5A8AAB21F43FF092392B00BD0B1F1BE99258BA9CC33
+1AA6610FF0CD32EC0DAA102D1464AC03EC54377EC51B2945E6ED009375DB7625
+CB0754AC014D4FBF71BF4BD404E75732898A37E8D387BB642974F417613B8D0D
+CF7F398BDB9D44DE5CD3B0BC44B5E94347967909655F675579BDF2C0E8259DD2
+68BC3DFC089BBAC39E1A271E51C4793E719E9C198F1A9AD765103A55C90295E6
+BB9187C8C7B1431EA786F05BBE37C9A7B4211CEC6D856B9DCECA3356B070DE83
+9CA6F607019976077439A417FB7E469A870BB850FC181B2F4A64551BDC390D6B
+C7BA33139E387BC1AABA41BF4E0C4D9A56F58E53BC8336EBC8AA6E176C4D26A6
+C41677600003F6CE83309E7DF481BB9173D8948BF5FC566FED473C925422166B
+4E429FECF215E5FA2444DB744928A51418EA753A6A05211BC08C16C081358C20
+DF26036E75F2863BF0766D1B1B542D09C15BBF4EBE07663A1B131D94F5685EDA
+2254E850D5465D6D66264007D638221B2049F736DC30681551B5034EF38D2059
+6A72EB8579014AD3605ACF5B5A09A038078B1CF58F1FF158D17C1ACC9539A248
+FBF6B42BC0040BA3FE9A3CCAB8EB5318034DFD2E191BB4C6BF7C69FC487F30A8
+6C6CC98D478308AD8545117D1B2C8F7259028874D03EA9F6C7D3A0ED729048F6
+E9CDA13568789A3A0FB34F7FC3F1EB90BBC01B014EE56FA63277981946C40431
+423FC41794245E0FF68C81C61F2B72D2FD98C8E05F051E5CC281EDE8C0C6CB8B
+8E49529F2104A94291E5CCFF61905B682AA1F85B42B39A0561A1104537E05F78
+774D2391B29158C39BEC717CC0D8087C9FAFC413CC791BA0A897C1DA495C6566
+7A82E6F2C26B8B8D3500CAA71ED412E87A57A672E4560B3B8897C0BD892D1AEA
+D5637FD193D4F521CE209459F041BCC9ADA73731C33ED805B56B689A82AF072E
+1B164486CFFB9EFB36BF00D58CFC5F012236F9086F5C83915D051CD086DB55A5
+AABD509529B3A59BA1EE440DE1646647C02662A067414F7A3073D9D31590E62F
+C41E3FFA0F763A14D2683BCCFC741A9344FC695E483617DA350697E255FDE16E
+81B8C53FF16CDACBA2EDA5E7ACA25F5A332DBAA577E21A58A1FD48461E5F8C26
+BEED1A264A8A8773984A56433FD8CE3C4E15B64A150358897BEF440D187EA702
+F6D64FE0A2BDF4538EBB61E9C3981EEF4595B2848A55B9AC9D01360A12398B94
+DB2417813D28F8584C991F08BC5A68215FE64EF81A6DDD32C663E6DDC26802A5
+9F6A3DDD7CCB2DDFFA14BB87368FB4099E87B08EFC3622AA24F28F73015FF0F4
+C6A6C6F257CAC8C812976633D0D53EA15B59E1CC8CF6A731AFC7671C49E55B65
+80A9B2796B90D7F8F78A3E265BD4030B57E858C6845BB2C7FA8E1FB82B329C52
+610CDEBA92DD7E32D23A2796A3222D62E9E4F031968E89C603C7F7E8FF4400CA
+6F438DCADB154CBB60341FA9267B859CDB5457340EB46AFF3B5406F42A6DB898
+9A688B1DFA6CC9C6E92B16A04DD03A6758260A686C3135DABCB370162DE9AA8E
+C365A56A567E48B83DA6019B19AE5238FB43BAF73FCB61BC9941F3667FDC4855
+A6DEFD14DF9A15A9676B02244FDDA0B9BB8320033CA2D1A6F582EAB0B930A02B
+1091CC61A1370545A0E806F790A8A491DDCB213B35A29C05A3E264D6472540F1
+899BF86BE9A82B7F69E72AEFF5B638DE53541810CAFE88FF834927CFA317AC57
+5E20A41CE9B1B0FFC53D89A318AFDE4C6BA093FA79E31580D798BFCDC732C377
+D7F0BB57F798DA6CB38467066716EB8D5AEF35051C0550955257E6043A1A17E5
+594D513808FBB06BF1FCE274EFF67F86EBD10AF30DD55A95BC7B71C9A4AAFB6B
+1A9A62D32DBDF7067A492BA1D15FDDCD3A7268BCF6EB14088D05FF91F4D564D7
+2ABD2D6392573079875B7531A3C08A0BE2BE10C58A8775BA3344635361884501
+BC5943DCB6BCD227732511EB43B6F3E67FAE53DA0CA4074680F31CB0670D6D56
+48D8B314DD49ADEDEB0C88F0B571F56002B1D453A0566028D7D8A3C36D688E26
+EE26D598CDD49FB459EF1B68D986A0B8A49DB277C3D73CBF21B6431EA295F503
+283D0BF76BBBF2FD119262329AD3037D3E9A15ADFDF4FAD322BFCC7E1A680CD8
+3F48B74BB3215765E8D78F007CDD6C875BAC169ED115B5446AAD1F4FE431B62E
+6E66A59891F0C24BFFEF9CB91B83A614573B98E3BABAC1107B2DF188E92954FB
+44358C49F83D17C17D5F8FB61083B117015B0DE1FF4772C6C21029BE0772A3B1
+8AA1286497486661E2CBE2A485BEB530478A7B1DFB11300BB9F9E8A891807571
+3FD53BEA3057EB1A7490D40B4068F94BF3E091938B6684460BDAE2884150AD64
+F3275D04132BE60221F52DC41FEEAD56AED8DEC97CB317BF8654C1B842A174E3
+0CDA968F236571C3D44392FEC707EB6680A454DA98CD944FBC905B9A03DFEBF3
+CD6763FF48F8103812E1F3ABE6CF82077D478CF28524B16CA007C8FF4C0C9366
+55EB46BB4786308EF011B9FD66BB474BFF1F5A1C6D176A90F48AC7752C0B19D4
+2DD4EEABBB35D0E320F0CD1BD922F3D74BD2F3DC87225AC952F956A049293E2C
+AB5D7469ABB75A106DF81F785F7E5B59274FDA29F51F7F3A37B8E49F58A3E7D2
+3DA9A4927D7D0255C377B24FF6B17B40310481E3620B5BC6BDDD571F16B28654
+0353B7D6EB1620FA94E198C14EDA0AF87541841DDA9B1FF238DF1090C48EA923
+21B630E2B1F11380E703AA8F0A544D4F0BD1D49C87D6753232DBA6C3E0B6A539
+EB10E6251C9CD54651FDF4C8F70CD6C065D49BAF490FAC0B55A2AAD74A5237DA
+C6DDF61122DC8CB40453DD16B6805B550411A676BD3F45CD5CE14F89C681887A
+9364B5A21E00E89B5C6E3A062D238D70D23D4D91702EFD2F8453EEE5F44CA98B
+0D82E5EF6C70764CB070BE5A6B39B8CDFC62563CD7F30CE9977EF93548A572F6
+7195C1A258FF074D50BEA47A2C0E99AFA5CA72B3FB148A1F44811AD974419C6E
+AC88B4A5B04E65D3EC9F64BC4E9D828214F71B8DCC84440A6F897979BCC75D7F
+7A1F933450CF917AD2D62BFD4DBDA3ED09F44A858447E79BCCC0018ABB395301
+212AC0BD5DAD4DAB6FAB835893D43DD6351D6B36328FEB225A80BE56EBD91CCA
+3DD40D4C19A637B15FE0441BDFEF1908DCF9DDB2C7D63905C4D5EA8729F2C5F8
+63873612841F86EF5DB9E435E2522A8AA485231CAB30BDB9A6167C5EC1055F0A
+5A5CA4CF0C0A248315779BD530EFEE1737A20E35D50B47038B2D7B812DC79CED
+ED6ACC2927479478A9689A5D6BEF43930334B5A0E742FC32E3D926287E1BA01D
+3E491BEF4D6A1B77DE630ADE289E9C2EF0641083EF800FA898CBC7F2001B4B84
+635797B252B46D3755EE44B7BAEDE227E33A94F8AB3AE6B7B17819DF35EED17D
+26A8531E33F275F164859E0B65405ABF7053C336773D248513B43DCAA270CAD2
+310F3DDAFBB0D1D764DC2B03D8F61B324719E0EF174A6F9BB3CDD98BEF4749C3
+D02A8D1C84081B9A7955BA17CE26D4C44C2930B77A597E74C7439871581C1DFD
+75D77344FD2290975E6B87A2D1E05E4763D8494658F56C8907E454381EFDCC58
+C01531ECA79D44F0EC400D19DE0DC3A03DC5E895F0986926E855896DE496323B
+E548004FC6CD493DF8966E5DD28F5CA04BB59E7C89511A3CEA4C6128D72E9DAB
+71A481CF2E0FE6E702191703E6D3F0BC3B36AFEAA3C981756F09A9053069ED8E
+A2D55D9857D9DDDEA6D16CDDB65D61AA515DD3143175DAC4FE742497964E98E8
+272986DEA265CBFFB752A3F1A14D63DBF0ADE0E123C44596BDAE6DDBCB988328
+ABF3174079E1065612C37742BAAEA35F589D98AA1F0F9EE9F0F976966A9BCA11
+6B27123CF3A0BB2D2DA80AAF2CBB4513E69D8857FA785BE12377D671523604FE
+D8353A3FAA57920350702826B3E4A9663E24AB4E1BA03A2D8CCC84FA4CFF3CDD
+A02D35F751A4516F7646783B71F79E328486FB7CC4405FDE986AD5562FF2D9FB
+575E9A936D40724C5EE60A1C48FB8DA54036A7A4A5BABE9B3FB1F0DB6445DBE0
+D1B0112FA5029575DF62D7D397D0A803F8D1ADCDC26313B4F753586B58D4ECDA
+AE42D510056AE025DB1F28127D4B004307AE47E3CAF494FE09EF3615F140674E
+CA23E4D168EF75AF5853406E00A8C94D7A12930C90914E4E59F1B70E8EF668DD
+6281C05F3CB5AEEA055DD8737349A7E3B88C68993235BA78B842C4C0E77AF020
+B117C77D5521CECE431640F8B721C7CFFC554CA001F24062D1B9D32520BA32D9
+6F7D28192E24085D5EBE6A25EFD540967E58EB72EBC075B3CB38ADAAEB98553E
+81B83009AF5C476C0BF21DB698124F5D852843718D3C9C06166A32B2594F519C
+29666DBB8EEED133852FDCA8AA97D781A80D87E3225BC2F1538AD125DC398E4A
+50D25DCE4A154A0F079E444CF6FF75D9415FEAE171508AF8E74B3ADC593090CD
+81B8D50FAE14BA5D6A55F49CBE6DBCCF962FC3A02B5D6E438FE16ECD878CF534
+E9BA312838525CD7FBC3CBE7CE7844BCB1C5B053B26D2653880040B3DA5B43FA
+8D77FE1455377D02C061B39A00E882AA8B1E6C3687AD610FA915006440AB37FB
+C1A942E9668B58988C716D9926B17907AB27299DD9D1BDD8979820E9C66D9D23
+C816D0D32F7A056FB55E29B3AB8CCCD6FAFF0C37EB54DDE89F4A44F826E21FCA
+1EBF46EFC9CB5F298F4046F08F5F966EC6F45BDA2747B2C7518C33317D81CFA0
+88119222263508EE096ADBA3919620F113CB44C50BDF15165C0A98E2F917AFD4
+943D489C7D0A8F1800B2610C9DDB1CD2E9CB56EE4D913AB23564897CDA5750B7
+FE7091BDF30DA54FD321858349E494DF21D0A50A919B7F95FB93CE88B64A2215
+AC6D02252B1C36538CED144D869E47115D182B61325D5A8E15A73D3CC48B98D0
+22F65E7CF3E600ECDF617AE8EAE1DBA44CED4958C85FFB1DD24B2C42D22AD80D
+3AE90504D549C6D25126657A6BD74A4F325DC56267CA48A033A775E1EAC4660D
+48746CA54727E708053FB9446B6587B8ABE0E93218D33F1EB8E90CEB6E66D203
+FE83E732CBF22BB2B1E0A0094E7975818CA21A1FF34ED1038C11FC7B328E4FEF
+3FCD26AEB10E3857A8CB7ADDA908915A6533F14ED6FA0D904BDAFBCA5FA57A57
+BEBE290486C8CEDFF91E4B9073FDD4ED64D81BBF173419D6DEAA20E08F5166AF
+EB5069E421B1CE4E2679B9BF64B0746FDC7EF2FB8259ACC574DE736E2C1FA2A9
+272BC22B534C8AC3B3698264A08D976CD9C3A27D2611203DA040E3182BE9DAB4
+1E9A15159D24D70ADCB1F00AC29B674DF06C29EFE6B282B379336D73FF351EDE
+494CBDFC8C51F1696E5740DB3EEB27CE994AC28F3F40E04C89B4ABDD3BF3742E
+B152BB405FA40F7F0554913476A8125B0F2DE5FDE975CF738F37FBD08CD4D330
+975E1FD70AF356688027504FFF9F9E0FD6EA108C70F1011EF26737FE5D8560C0
+28CD4E0EA861558ADBD429FE4D285FC55B4811F16BAF54E3B42D2BA686661BCD
+A1DA9B9FBD1DBDDDAC0E9258F3064C9B92C4A6B90BBC330562836658FF9358C2
+71BF5CDCF42952501408A6C6397DA359F709A9D901DE65F8D5E62160
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMMI8
+%!PS-AdobeFont-1.1: CMMI8 1.100
+%%CreationDate: 1996 Jul 23 07:53:54
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.100) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMMI8) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle -14.04 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMMI8 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-24 -250 1110 750}readonly def
+/UniqueID 5087383 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
+3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
+532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
+B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
+986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
+D919C2DDD26BDC0D99398B9F4D03D6A8F05B47AF95EF28A9C561DBDC98C47CF5
+5250011D19E9366EB6FD153D3A100CAA6212E3D5D93990737F8D326D347B7EDC
+4391C9DF440285B8FC159D0E98D4258FC57892DDF753642CD526A96ACEDA4120
+788F22B1D09F149794E66DD1AC2C2B3BC6FEC59D626F427CD5AE9C54C7F78F62
+C36F49B3C2E5E62AFB56DCEE87445A12A942C14AE618D1FE1B11A9CF9FAA1F32
+617B598CE5058715EF3051E228F72F651040AD99A741F247C68007E68C84E9D1
+D0BF99AA5D777D88A7D3CED2EA67F4AE61E8BC0495E7DA382E82DDB2B009DD63
+532C74E3BE5EC555A014BCBB6AB31B8286D7712E0E926F8696830672B8214E9B
+5D0740C16ADF0AFD47C4938F373575C6CA91E46D88DE24E682DEC44B57EA8AF8
+4E57D45646073250D82C4B50CBBB0B369932618301F3D4186277103B53B3C9E6
+DB42D6B30115F67B9D078220D5752644930643BDF9FACF684EBE13E39B65055E
+B1BD054C324962025EC79E1D155936FE32D9F2224353F2A46C3558EF216F6BB2
+A304BAF752BEEC36C4440B556AEFECF454BA7CBBA7537BCB10EBC21047333A89
+8936419D857CD9F59EBA20B0A3D9BA4A0D3395336B4CDA4BA6451B6E4D1370FA
+D9BDABB7F271BC1C6C48D9DF1E5A6FAE788F5609DE3C48D47A67097C547D9817
+AD3A7CCE2B771843D69F860DA4059A71494281C0AD8D4BAB3F67BB6739723C04
+AE05F9E35B2B2CB9C7874C114F57A185C8563C0DCCA93F8096384D71A2994748
+A3C7C8B8AF54961A8838AD279441D9A5EB6C1FE26C98BD025F353124DA68A827
+AE2AF8D25CA48031C242AA433EEEBB8ABA4B96821786C38BACB5F58C3D5DA011
+85B385124A4E61AEB68F3178EAB6FB6A6F6902D21AA7CBE91C993B33AC52A6E2
+A7AF87F9A06416D527E83B7379CCA8951C333698E61E5703F26C9016A56D7C85
+22EE7EE8C3EFDEE06B62699CE641B595348F38090DBFED7062B7224CBC175D29
+341EC43C6949F06A90D37CC8A29D2AD617B1CFEDCE921DDF5A44FC57D936E9AF
+9FAA52B5F889B0343187B490AB7A2AF188EE496A5129C743AD389DBE9E9EF818
+6ED7C16AFED2B814FD2213B0E36A7A3C3063BD6432669D974CBE80A7B404FBD4
+D70E5DBB81629531D324550D271EA66E5660A447848DA526CC616EB12B4252F6
+3BBD9E2E4B1F3555445FC356ACA6AE2AC7B84CE91D014094C8FAFDB64D7C61BA
+6638ACE3A4BFA320446A184E033256231685E6DF09385223DE36049B1A0A162F
+D922569C4143669BE03611ADBB74720301BAA53FDA75B4105B4ADA71E4417EE5
+6D16FDA6823DD1BA8DFB1532FEA3DFA0FE8E3DE730C043BC1373005D7B338983
+5B10F2D85A19C32DDA842D3FBBE46BDFD07A80F01E60DF47BC5311D43C81157F
+2875A433E10121CB10770665AB197DDDC95987D44378752248A7FAEEEED6D613
+3EB59EC79E6AF74BE6190E42A4B9065E6A169D8BA92D1620F61A488437F2618E
+BC9A84B4189B3622BC22FB917329C30EE83816F7B944E045A22F214FC418A704
+81B55C90E91B775EAA5B028B801A9FEE636C3BDAC66A3D72330D035E5E211933
+0CFFA0569E34F9DCD4EC7DCC0FE8AF19FD7D788799DA1EB31ACF6C21662CB3A1
+C5ABD3C431C68CF3B7518E1046B52A25C3232F2357D518238C88C4F5E0D12DF4
+24344F4240AFAD73EE6064465A410D1700728CB42A5FFAA7C2C296CC5E6B014B
+6D891CEF24061234414F67CC46BBBF9A2E419CC9BEEA547FA63718158645528E
+C196CCDA516185B175AA577A3FC6E78FEB5D248027FD62F8B3F948797A0600BC
+C7C2EB6ADCE785E1091F9964FE1D41C93B19433939C9907622345979EE247858
+CB5092CBA85215597188C3400452D82BAFD62AF9C8A1C7A6
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMCSC10
+%!PS-AdobeFont-1.1: CMCSC10 1.0
+%%CreationDate: 1991 Aug 18 17:46:49
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.0) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMCSC10) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle 0 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMCSC10 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{14 -250 1077 750}readonly def
+/UniqueID 5000772 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
+3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
+532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
+B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
+986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
+D919C2DDD26BDC0D99398B9F4D03D5993DFC0930297866E1CD0A30EB76029337
+900ECFB1390CA5C0C3A04528044F266BA17BE487C79B94FAC6D6484684C5BFEA
+87BCCC77D40AD11552035E95E3007126418ED49B68468B38A14E88E68A267B98
+076F1C9769A5AFBC285E5B158EAC9F926F1D6C0B8F1D57D9C31D25AE27123518
+9D2CD92E5689E0213089BD268DA5E47525CB8EABAA4B78A15AEA34705889AB3A
+FFB8953B5B3482E52BFA0940630ADF8C0AC2177D907324299EE980E850F203CD
+B627962F43D5A678C44243CDE97853BDC6AB45FD5C09AD274DAF89929F583CC9
+CCC24BDFC68B92111055ABA5F26D2DC67C70906F71C2957701D65AE746A60C30
+40E6CB24B97FCDAD0487AE38A201FBF0E41BABD2181981A71940F1E707F91E5D
+C8CA50CB16D8702D188E56D014D92F76CE0B52ABDB9110E32438D2BBF3E6A40B
+7B005F10BB437812CAC6ED2996F7606DC962C4FDE207FF322782C343DF44CEC5
+FF06A55C630C20E9AE1B0D1C5673753C43BA0767D65D1B451CC6380D8BB3C4DC
+81E8FD8AA79BE993218686F29D3CD925566DD587F541A0DA1B1CC3BCEA2E6C7D
+5E1016F6917A871F1BBAD96AF9E867735017119A381FCF33EB2D3E1E7093FD90
+CDB0CED4818CFD9E201A03430CEC713620BE0D3254158931FB657C6AD4B2482A
+0E7D070D7497892E9E942DF58E88CAF0C8221BF36BF7C435BF2C683A4A2EF4CB
+E85820A8AD3486155A40143011BA9D76297F46DEF69ECA4596D6E4CAABF84091
+22A96A4BC78A8DD072FEB759A68A44BE1164638B6D952147EE3C628F9A022060
+1D1941E73310943FA782532ABB1116532AD67AEFE0758C051241E301C7E13A98
+6447EB0180BF6799814BEA4DC0F727D0A40B7BC3B1269CDE174453D6A3C4479C
+146001CF717DE25AC1BE5AEA5F2F1C17719251C429D3AED19EFAABDE5FFABD96
+2ADC0982F030698CC2C3A377637E71B2B7C374035D21CF196E4B05CDAD9E76D4
+DE24BEE50B0C6ED7C3CE2025F9609AB733A3403A90BBC42AE3416299A4451E65
+37D426466B8A559DE93C4A5671340725A5DF85A42E4E0A629A1A66C8FF66CD28
+F5A2F4B970A5FB6597400077CD4E4F7C2EF90294ABBDAA0CCF0E36505F5E6C23
+FBE41381E12D84A7D9408BA9D1CBE275CD93692676EC9854F962CA277A309595
+0FC087F83D51EA1E212F5D306B0CFEA944B6EA361EA9CBA8006C9A7D9002CD67
+93227579B2EE31303E9E8C7FD40851004B1FAE485ADD67D8EE284F165E740761
+CF2BEA52BF3A7468015F27C1AEF5ADA23A9DC16F8C80C1362FDA775E471F4CCE
+51F1351782CE12464F5F217051560FA7A197E68A64AB20F048A971D190B64965
+2DBDABAE15892E9F4591913816B653889F6E83041F8947C0A8AC513344DB5D1C
+366B9EADB9C0CFEF0698CE4220FE163A4F6598F55EB038D0FD6B33060F79B483
+3B23B153279C287D6726DF9AB4555D5CC18604523C9CF5AF50C395CE99A059EE
+09937A78F6E133A21C0BFF9224C48A144FDD438481858895720ED918B834E176
+ABDAAC5E7BF2B1822D6D418AE82EB994D818A9B8586E411F32F3306751EC1EC3
+6786DFD56CAFA40C2F5B1F92E720BAC349510BD968999F07E2720EF7370130E1
+AE5516B5855A02157A9C757F4CB0EA09E13FF65ABBB515E2503A1388F2104711
+7376E8C86FC5EB56CA3237527CAD5749BACD30F5AB597B71B0D29ECFC0BAE51F
+5F987AF82D8D780E1ABB8AB759E58B5FF5079739F712853631B27F882BE5CC58
+FE5B3BB95F60C2C5510CCF4ABE4B336363910D34BDB9A05B00AE7305FC6E66BD
+BF1898CB634D7012F6869C50488550F08EFAF075D03FB4EDB53DC464DFC41EDC
+8E253F44EBEBDD75E101F98BF378325667B7E2B5D0A10330B59F3B97644EFDCE
+6BF0AB1D42C25B62ABABC62A2AF4F35B75E9492C33B1C068EE7C46FCBB0474F6
+9832AE979E19DF861844EAC53B115E0E659F9339E652E797AC0B1C0F20B1FB43
+C3086FA4A8C30BDB01510ED055C884371895C7FDE42E023951C59F5126B6B879
+492788E29ED0FAB3E1344E3583F0490E4CDEE2A952C0EAD84BD9408C476C6186
+DF76C3204754C565962AD53D3AFB12DC24C891DC498D559329C55D3719465C41
+54271029FEB8947C966EE4B15A0103FC4F5B50821B7CB839B3514FAEA02C73F9
+1285D8D4E49E88067C9D3E41B0A2080108085C5E162A1FE20AA8638D48627DE5
+F78B2F7EC4995E4AB41569AFE22A8F51C4DBE4799F32D600E398FAA6EFF6683B
+053E323686CB0583938B55754A91642C0334AE920F5266BA9B8E647CB9B9C71E
+07FE1ED0C640BFFA6ED673885AB304DC50826967FACCC4246D0EA8F6AB830830
+6FEFCB60FB559F0679344A9682297440BBA895A82C22B51E90DAFB6BF1FEFCCB
+4064E609C1ADF4974B433225B775D5F6A00B672ECFF8E421CCDF9434E89CA165
+4321922952D2A656594D88830AAEB01AC5B623AB32956BA58416783976C9B83B
+440A045FA8D0613E2E10ACC3DF0946B734C58FAEF1AA75104821E27C51E22761
+EA625EF47EC826C5C8BDCD4B078482B1C74F027F2E4D47E5F8DF55EC493803F4
+AB7758C397BD13C56E765FF4E2BC917B299C49F28A4EC6B2668E438993A6E58B
+8758BF235D38D6628BF6088EB3CD62E9873E0E3F97443CD155E3BE47D46AA496
+68ABDE192D144388BD40A79E54146A79D20BDF2CDD557A915419B0ACCC80DB4F
+3108179EE9FC37F9DD06F4A0B7AEADD9FAD136A4673C30B597C99BD0DEBE0ED4
+E4D225DD8E2CB22CCC8A24D7C4005FBC7F6CE2EC2FE7BE5634D58B513384B469
+53E41340674A7C89895E92AB2B992DAB93A283379E0142344D23FA9B89027523
+CBD878DCC799CEA2F415BFE0F6B944CC9C49A6D91C785A4453349D2379BB78FA
+14677E38C742034F0922D977C77D75F5391819E0B93B5A92C4303528B24493E1
+EC093B93A6FB46D2A6AFFB0C56C67B19F9A49509C9370705C4C7CD1DD8E4471C
+E7DCAB8C5BDDDB0081BE08F4EDA632D06A0D7975F3FB093D1373F8977D941E27
+293E8F912CD96C37EF364DCCBC8E0EDD8812D9AE0229870D82784D000FA2A3AC
+F57BAE026B3A93C67591135D08436751AAB8A786845B866B8DEE4A232B434B53
+A05AACACDB1557C385E59BE1E68D80C8FDB16316DF2467B540A8388549AFDA66
+0543100F367AE16F031497DABC69B2CDD498F07CDA57C856F2D079E6FBFED066
+D1BFC3D746C863893E7B4055E1840EE73ACBECF1DAB9F95631ACA79E12D92E31
+7235D2967D2B63E0E87A67B73A2809000473F5639B555504BCEFF558CB3C988B
+D5519EB9A54B3225BDF1A3447CA4BF9ED7031CCC35F8B0E19B7EE238E0B4F0EF
+36E39FEABFFAE7801E8A44E8941A8B4159CE1ABFB2E24B1C4F5EA09F173AE1D2
+3F390D414D278C42123D97B58E3745DB2024C67DEBC067C14AC05EC49D5845CE
+1762287D4E0C853F014FFCAE97B2337E2F5432441A35F9B301B291390241E0A3
+9D8A22320EFC99B68AB9F90C13FC8929A2C235C06BDCBB8E49400C50CB5D1C92
+859FB4F6FF7F340E0748DC2F7DC7E9887AA8BC30C46A073B8B1BA14FA9FA302E
+488C0E2FB315566BE27BD5C1FEBDD4952C962C20ED6B0A398ECAAE26765D6245
+22429786AADC90BFA402921903DC02B850DC862AD27BF00B4DED5E8E15E0F8C8
+0E6724A8484B9E9B469D6FC30CA9690B2091A6EE674F35B4BC3E8349D930EA71
+65A80F75BBDF5D6A3C043B0583AB59516B853E5F626E14FEF04BF09FF5E936D8
+D4A0677861984BA5B9920832A6E6300E0DDD91BD4A051CB7178FA00712679D54
+453E44E5F94A48C2F0BD940E8445E8788678BA13C6E29475A60AFACC018BCA5B
+792F40EA9CB9BA7CB5A6FBC34A3857FF223EAAACE9652BE971B95181848B148E
+53A99BBBB2233C91A5994392DAD9F2CE53687D244C9C2BCB04C97F70CF265186
+8BDCAA4BF51A819FC6C2C79872ED7B9EB84896B51F410ACD2E476D13E9063B03
+BB9BE7A6D5A0C5142104CB3069713A074B083583D913C074AF2FED85A550DE49
+0CD0AAB9E0DD77C8B62392C8507D18931FCA4A9268BC1316750795531F62E730
+CF0CF64776849F4D48BB22F77B24AC8EDFA1119E94D8462E2A1CC9D22EEF8C40
+E6A6E77F654C3D347086A64BDF0AD74C152E0DB49F92D88C76CA6C4104B4F423
+56C7DF65FA524F4BD7CF7D392AD480AF8D6A057964BDFD517EBD42C1D68AD14B
+ED69D9E14474274F742B5736369B0AD5C796F69E13363719C3344D84541A7BE1
+92AE105A674959BABAE02A9E16E2C9C230FB1B4E254F038A189457F7F2DF983D
+AF20CA0E3B8E22E20EB3FE162C45F0024F72D0B2A2BDAAE56DE69C3C4DCC6140
+58686F01F90BF9528F5EF5CF06C75220105B1223DAA91B8136AECB46E846D5C9
+15DA086CCAB96BA817C275AEDE14D7EBB0135179C8BEDF94F72277E0FFFAF718
+30624440C13B350E65954F2E655C6A72C48E809A627AB7972856E4E3D6E7054B
+54B5F1C8C1928CE90499C2BE335930148DCEB5C1971BD29098283FC848BDA13B
+E88AACC3F11ED680B576661EC55341F46E1C0F11B955750BFEF0AD039B6388FB
+074BCE2B31DD41B7E446D0BBD9BB44D90D945AA7C9E380E9C1B4B18726E1D1EC
+1000B62F5AE439468B87324C5647C0D46A2BDEBEB7E3FCAB13405D47D3A76961
+847B4E07F935DC1214B85697D8F7F9C05D244BF008EE6E44F15C2586EECEFA49
+015114836234AE2E90F1097A8CBA06D40A22292782AF7FD4DE73681A4E27F1DB
+827610B65FE90B22C0514D2F56ADB2FDBA3F9CCB14E2C5506EFDFCD0BC87DFE4
+5F6B9A6BF1C1EB66024AEF73A0CB829A42BCEEB46906EC6F01B8690FFE8EB92F
+D7249445E9EB87F946C22C16F58BEB38E57432071C1CA13CA6E831E9D274A40D
+E1C1B2179389BF06314151F993DC4303C7B172B07002D36DC206184F5190DDC5
+ABFE3AB9248AEE5A22197E1C57A3B5F218DD1501C3E26A0737E1058416986BB8
+9673176059F4A86933281B1866B67B109F0979F25B807BAAEB4C2767EB4A82AB
+5EFC11B8ED2DDA0FF61B3E8B410F3B3A58CB450BBF1913A97DD5631AF485F7E4
+12494FFAA7EEB107071BD638DBD96F9F2E8E1F99784858A7C41022094849017A
+6C117DC5D7ED993470EDAB3B1FB8D00640AC8B725EA307A7249186F40355C216
+4E1E352006116479812AADB108F70E0D9CE256746338FB36637822BB74441AA8
+C3FDB25E0B2C00806A68187CCCC71B9247073C9BD448357324009C06A4E774EF
+FA37E9843B46F1EB7073D5222C88BF406CBCE292634787385618DCDBECEB80D1
+F379129C02CBDB7D5063FA8774D737D71EC63FD5F3DF38DF71131F9A970E40C0
+99E1AA6A1B2582D1BABF18BAF32B82379195B4B75035703BEBD6C5EA2463EAA2
+8C3800F94D69AD85F39416389FDB6A3FACE085BAB482196E1377E34E758DB5AA
+E0EBCA8852B2E1C580B0EB7F2530C39889425280D4CCE568D0D1DC07271CC3FA
+1FE6337C10127E8A7F0EE77D824D2ACD6DADE06E0504C1571C424812294F77C8
+E6C31E1B1B8609C4B13D55F7A6BBDB3C00355B4BFB295140B6DB95DC953D4729
+2DF8663410FA27789E9A27DDB57820D410B35845CABE5B85CD3293EF6F92AF8A
+F8A15F885EFF34E94BA9F0C2BBC1D5247BDCE520F7156A19CF2D7F885745AF59
+24DDADC3B43CDD4BA9FBF8A354441581E4E05FE78FCE3EE512010AA0FE0CBDB2
+ED94B0011BE67BCD081FD440E4CF8DEE2656CBD06F7608FBD4BFFD412F2A9155
+58FF9A9893C831B35A722AF76B1F51404B6307A43BA6FF55F8AE46C634AD30F3
+A9FF20890C2D841AFB6113959E3D7DC0C6FB38613F5B4CB2E64C6E53E88D9B29
+F56BFE3B01A4005015B3F14FF0D913EB9950DB86AD188630CF2C99A38B8C4FE0
+62C310D65A3D4BB926C432824CCB02B383D0210C148221D2FA83FB3B8D5FF531
+D3B2CCD43FDE731688CC46FEA3D2845B039BFF09FA63FC98BE95AF6C3B4757CF
+6EC47EEEBFEFBC7E3C2761802B7BB6561BF018948B0E2CCBCF8F435EA5458F96
+C69F956F9C7CD7274957702093892CCC2D0FDB39B4E2602860F5034D8BB0F485
+F2FE96C917C04C8512466093E3A36FFF5ADC4100D9889A7788CD546480C9BB39
+995E386C9B5CED29ABC38D297B7E15C059E6C15335525E3048E89EA41AD767C6
+B369E853E7BF0426798501749DF4A6F77ED552C314E72BA91219C32368749F08
+8EFE006541C0AB9388F1FBD4636DA17CE7F9AC204E74D9EDC3E56D89C35B0090
+CD7A7D5A8DE7E252AF95DE35B9483A9E92B44E5AD5FCAF3ECED216DD057F989F
+F6C76DD1D174ABA0EE3B9A75F3AB1C7E7CF8B1E7CEFC601FEA6B308AC8AA711B
+F647232AE780C58BD09F92D48770778153E65315E4DC9E26A6DEB03E4894238A
+9AE5A4F3A4F3F60D154ABA65986D4D67A5E567F975F33B3B2661B6D5C0EE59E3
+4758471CDF55542F5ECABDE372AEBF2703150EBA0A0E2D199359B7FC1E70B801
+4D41DB5C71F46771DE8BDB5E37EAAE69569FBEF07818CD63F12701AA1B08C868
+A597E68277B3DC45EE71C39D8A60BFC3F44432EEDC01E2D134721BA42C2BA930
+64D0EC4410277B8928638544BC4EE035F473A69A16F5F88DEB7494719EF88685
+CEE078F873237FC5952AADCA030E7294CEAB577C44F258D68F8211B7BB33D462
+648382C66983657528344DF92A79D675F6DCD40F6E84AF34C3A8C6ADDECF0F31
+F65D3B73DA48182127874E6EBE3A7C9383D346EDCEA76A652C99EB8E1BAEFB59
+48D0E59E3917A614B0418E5139B121B90412AAD268319AC4511AF5DD16512A62
+1BE1BCEA986D1C6077AAD695B7C2CF346284CDE840C9C86A34BE2A3A24593391
+4DAA2D85EE5A9AD0678F5C694F7DA4DA7FF58B7497455AC56263564EA28656D2
+959166040E1A7E5DBCB5FEF6DD4AFF8220815B9FE8A0F2B74B2011784807D964
+F8264DEB6FF429A023F8B86F0DC866B970F2CCA548A511C58E313F3ABCF21480
+D4F39AABA29E02532F7934F1917B68C60C52A69171514B112B9F59B71873196D
+125A75AA7EE7BC525E3AFB52D573F7423F286091CA936CE59BEF26F2D025B042
+E186223EFD34DFDE1D3F9B2B35E585F915C01E0F3710EDB9D90053082C7BD206
+91423942AC3818F2B19BBB37235BDD7654AAE77BDAEC33C571074C46552E0A90
+DABFE9D106480B7BEFC319D0F507820C6FA335CE8126F56E654F2F2479CA9359
+F97C87498CA204F1FC37E65DA1442CD9DA9304C91B11A63D240DF5B12329E28F
+7805A32D03E8FFFCC87859B9BE553709909D579AB1655E53CE5E5CC035F6445A
+EEB07184C2F181D477CC4BD71D8B59520D210FBA51C8CB724027FBD5D42E48D9
+0011E697E6E4BD94B79405BE01914FCE9C8E4D750A052E19619151ECCB6BFCD9
+C95575B5BA46DDB43014177ACFC00A5B9A350BD729D3B926BA4E767036FB6E61
+95F657DADEA8FB6484CE6955C0E1150CBF5F5653A3A4381026933EF55436B8F7
+EC0B776CE0D40E9E8406DC6CA41E68EC1D156A329B3D7E0627CC2186517428DB
+0FF798B99039D4B938995815F49BEA9652E1EBFBAAA9C0900DDE0972E8FB0345
+D4B69F54176479591147253E78B5A2AB227E04C1B1A570EB5DBA138EEAA9EE9E
+65A3C624D3A17EFDE58DC609050C934358511BAF0B2BA27530A12DD9CC0EFC00
+589D0E520D4F1A99321F8F528B53704FC75D6E0B5EA3C2F3D17583B8A71DA425
+4DA024143C876A381A009AE9518BE40EF19B61DF0DC338ED494E7B0F256A530E
+973E0B1AE17DE69E2224A30FE0AE237976EBF42F2636373C8B63156E6A7FCC13
+A17A7537944840FAAE07FA2ED07CA8C25013BB3FCA393538753A72751873A3C4
+6074D7A3877B9E72089C0312AA766CBFAA13D89DFE50DBD73288E8E5165C68DB
+AD4B13C1C5DACC417A3818EBC559AE8814AD44FA8A70717F585CE0723191C86B
+260A7D159EDBC1C7F2A56DE3973CF5E02B093C4E470AC53304421C704F012B6C
+62DEE5283D1AF503D0CAFEBADD4868DBACB47D08B5347B0FB3114A5F67CED740
+C04C89B8796AED6552A6E102EBB0132F97862463FA9EE8B2B80DB08B44487328
+5A40AFE55E2908187326725DBD29C38792F14B571860755C2D18DEECE9FAC7E4
+A1038ADFC2BF67A6E93A5118236281D0907F8823197B684C6C907FBF0C992D9D
+F960B81BAB201B379F24E3C002214EBC1C5EDF16CB4F765863EBE8F9E9098946
+0659DEA1147EEA97F354463517AB04AF297AD77F167F96B07D4786FC18CCF1F5
+EC1DEEE54F00BAA4A1473CD16201151D816D8E73555F94062C03A038E270AF54
+53E04CBF02E2DCC04F167762231A2119306776F8248BA18342564FC4BA4344A4
+984E877BACC616923C702FC5EE4035982F2461B1B7E25C69C15167CF244F8B11
+F7FD10A5CF9054EC938442B968D25856ADD7628EE92B6EA28B03DC1A0DD31DD2
+50B6E2576AD604C0564777892A7FFA2C19C0D9D87832FFA9B179A0F0552CECF6
+08AB61A26DF50CD820307D91231F7D39F1CF87493F5D0D8A4FE2B918330F8C15
+4292FB335B79A8689C30E9970AD41B4B0054F0251429C47DCACF36DE7C730DCC
+17A6DEFE65C90F01C6A940D1C457D957255F627A724EC358AD11E5D2D59E104E
+C1312DF39B3CF8C6C9A1FFF9AE4CF9984815EC62A9A773A54A7353EEC47DBC85
+4A74D4B10BA3B36793A873F67F55FA857D218186285143E9937196B82DBB099D
+A01A2935A1FA98F9D619D1F78DE9A3F5BAB3E026859147C6C19BBD7419C0B51D
+C9471BAB1E8D91BFAEF33B7BCAE024F1AD5334E2F2FFBCC6C166D786DFBFF53E
+05C2739E8080BA3A27912B18D0
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMR7
+%!PS-AdobeFont-1.1: CMR7 1.0
+%%CreationDate: 1991 Aug 20 16:39:21
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.0) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMR7) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle 0 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMR7 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-27 -250 1122 750}readonly def
+/UniqueID 5000790 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
+016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
+9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
+D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
+469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
+2BDBF16FBC7512FAA308A093FE5CF5B8CABB9FFC6CC3F1E9AE32F234EB60FE7D
+E34995B1ACFF52428EA20C8ED4FD73E3935CEBD40E0EAD70C0887A451E1B1AC8
+47AEDE4191CCDB8B61345FD070FD30C4F375D8418DDD454729A251B3F61DAE7C
+8882384282FDD6102AE8EEFEDE6447576AFA181F27A48216A9CAD730561469E4
+78B286F22328F2AE84EF183DE4119C402771A249AAC1FA5435690A28D1B47486
+1060C8000D3FE1BF45133CF847A24B4F8464A63CEA01EC84AA22FD005E74847E
+01426B6890951A7DD1F50A5F3285E1F958F11FC7F00EE26FEE7C63998EA1328B
+C9841C57C80946D2C2FC81346249A664ECFB08A2CE075036CEA7359FCA1E90C0
+F686C3BB27EEFA45D548F7BD074CE60E626A4F83C69FE93A5324133A78362F30
+8E8DCC80DD0C49E137CDC9AC08BAE39282E26A7A4D8C159B95F227BDA2A281AF
+A9DAEBF31F504380B20812A211CF9FEB112EC29A3FB3BD3E81809FC6293487A7
+455EB3B879D2B4BD46942BB1243896264722CB59146C3F65BD59B96A74B12BB2
+9A1354AF174932210C6E19FE584B1B14C00E746089CBB17E68845D7B3EA05105
+EEE461E3697FCF835CBE6D46C75523478E766832751CF6D96EC338BDAD57D53B
+52F5340FAC9FE0456AD13101824234B262AC0CABA43B62EBDA39795BAE6CFE97
+563A50AAE1F195888739F2676086A9811E5C9A4A7E0BF34F3E25568930ADF80F
+0BDDAC3B634AD4BA6A59720EA4749236CF0F79ABA4716C340F98517F6F06D9AB
+7ED8F46FC1868B5F3D3678DF71AA772CF1F7DD222C6BF19D8EF0CFB7A76FC6D1
+0AD323C176134907AB375F20CFCD667AB094E2C7CB2179C4283329C9E435E7A4
+1E042AD0BAA059B3F862236180B34D3FCED833472577BACD472A4A78141CA32C
+B3C74E1A0AE0520B950B826B0ABD81766035058ED1654D00FE541CAD1D246C0E
+DE85FCD3C0BF7A70B913487B1A527EA823C00C39DB61FD6641B140FCED8580D8
+046741D2494B4E7CA1F120CBB0A532BE049CABEB70A39018E8212F8178E93C98
+B377AE2880FE39BA0EE29451857DB34964DA26ACA4CD23CE284ACE37D89571FF
+CB67DE7AE379B74B32ECACC5F3DE0566CE9EE820E96F27653C75935851CD9360
+A83C7EE8270383CB8A80715BC2B62B1F709235A5A73D99710D7665182D461095
+B98C8A0FEA44F0F1959055D50BABC7880E7BA1CA4CD72531A240A622663A0A1F
+DBE4FB907F97515CB1100282C9A0241F65F84EBAB1701FC105BD25F82807F4CB
+6A5EDB5CB156A7D55F64146818245C112DB0FEE9E0AC96B4B2AEB27F89FE0560
+727D85FE6CFF5C457EB1EE5D7E2A09979684E2611BA57A1BC7BA4E37DC4BA761
+557D986F9A8B495CB7212507AA79C297B0665CB5883F2332DF5CB088A92E24BD
+1EBADCAA515B567FAA9E15E7B8DA60C1BBEEF5A2E0D4C0C67EDAD822B5E8D81C
+6D29928726D36EF0A9238476FE54D4990E8D75FE0109C0336DD50F9021307213
+F69C700D2291C546007CF3A5DF3BF5ABEEB640D3AEF585055A65EB2CA7AD7F11
+22182523EAA8FCF029C604212529C03F179566E6B731FFE2283D6402A350EAB9
+3C7FFF41383A9398B33C48FB2F9A8241D65425FC5E49DC9BB97521D91E44B3C8
+B2EB1BA8D532BBF175486D1DDB914BCB92968D342B5C1FD6FC72DA462FF68992
+464BF0E00D05C2AC3729E598991C6EE7354F0C400296356ABAB37A16FA504DC9
+B6369F88BDB7061D5EEB761527E588B4A6C83169B517991789D664BB543A0E57
+6F2529BDC7838AFB93D53D5794E57B65A7DB00584492C046F72CE19E4D1B177D
+1D951362B2F7CE2B720B305D45B7FC74183C1DE46073D8E20FDF8027FBFCDF40
+5F0950F5AAC19AC8E8D9A57A271C0BB212822798DCD068B4F05DBAC2AF7BB25F
+5DFBFBFB5A51ED26ACB22541E1971002A5D97B5E148F8F087A3229C4
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMR8
+%!PS-AdobeFont-1.1: CMR8 1.0
+%%CreationDate: 1991 Aug 20 16:39:40
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.0) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMR8) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle 0 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMR8 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-36 -250 1070 750}readonly def
+/UniqueID 5000791 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
+016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
+9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
+D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
+469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
+2BDBF16FBC7512FAA308A093FE5CF4E9D2405B169CD5365D6ECED5D768D66D6C
+68618B8C482B341F8CA38E9BB9BAFCFAAD9C2F3FD033B62690986ED43D9C9361
+3645B82392D5CAE11A7CB49D7E2E82DCD485CBA1772CE422BB1D7283AD675B65
+48A7EA0069A883EC1DAA3E1F9ECE7586D6CF0A128CD557C7E5D7AA3EA97EBAD3
+9619D1BFCF4A6D64768741EDEA0A5B0EFBBF347CDCBE2E03D756967A16B613DB
+0FC45FA2A3312E0C46A5FD0466AB097C58FFEEC40601B8395E52775D0AFCD7DB
+8AB317333110531E5C44A4CB4B5ACD571A1A60960B15E450948A5EEA14DD330F
+EA209265DB8E1A1FC80DCD3860323FD26C113B041A88C88A21655878680A4466
+FA10403D24BB97152A49B842C180E4D258C9D48F21D057782D90623116830BA3
+9902B3C5F2F2DD01433B0D7099C07DBDE268D0FFED5169BCD03D48B2F058AD62
+D8678C626DC7A3F352152C99BA963EF95F8AD11DB8B0D351210A17E4C2C55AD8
+9EB64172935D3C20A398F3EEEEC31551966A7438EF3FEE422C6D4E05337620D5
+ACC7B52BED984BFAAD36EF9D20748B05D07BE4414A63975125D272FAD83F76E6
+10FFF8363014BE526D580873C5A42B70FA911EC7B86905F13AFE55EB0273F582
+83158793B8CC296B8DE1DCCF1250FD57CB0E035C7EDA3B0092ED940D37A05493
+2EC54E09B984FCA4AB7D2EA182BCF1263AA244B07EC0EA901C077A059F709F30
+4384CB5FA748F2054FAD9A7A43D4EA427918BD414F766531136B60C3477C6632
+BEFE3897B58C19276A301926C2AEF2756B367319772C9B201C49B4D935A8267B
+041D6F1783B6AEA4DAC4F5B3507D7032AA640AAB12E343A4E9BDCF419C04A721
+3888B25AF4E293AACED9A6BDC78E61DA1C424C6503CC1885F762BE0618B16C14
+7386EB4C4B9B3142B9662F48DA723079108398B61EB859739E028C0C673C3E64
+C08C3213E7A9ADF9570CB0DF3C01FD9D905F01E8587D35421CD2F96A1EEE82E9
+DE47A4656CD75A882AD299333032FA183BA3CDDA9A88BAC297A878C886C02069
+E88597A851BB78E95B1D1D5BFA6098219B2495650CD0C80E05C23C2C641A41A3
+5364975AAC2B2E14EF9CE6B785318D370319D3CB4C524777AE7CFDA89034350E
+19888E124037F0B85966EDFF59CEF8020A49E1389443F8A91FB4C94E763B1ED6
+FEC1823E2FD955EE817A7AED2CF459D460FE558F355798E12D9007CBB3C13979
+A08C5C739B0A484C17717CC0BE94092FDABC2BEACA5B3DF866FBAB02D675C8EF
+FEB829CE7306224FE4622017E5C48A2DD5DBA288F74C60824A286BC53F8BD7A2
+4F93E0AE61CC7308A56CC1995534EFCD8D6344F085AB589E32246F6ACD92528D
+556C0208F7D17D72A3DE2537587D22694E987A582C95A5A24EDBAF25E0EC3A8D
+28D19262119E10CDFBAEC6DE6AC5F0E44B7B759D676BBA41B97A358E48FD10A2
+8FEE9760A94B4FE9161F74F12C6C3C2CBF5EB56147E95FFC693FE4C88BEED81B
+DC1C4DC8BEB4B103C2967F76DF1512C72C074F317C92AA76693B21994E7B1304
+D81ECB167A80A7023DE87858DD902F264AA80AD84B61BD206CEC66E9C49396D6
+A04A639D08D804062130B73455983DED8A848CC7C390D54A60B78717298E8B8A
+86271A89C78CB842F8617E8E10C6DF2B1E4F690C8B28D72E91CFB22BB1A4E2E5
+8CCAA2A6AEC85623B1C46B816FDB58660E5A831C1A504CE404950D060A638129
+F1D9EBF82C9681B0759552BCB6236DA364562A1A882B8DB550D727B690DAA208
+F04E5B8F8F2A1AD9DF2450D8B5C32570EC97E37871D042E08FFE096FB1FB779E
+0BD911CE8CA02E904FE9B1FA76A0A71C114A593B1D6ACDFA7798C6AFD526FD78
+79F19A56A98967F6D98F61904CE608322E0EE3BDD827F8F0B963838546363EE7
+85BFFC437BFF8187C4B75FF1005AD0
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMTI10
+%!PS-AdobeFont-1.1: CMTI10 1.00B
+%%CreationDate: 1992 Feb 19 19:56:16
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.00B) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMTI10) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle -14.04 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMTI10 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-163 -250 1146 969}readonly def
+/UniqueID 5000828 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
+3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
+532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
+B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
+986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
+D919C2DDD26BDC0D99398B9F4D03D5993DFC0930297866E1CD0A319B6B1FD958
+9E3948FFB0B4E70F212EC976D65099D84E0D37A7A771C3101D6AD26A0513378F
+21EC3643079EECE0C9AB54B4772E5DCA82D0D4ACC7F42FB493AA04A3BF4A1BD6
+06ECE186315DBE9CFDCB1A0303E8D3E83027CD3AFA8F0BD466A8E8CA0E7164CF
+55B332FAD43482748DD4A1CB3F40CB1F5E67192B8216A0D8FE30F9F05BF016F5
+B5CC130A4B0796EE065495422FBA55BEE9BFD99D04464D987AC4D237C208FA86
+0B112E55CE7B3782A34BC22E3DE31755D9AFF19E490C8E43B85E17ECE87FA8B9
+1485831624D24F37C39BF9972D74E6EC4784727AC00B9C4A3AD3DA1C22BD6961
+7E0ADAF55422F22ACA5E4DCD4DF9FCD187A566B7FB661D0530454D0DD6C6C50A
+7A3875C6CBF8EC7769F32A1F3F7FC1C072BADEC97794D4E90E0035282A170402
+356E5A9CD9ABD80AC4342A5283E458A7269252F4541CBB6452B39ED54D336D0B
+19928E9CD1AB26AD83EB209E2EC75011A2643813053B5DBB0246097C4821B5F2
+C92554E9140BE35B2DBFCD98809A8EC9FC910FDE9E0D86457C70ACB056EBF90F
+244DC0A5BBD455E15D6E3180311D52CF50B0BF7D0A7F64F3A1821E0AEDBC2E7B
+AEB549FE1D51088C153799C6E089B5D5D65E1C4E2D2B430CDF1FFA23CCB25D95
+5C4DD885310A706B320AB25C8D742C6F29953254FA54DAAEE60ED477877D19BC
+D28E9AB576B0EA088171FD000B60D73B3C57F754BC07EBC9BF751B7D2B32459D
+993861B7C4B0D98C422A11BECEF76F4EFC0ECAEE89723E6CED53E3678D733363
+2DF068AEF0FE7DFB57393BDAA439A6A4C396F86032A98009EAE1247B7DE83B3B
+E46DF2898598FF5E6CA6953127432A967E4FD41CDD60D6E413059A58FA556EF3
+309178B57C16A763CFC9BEEC276944BDEA255789EF4E1ECDE1EA43EEDB955513
+F42EDDCF39AE522A1DC2D80B2772B05DA60F3DC15A815A6BAFEDC399C7956E75
+3851CB3588E22936FBFB63A58300298B11C45D82385C083D07AF133BB1BC941A
+FDD9F34D5E0B8087EF2A58C54D8AB7580EE3ED58AEB83B72CB9028F472ADBF11
+05A77651F118824F6CD00209EFB60C1D32D46A78E8C8DCB8B0E742828E3B7D17
+DF5200D68189C918C2D1E2BCE076599AF2AE945C35C8F442DBFAD21892B5A756
+B1B5447FC44BDB516C6C2DA3C7BADA707A611639986453619B0F4A87D8D42B57
+4F96DCAE49B6006399CADC683C87A316C6A202A1C6978B80890ED96480EF2647
+ACCA61BE6D41EC35142A11C8B2EBFFAADD0C11B0065E2ABCF51132F38B3DF788
+7D35F29CF3DA6A21033BB28D01D9967E01667868C7234F9C904A03CA7875A7B9
+B2980655C5952AB003126D522009AA379D50EE8C22EC0237A9E82F50B4C1C2B8
+6118A710F6DEBC598736EFA653650A0A4C3509E78715449AD2E324E8C38E4757
+143FF4D148AFEC4D5B7C8D0C358B5B0D4CF94C6C47162AF6935448AEE62A6B4C
+DF2DD4CA2684DE0A1C7769082701D3E33ECE2DA0F3FAE3D56B2277DE5A94B9BD
+2D9E4998B74752EB51CC7A4AEEF56CB3EF3A051A7C72B5C0C98AB1B13F692FFD
+CEB26F2E48CEC4DCDC64D59F27F924ABD8BC48BD94C19F34835B277E19FF3E54
+8262C82345D91F9C55264EC7AA36EE86E39D23111202B922B1077A1D8D27E10C
+8445DE03792EB23648CD46D47456178B95773F526EF13B976EBF32A158CEA0A1
+B7EF3D9DBF6EA57352A4DFEE020D8664E8A1E98964975B7312565A66DAFB4827
+A82418153883BEA2F7D4DB653B9C07F092DD81663EBC2B53A272F87E70252916
+A2EF6CB783F782BBAA7355A594EEC0EA2622BFC89DE290884B21B81053DD98A6
+6AD2EA32488135444C13B267099BC8D3E43FF8AB26EE9AF552F24BE51C5CCD38
+874181E83B4F9020B47292AFA5B39361E84D8AC0511E6A7AA8043026EAD6945B
+511835CE7075E84299271A7BCDA5C229C8FEAEC078FFE75F092F5FAC0B4E0D01
+1C6A42D748811384DAAD2D9D8081382E9DF051BA70361E4441D99682964C6523
+FD7AB8D5C13CC9DA92EAE76548E7B53FB1FD1B2310F5AE2CFC9AA70BEB8203F0
+4F34F37A320BA45CD77EABC12926596D590B37AF37E6CFB56B016A3ED1AE0B97
+EECE053EFFB83F4EF517ACC98CA4C5B8293191CD2E2A9EB26F834973D6361BAF
+77800E410E390190780EDCF385F054024A4C7A5FFC6E5437F69F7AAE5647A81C
+42D0CB9215203DBCCA81132438BC3CA087BF2C28F3F355B6360636536D1477AA
+33CCABE85D06007BCB72D4C2557D942294E21B539F29C50CC86C26B1CFE4EBBB
+A032AB613BE16B13B62B20AF72B74FEF827D1B56BB34565A444F40B7A59ED22C
+44265A44DE87AF36B3BEA1FC7018A59A7DFF9C4C70BF4F87CC96E1D57B70E460
+3F16FFAB8D08191356572444E5E21BC140BC3B1186F351791E95B6F599B9FDBF
+4017EC5DBAC32E7E2977EFE5DA7B7DCCD0741C2251A37E245F03D05F021718C3
+29EF760D50E1B34BAD9CCF5EE65E7BF7811128A6754B516D76FB92A8FDB70296
+9EDC1E45495259B030EF2D648542FAEA3C50FBBC06AC3EC5F7A773DFEB184496
+31208EAA5AABE401000B8F5159CE47333F2AEA6DB5BC30E5F3D96BC88CCBA56B
+4924865123C3A27437EC9BDD494973FA4526D89BA59E5A88297BBF7D393165E1
+9CC5FBD865145BC171D780A76ACCDEB5A33CCA11ACEF0F764046BE83503A48DE
+CC500AEB869A72BDFF2037A38D61866AF9B45297D2419BE813BF36D399072CE2
+BB88789D351DC75E9A99AB74BE948B9472327A573E924AD59FE2D1DED38B8144
+5E1E6CFAAD7F0AF9C2B9026EA63B084AD3D08C578A15E419F1EBF18E8781B9FD
+2100FE4E6C5DEE0D83D4B79A531DBBB001AB59DDC54BF5E9583AD3B8FE5B2106
+04B231BCE544BA345B8CE72060014060C32EAB34365CA4B4E8A99125903A38A5
+F96EE84236C807AF259181579A80772C6B565BB730E35027AA11886897144340
+46CA9B73472CBDEA24964D38856481843B77B492496D6168FBBC85A4FC8AFFDB
+1EB27EC9329967C2280B22793AD6C011B7A75A55C00B4AC16A276047AE51EA94
+08DCA3E448296D056FC2D15FA141105AFEE65AC1FCD6B3EF93D489E04E9EE0CB
+0E6ECFC092DB566C0E4AA24723B491928229202F63014A9ACB32A27590C96A21
+2AA3C0666F709FB5C747E8ECEF81377C6C3555A2A1B1FB7C5E8914F533CC53FE
+5FDC99969895D626F23DDB141B11929F28F430598C69B0CAAD8F965F4FE730C1
+276326C2699F7F1DC940FC02DE168B09F254F35EC1BAABC5770B92C0DA23AC4F
+A83ABD92FBB651137C435EBE1D359E07729BB77F07A8051146C7274DEB8F0645
+7BB9C4BD185CC44911C47A03D2FFBC8464266AB1C7AB258078285D4621ED7C8E
+F9614DDB91E0653AA0759935D49E9A5B4BF0176CB9C1073A11062F8CE9D1A94A
+307221E2A22065E1E7648DC15630ECF9AB4106AD08729F9E108411C6E1644DE1
+C0E162A1B4BF68AB00A33857B3A97663D0769B1EE3225D892B5C479C995458B0
+2F466B74E100CE78031688D1582007F1A6B050AB69A1FF06ACD0218118674355
+AFED5D80C0E71E72A18D903DCD14B52750433D3CC8FAB49838AA4FF9DD84A2E0
+16A222E7E44F4CB0E5C497296D33326B63A4DDAE12439976D054A0DBF79A4A60
+D859CAE9726C4CDDCB29622CEC52A6F108C60530498BD3DD4852F0AF2D44B60F
+0E6C7B1E09F837A411DD8B29C53B42FD3F47D73E379D68B6CAC4E9C53543DC70
+36589E43D26FC49DC1D35638C061084BF96FD2126FC5555B51F431F349E131E2
+A6543573356EB0C03F8766353045D6E67CDF958E0821BBD15B155AE112CF1A83
+278F6E0438A82CFF68B336C5008A828FA4CA2F79CD4A3EE8D2C58B755BD98431
+49671B7826712910F120E7D63759E520349425A4951501591A8A49ADFD6AC629
+965E329D83C84CD1ECCF04225E56B236EE3D41A4C5422DB06AC24510AD9B17D1
+BF97473F22819FACBC05A36582BEFEA41C96DF3F8F385C083D757C9F9CB05560
+FED5E185FBBCB53EB1D7830C72454621F360A7235450584A9E055A0DF95F9AFF
+E7A3E90E88A004FB2C9626C8154703506F2365FAB6AC30EE16C5A392B91F6419
+945D7E76E9698BE973BF34E5A386E42046D1468421D5988D7E1ADAE3A7889040
+D34D8C3758EB44D44E8C75011A85BEB4B5EE0EDBC109D3D1DB2C8D4B3C612B9E
+3C62DD6AA41CCBC403F5FE35D9706C4DC61CC15932007C4B0A55A9D3C34DF4F2
+B542A46A9966CB23D610AC29D1F25C51AC9AB98BAB2F00672AB09F07D24F2C6D
+4DD9D3F696BDB8D8636A311417EBE3C41E3834A30FEA83FFB22A4628EC41D4ED
+BB016F8F2DF42CE256CE2064315D2F354406D33CB209EE0D5AB04CB7103AD9D4
+D1E9B8D96CF7661C6E224C33F3139AEFF8BBDFE9CE55F4882C37C1313E213B20
+2944468D18685BBEF0929B622CF086A69F4511117C8CE0893D30F4E6F4B4DEAB
+2EEA4D708C362CE9897E8CA39221D0DB6EDF46238BBC7B2BF71C7EFA56F59715
+EEF70BEC5B7D686FBFC37EC27F3BD10812CF7BB9F9898A55957FD5881FF88D70
+32F02FF54200EADB6014A1D9589359B1B602557E283654CBF8E7F73D92C0112D
+E55CCEAB2D19096008D31C07274802B6B3FE2ADB56D1E42D28128E9EAEC3C4C3
+3F82EEA7A2BC362203EF5E07EA9B24C712096917312EEA919E0D3605F69401E1
+5CF81B8400A4450D8FFD4946C4B02D195F635D8D83247F30CFE03C0D17D945B6
+9859BFABD3087F3363194A30F64EB6F2B6203CB1ED816963378685B81B168093
+F3BFDFCF49309F152D1476A09C9C95EFF0958FE59C23BF2A6ECCDC492B0853D4
+C4A9E321DF0946FFB5E43D19EA0B8A875584EA980E18E7C837437333C12BF69E
+6D77215ED05BA4A706F321645C7486FA6DA18F7669C1847FDA69F10DD7B2E453
+5A8A5DE7ED65AFDE3FB95D78A739856C7BE274BDF36762D9431954E3FD211BB7
+161DD4E696722A68149E49C5568357112B91EF3E5AB3339F29716EBF11AA97D1
+7F82778689E9917E4AEB24AE3EEDC3426F2960E002D137CC89C22ACC8F1A5DC7
+91DB2B5F4A5792B30DDE4C2D87F8546B5DD4B46F828365DFFEFF325535C5FB2D
+A95AA861560EE82DEE22183004A4FC4211D254749B6CFC6120D90DF2DC508569
+47F4B19B1A53CE7E2F3C4437FE79FFC0A025314B29EF04A9BF01BBFC1116914E
+8DC17A46CE7E783BBA03735CB7205CFC03B020F2C074C55B8AD81AA1D5D842F8
+959E26A432424A8A9F94CACCB8BBC83FF30E1EE10BAC8AB0D4545CF4FF9ED89C
+47F67FDC51E662138E983A069E7A0ACA01235BEBDB8CDD1C15F8CAC649EECF10
+56B4AD8BFDA9CD94526098B90C39CA6E3955AA0E725FFE4B6A83EEA5322811E4
+7E229F4879CE17F2A03DCB4E998E742D749C1801D160E28BBECD8B2FDCE3B981
+FB9A28DD54AB3695A2379F68F9DE1CAB25D87CE0EF5C937675E45969BDAD716B
+BE4AFA8A9492C404D4C35F29EE7D4D8722A3A52358DA2A4F208189226992F0C3
+597397EBAB7D6C8862FFE9BBFEDFF1A99D67F21CEB66C072AEA93D5B219D2D6D
+058AECDC7CD76909259FEB844CFC6DF4DCEB241133640EC83AE7DC19F8A9601F
+145C1338C28A3C3F057F50E910EC0A85F27B4F65FC21F3D2ED2E5E7ECC954F6B
+7E7DF6B4A87DDF2B73E618FDCDDA5858E66B6E324FE2CC79D6AFF896685F4BCE
+D4DF0EBB8DEE89196839163D0033CAFA3D61E6008C2A310EDB1F028529238362
+A3A9A427A31D21E3B1D29D695D57ACAEB739E302D816AA57920A2634E58DEB64
+41C73DBAB698142AF5F42BCD515BD907D6FBB87FC982AD9EFC1D5F60430C81D9
+0E907C8CF3362CD7CDFC45CABB4CE21BD9D909B31B399E7FE20215A55963DB70
+AFA0EC86B776DD313E5255D2917F70CA647661C65784F57C6002E10A81FC5CA4
+075A766CF23739F6BDA9FF9E5F5BB2994385F7611044DA8FD845CD4BC968E7BF
+0DC302915FFE45E72909271A055FB1C21B417459785F333B4CAB29CDC9D3F840
+75F4EC8328671311FCF085F201DEF347EDC33D69F0F3C3AA487E9A896712CE69
+F096E730D8B8E9614246FD26DBFF8CFB0CAD53D5A2D3B000E3EB1A4FE6F422C4
+37943906D458893FAC26E38279699314DB9D25D736D633A3D73BAD3CC54B6B38
+645B45D20428113725B0589A981A8C1048D4CCEE2ADE5FCBF09FEBF681BE6596
+E02438E78D4720482939FD9609F0733AA7C4DECDD0F188493E770C4919EF1F80
+F081D19FBFDF2EF92B638A4EFF06208C2FD20FB667F759B7A636F1556E5079D6
+36CAA6BBFC185B58B52B0353FB64854BFE53111E0D6B91390267118ACD6438C5
+57110D27B2DAE9CEC38DCEB96CA5209D197D59F74B98B2BCCDBADC6A82C3D4C0
+211EFE658A1756787F0EFFBF0F6CEEA8BD2068748F4708220F1ADE6C9F5086F8
+CD233F74439091DA558D2DF7073CF6EF5DE3E67B394E92480AF2AA43C2E558E4
+248C26234D032B58FED430FD1ABA6FBE459F0DA401EDB85A155F1FD30A828BEB
+1D2DC96BD371F06A4FDFEF2E6BB1789DF2631E7B04C04FE3F90F1B65021731BE
+13D6070741D0F0FE4F89699301C7E65669040B10B42C14D966022BF0F07265C0
+F98C7DD83E607FBBA6F348783213290B55D2628AD410BE20FE4183B5754F8750
+DC73DBBFEA0C308599884517D61AD0CFE69ABDB7469328B3A0301775DB74E57C
+578111C93FEA88ADE918A04DDB4C6BB748D2FCC02298441411ABACD4F61ABC0B
+CF748C1CCD12BD1C6B42236A4CB0A0F0B7092B4F75990FB63C46430C2CF66DD5
+FBBEE4EE8C577D0FFFBEEEA4DA57B12EC4285D8B1BC15B8B35A0225533F940AF
+E2E6457EA001282C4861236DD778290E0168D93F83CC88AB1359C574B8969B53
+8705F33E36FD26F68E335080BFC693E5CD46B94D703D409DA085D0EEB973A56C
+CCB479D3579657ACFDEFDB9776B86B43F1874AA25EA68F28740C100504A04D0D
+5AFCBBE1138F0937CC604F330A30FE961357AE498466CA19B3BA01968F33812A
+4269542D558C1F4E0ADD01C2A7C87B4B7270E42120D8F4479E089B34428FE3AD
+F8919D4A80E5FFB2721EAE3C124F573BECB404B494E126117AC5973A3F41A994
+F4282F1251034E171D81288950A2290D9E491810EEFA6DBC472908EB40FA48F3
+77914A5ED42972018FDDFA698E6FD8B506F18016DA74990BC9FFAA70A982B600
+47265D16F3BBE6E3311C7DE428B640CE150725A77B2A505E6C460F81732C9FE3
+92E2C03C8EE7D07A033B591267478974782E1048E0FDA5CA64A60817F218FB89
+62E00EB84256056AA0707D0E657A66B0D4866BBA754C51B6DAE7D839A457047E
+B38D3367A9FB25A4387BC4F89E93F6072ACCA89B86292F4C134D495CBAECF541
+CEA0DD0017C07081A57402DFE6E4F4E16594AB451B7AA6F7BF3BA02DA1E86D0E
+372496EEF52B1E837C17426E6BE657916D6913417D1CE7F7864FBE7A8491AE0A
+DC6109137084CA2A03CA661B7B145AE94755539057EC57D2589C61A2BFF7916E
+AD998095E2A3BEFEB2531FDF5D15D2AE2FC6BA2D565E9DB7DE3427B77308370B
+2ECC0ACAD51B951A847A9B834ECD32AC54DBE058AE93255E55DEF73714C4033A
+3ADE09B98DDA30E43914BBFBF540C059CB55F6257AF92457D527A4A10915B2BF
+A8989D486F715495C23565F95BD0FD3A24BFD020C7205C28453CEC3FE3D5D706
+2FDB6C81C7775D46D497FABF03CDEBB4850C6B15F409F0C679A8EAD7D6C2643D
+346AC006BC6532E1670037AC69ABCA8B795CEE7A58B702F41024B0726DA0178D
+FF650E1A08ECE2D624E88B1AA193144F89D56DC12D6136966119839C852FC38F
+766B363DAA079D936DE526B880CDD5AFC4E2A3E2BA31E8E45FE7B7FACD7557CB
+E7977C5101CC2BC589151F97E591078DA827BB552EE9695BFEE0AFBD4EDDEBB1
+0D4EE3227DA54E834664BE0F7AE90CBD43CA57AFC7DA02E7D44493C73A69D464
+0389D7673B86E34BE62935F862F953F5E394920A63AAAEC49C7AAD61D108253D
+8D28A5E5E6C86DD9632ABB737CE4319D14A49CBCE4ED22E37E74D61397791F8D
+398882D814860BE3B86E4AAB856587C2CC6761A2F621F10F7B8E937FF6D5C3DA
+85CE06729569B10DABAD4B3338EE43EB28969C2D85483AAEA0186B96528CE435
+DE327D74FCAFDD0AB2046D4BC9A216D84858AB2E62E830E4F83904E04A2660CE
+91CFC0E24EB10AFD612EF8E906CC2239AC2CEB2E49B33399DF0458D5177D8937
+BE0B4A11AB5AC76046E62C7AE5689308DAA341AFB6C8079297ECCE63E8A67B75
+E12B11099FC8563BDB73561A8F7DEB5CF7366DFB6BA91E81848AFFF2CBF418D0
+2BB202DA5F20AD6CFE2D94669B871008DE9FF3064C53F1CF1D38FF4974F4FB79
+E5266BD608D30900EA0949610CA38CA49453DA0973EC4C39AD1F4A3D4666F907
+10A4AF715CD74F03E388E7974B70F3DECD1AE4F7FF3634F89C3DBDB93E5D8A02
+ADFA9DC36AC6129DB20F8590000DA408825DFA778F51F1AC613C2EEEEB8E888D
+FAE2739124AAB0DD9BE8B1B5AE12DEC80897E23998F5837DB1C5B336931F0704
+5485FD8C6AE01D927A5BA69F3BD8CBDFFDD18885E16C84CE7C8631514EBEE66C
+8BC7B6731A22C1E8F15450466E2C35966E51388B7631763B338B6EDFEC06BC58
+AE53D7DE19F6B6C3A681D4ED3922ADF4A5D7B77E50C8CD2C96F27F292D2D84CE
+7612C82EE9F5EACC53E97108D2B057E0F936AF334D0680D56A5511E52B9CB7BD
+723EACF18CDCA9F04F62C6C88643A9979B62670AECCC85D460104946CDA768AC
+41F5779AAE7E38BA391948D8F8C259E72CEF6D541D90A53CBDA4DD0E4F2EF337
+DCACC724584FD115420FCDFE2868F4F803F92628E14116D6BF82325533F0569E
+5A7A4D228FE23AD71113E9F7C6F79CAE92F369CD8E6EAB5DDC9D174B5341118D
+6E099D24003FD64F7D5A5BC4A263134654215802D5B85DE158D04D314B075CB4
+19F34B77EF531DA73C669527B56A3C969DD4E5AFFC246CCD365403FEFEB328C2
+48B0A169EACEC8545FEDD8F64D96F3467ECC185C9FA920B0ACD69D8BAF94EA37
+C53B21F1F3C4A9971BA16E18E7B4F1F68EC82633CDFB36711A745257A1A2A684
+3DEBA577013B5EB98C7A2665BABC96E33ECA158FC0D7951D13866CE509A86C1C
+72CCB7FB99CD6EB800D10A37291456CFD416F8C4CD65B02DC8E4FB85670E143B
+865B5C6BDE3AA9C99A5ECC92C4D6FC4775AE0BC2B4AA78B5FC247D53BF3A8904
+8BFA3C112549B5FAFA87000E2CD1403980C310401C06FC4CCFA4020BCE77DA44
+D436A2B33BE679D70FE6CE10ADDB4E6456296310B0080160351278C6E6DF2618
+6C482A06B618DF01A4C8923F213DB9B1B62C7B5554D0427F97D23BFB79F487BB
+8A4815E7E22BAA40E5DBA80EAFA4427EC41D8D75D8518D9628FE7D6E7E7DB397
+610B5E3D085150EF9372EC34261314C64C1E734D9EC5EA86D328500A3BC10A6E
+45114FDFEE9F96F4FF0722904B5E6573A0AF120B84B78060B4BF077376142088
+CFE67D184A429C5540761B6600F0FA686CDEC8B6FE4DCE8E2951F988D8A0E9BB
+AC82846E9ADF1CB03A5A641B7FE90EC46A604EAA22DADB05CBA24E1A1E10FBF4
+1B627328A620CF0A6ED895A6A0F81F37E32D6C7145DF69579C94FE0BEB0EBE71
+9A6FC70BCC1B248D3EC7DBF8082692B816474ADF169ACC0DD57AC41DE6D07098
+6D7FCD04D2C054FB176E65EEBC9D98A6EE54A92A747EABA0E898170E30716EF0
+BBE2C9352F39D652E456B3D6F37491304E32847015D777B7C7D23545C700725B
+903D1629619E13BB44E2FDCFE916A7A2D6ED3AD770807CC1C35D300C71626958
+1E80C2E6B76E93970DAB0A47E03FBB4B143F35A874A3B294FE2484D398D82A9F
+D3BD0E1A20DE52BFB657CCED6B5430122CE302F0459623F5FA044057EA4CC332
+BEC2BA2AA9486DD5F59F8E809A203BE40B525725C383ADB44901B42A4E22EBBC
+3C5FC954E51139AA3FF3E970120F87B0B7E231BF6D3AABB2F26913F41BF03973
+41B5980A7A8032D6CE660384999918F5FCF5606B2E7E6788CD93123C2CB48D66
+5C8FA4932F5056CE952DD3DCD5338DCB9D12ECDE3C640ECCC69FD9ED4A8856C2
+1E2D3469A8F01F617F1EF188E9871A30430B7F4978CB0CB3C54A34139A76457C
+874A2BD48BD047862C8EC9EDAAB6EB17E4B51A13D47DCEAAFFEA8095ABF16784
+2DBD8CD31AD961D3BF65071E87EA32C2D06C2F5C731AE3F30C8F7160D1455699
+D1B9C4E08FBCCBEF69A6EAA828D38857C2C04F7B033274510766096EC1837B22
+120EF5892DD2AD6D3DBCF3679E613AB58F7DBB155942EF9E9DEA3971939DED7F
+F9156223DCD0F6B3BC9D31634C6E8928D1A9E5453A34C9F5A2AB3467E591C64F
+AC7E0E23B2A08F540634544350DCDA2F1B2962315B5475A72EA2E1891316740F
+5BA63BBE26359EA9CDF754DEE50177A07B5F13FA824585BF40177531CD9FE47F
+AC05950B3ED5C87C3408441225D02691EAD45D09DBE8D8A1665D18CC0E5CCA00
+F1993040E6BEC9213144D1D95E9DF7CCEC67714A02F270F25419FE6AB8A3DD9B
+FD22F334D24EDF187826CEAD412B0254DA6ABD8D106D24314B084F2D1A82AFBA
+808634BC6712C91164CCFECD49ADA688CC9DF4139B845FD26B1C0EB1C34167C9
+C4270C9DF76E66D32304679DC2724FDCBD81E0A320953CBBBDC3926329D51C2C
+C17C20953118CC13DBE72C963BA0074212F2280D6BFEF21E237A1A3F8FB6D66E
+9F385CB670F96C966AA708E94141D63EF11842A0B13BD2A542EA9994C915BD83
+C239C68A49651F4080DC80F5DC5521EA74099EBB9231CD4D87963D969ACCAF39
+B5BCE555547939D8D7D00171D3E372482C796BD99CE8FB2A11BFD621CEF6A8EE
+027DD8410CC3C1445A737E466F95C76CC619169C6B6147C34F1339420C22D347
+EED962A9F03B1D20769B1410F2BC2B7E15C13B73FB6C7AEF9DF27C6221C52681
+E210E6C27882465398FD118EF6D6FE61C21FA581DAF7E7A542600D4534064DD4
+E538C97701BE46987D474851C83C65FCD348B358A54E8F794B45745D6CD7FC6E
+387F728497F1D699B45BBD01EB07D6CC932C2D23CF09F793B6B52B155652DA2C
+C0495E024F8CAB0BD6AB659CFB16F3874DFF4E6BF3C27F1152CD26069429DFB2
+ABA9F1EAECA513351C5B3AFD41D169201D75DABD4513C0B037DEEA11F39B1F87
+BE990817E4BBA5B62BDC40D611B9F05207E2FBB61D965DB8AE417B86343ACE0C
+B2C23032DA2D41CF7771B5E6A729691888D07AE0DAA24C782DBD2DEF602D281C
+0A0654B537802B5D08F6E23D9E1750EAA9224228A7AFAEC8C3AE96D2F2CA41D8
+BE7939B66C06F6D38DF76269E7F36EC2DB950DF5FC78ADC0FAE4264309B4EBA3
+39B0C44215924E77FDD303A68B8CEAAC2CE88757CE3A7D54CF2C2F5D9505D46D
+2E93312A8EE2D5D788491E59BDA74135CC2083434565002D280902C94C15664B
+F370B3F544B1D3FA28FFFC245C41BF1A340E1E9CE55AF22FE567EC7FFE594552
+FA42F4BD011EA68D234B7F628A11168E7BC905C1A2883EF818A3D6FFB92D5110
+109022EA3C4D4B86367A7B396095D71169442600A35F1BBA46C8E1E8A053443F
+D2A4E4721B90095B0D14DC098D2FE7722BFD1B588C0FDCB5027E46A86A5C9215
+02AD5DE5C7A4B5EC23E7953981656D9BA91A42A603D4FF1A4B3E9F601B0204CB
+3B6ED597FA8A601CF34F509BA6E2F24CB18B9E9CAE33A58E12D8CAF9C49E7A9A
+ECF60F7001517FD70492E482FBBBD49E7B
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMMI12
+%!PS-AdobeFont-1.1: CMMI12 1.100
+%%CreationDate: 1996 Jul 27 08:57:55
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.100) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMMI12) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle -14.04 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMMI12 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-30 -250 1026 750}readonly def
+/UniqueID 5087386 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA0529731C99A784CCBE85B4993B2EEBDE
+3B12D472B7CF54651EF21185116A69AB1096ED4BAD2F646635E019B6417CC77B
+532F85D811C70D1429A19A5307EF63EB5C5E02C89FC6C20F6D9D89E7D91FE470
+B72BEFDA23F5DF76BE05AF4CE93137A219ED8A04A9D7D6FDF37E6B7FCDE0D90B
+986423E5960A5D9FBB4C956556E8DF90CBFAEC476FA36FD9A5C8175C9AF513FE
+D919C2DDD26BDC0D99398B9F4D03D6A8F05B47AF95EF28A9C561DBDC98C47CF5
+5250011D19E9366EB6FD153D3A100CAA6212E3D5D93990737F8D326D347B7EDC
+4391C9DF440285B8FC159D0E98D4258FC57892DCC57F7903449E07914FBE9E67
+3C15C2153C061EB541F66C11E7EE77D5D77C0B11E1AC55101DA976CCACAB6993
+EED1406FBB7FF30EAC9E90B90B2AF4EC7C273CA32F11A5C1426FF641B4A2FB2F
+4E68635C93DB835737567FAF8471CBC05078DCD4E40E25A2F4E5AF46C234CF59
+2A1CE8F39E1BA1B2A594355637E474167EAD4D97D51AF0A899B44387E1FD933A
+323AFDA6BA740534A510B4705C0A15647AFBF3E53A82BF320DD96753639BE49C
+2F79A1988863EF977B800C9DB5B42039C23EB86953713F730E03EA22FF7BB2C1
+D97D33FD77B1BDCC2A60B12CF7805CFC90C5B914C0F30A673DF9587F93E47CEA
+5932DD1930560C4F0D97547BCD805D6D854455B13A4D7382A22F562D7C55041F
+0FD294BDAA1834820F894265A667E5C97D95FF152531EF97258F56374502865D
+A1E7C0C5FB7C6FB7D3C43FEB3431095A59FBF6F61CEC6D6DEE09F4EB0FD70D77
+2A8B0A4984C6120293F6B947944BE23259F6EB64303D627353163B6505FC8A60
+00681F7A3968B6CBB49E0420A691258F5E7B07B417157803FCBE9B9FB1F80FD8
+CA0BD2E774E4D04F1F0CB9AD88152DF9799FB90EC43955871EB7F0338141CF69
+3A94F81431168EFFF7462ABF70F1AAD9909E0183601E417073F4EC7DF0180A48
+73C309956ED2BC852965D7D4EF3F2A3F2A798CD61AE418D9573497D3911F5323
+ED3496F6AEBE685EE322F58EA7402EF6A7B6EB9E433EB7D0F6E3C3BDAD24F983
+AC4415A43C9687642E3BF1E4F4A99F03FA39177E5FFF4A9205E20954906ACE66
+1BF1C9E2E43707530FF446F58B37C73CF2857A7ABB3355DC42F2E66AAA8E40FB
+4F9A575B9C83CF9529A2AF30DA023468630AF059A7DC07EFF8041298B7AAEE9F
+010E4C93C08FCDA085657E92D98E9B33E1A28D3DA18FCBCBC7839C0744DD5CE0
+17FCC070EFE545CB2387F92A4B74262D7729B2DD458248397176142195B59718
+AA5429ED39CDE4F9CD1F92837B1EDAC168765EDD6395239B7C1CC552A6EC2A8A
+76E87AE3D015F874FECEF9406C030BE3732916C975F583FC660BE945F1A3EEFA
+A3B4E315BC32CF5EC239A9CC1B8ACB2C09540B1A42B6D057F6EC11DC7BD2F474
+72592808C08B7725B4F629671C96961BEA8F3C44C56A09C74FEE732584F36B00
+27977D6B37B2827E64FF0CA96215E62E3A5B7482D08C0D1233544A78D7741D67
+89F43C3C7FF19E89F4899777AA6DB7E0250B519587164D15BC75E010037B3832
+9AB475694922DCF1714BA2D4F56477A653DA395A55DED91178B6FEDB13BEEA02
+64D39E3DFB7765742E60E70E5C5D597375C5140E3851D25DAA0F28C26DF07D1C
+079E556C51956D0957EB2074C5F64C7273311F5EF4154E828CA56E63115F1A4B
+4CED1CC44BB69DD41DE505CB7AE6CE3E28286CE765EA0CAA9AA3FC9CDDCB644E
+9B0AE1B58CB4720FE2424EF95958270EDF8444E6A9DE61FA4A5C590363FBAF40
+82C18151F507B7CF4BE12C1409245FF9B901EA53205C1141037362500708E825
+60241C33419F08E83F0F8483325D6CDA7FD17DA8ED40189C2A1B51EB5F6FA69C
+D667289E27478D44D1B91A4472989D46ABAA727B0DE7F8DC771A5DF4877FCF3A
+6C12A864F36C5C47CEEB9FF0E9E4EB794E946C5938C464161EB1E19F518A96E1
+4A6278DCDEE3592AC76152CF8D67B23A34452524E8CC6DD5E214DB5E5C54967C
+0094A54154872D53A2B4E1F2FC4A4F367575C4FD5E9825C595FA8BC2CB77826F
+EB37485B802E41D9E3A24C316D2EE98F5091E723D8FB0FDB6A1E70A48607B19D
+F1C03EB8A6D73B86ED41AC4373BA7A13E2F558A19643DD2BACD71D97DDF4BD94
+D4B3637866F9F2FC3CBCA20067D0612A3E899ADE22405DBB504441A0D62121CF
+13DE38B856746BABB263AEE6CEFF897A7D923E583152D4458D10EEA1E10734AC
+D31D9E5FE8DF75AAC3276F7945B1E8B1BD090E379256E66D56A91DD70D07D9BF
+2249871803E59CDD5DDDED84923F6B2B2B5AED8924D206E2022494796734B9F4
+E902A171EC4D455D47264423DCB7DABB58A62CA9F8E08F095EF498B81C232537
+E079C151ECA933BF1BD64F1FE0CDD5DD7D3C300EDB6927561FF054A26CC629D0
+72411BE00D360FE4C6580CCC032FD787848C6013EBD9639B2ECFD30755B45123
+E3CBABE020D8FD971108C940D6F601D0782E9342F03182E6D1141089C5FD6B90
+2E71310DFD4E10AFFDD13272FB857EF3CFB46454819E06AE011419A8EA22F30C
+6B93A40743A51D05CE4F5A5EBF6B7F78182AA14165DBFD8C29EC66E1FF9BB143
+9D165F9D9C82ABE605655D89A9788049052EA0E022EF8EAEC9652C1DDE637026
+508F01285D725E2E0748B37316563F33B10F7352C956D1E9F3251BC6F1E0E208
+FE4A56247FE901A9D1AE2BBE7354918D9E35288E91CE882F3FCDC1E8DA0BE9E8
+4B4CD8D9F3BBECDC8BDAA394848784EDF5463F20F4FA7525907578E0526E15ED
+033F370D6EB0BAAEAE762791CBA974E6711530EE4D9821A679974F188F59E7AB
+ECDD87C6DF243F3F91C3FC2634744EE2ACDF29326E98213DEA243E2F8C4D71D8
+864D670687FD4F575C3AC99C4D6E6D97FE28C401ED5A743F77F7956ACBECCE77
+3D82FC85F8BD86B023BE114A4592C0D133221EBD148F833176AD973C4F773ADF
+4EDD82B56C6F2964EAC8CB0257C5C94ADF48B31CEFB237CF021158D127558A97
+F5F5900C9851CB1422FDDE682C438593030659F9B97881585E64A1A7A45E4420
+CEC1BC3FF4738990BF5CCA2AAF35BD641BE34B7C1455D1D06CBDACA6E6E3399F
+FFBD640CC187C107C8FDBCC4F2F9EF74D8CF274854ABA0590A7F61A33A91327E
+7EC8713104901FEA339D27EA79FE4AD8AF400C63AADD44A3FE798F2AC69F601B
+F1AA591CC831CFFFB5510D371DDBB0733A2BB75FFC1A34D6DFC379021B802895
+55A7229BBB3A6D6D29EE614F122ED7B0AE28F6311D415DCF1AFEDCF31C7ED9BA
+6057695EDD15659FB3D2AE0CF89C9F1FE31319B0000155CCD900261C0CFB2DC0
+85122FFD28CC3CA2D62AC136C830A0FECC4BDF319A63C900BCA62D5F78AF9A74
+92FA56DB8C6557B3E21914470BB9BF3A06171A9D8891626E088344265D73A2B3
+19877EF9EFFC4E76CDD07A58BC0F2ECC98220BA3EBC9F88DA3F4B2D9AE80D6FC
+E19DBA0AEC849A2854D101D556A92C90F5AC0B0F8A21ABCE283E7EACC3677046
+3B4AB5E7EF5D02428B8B5C5D2FACC73BBDE677F286F23D99DAFD813E5AD101F7
+A343FD45B41E39DACE245F836A91F065D4C1417F5326D4EDC61A168726B938B9
+1CE28AE359F9BC1F2F679E4C65A7EBC98A34A58314F0814AAA02FBA2224A7FD6
+82784F5BE202159BA94D96B72B04AB55CB98ED4D58567CF7579E98C3F902DDA4
+B3EEA870C9306069D5915D714C237320A3696C85230C322D5CA53B54860FC213
+4BC2577B94DDEC306F3E7A51E72D22BED902D56D47114A7FC0F2C9C73D654E67
+11C4A479ED23503317964E371E76C385CE16F9AD8A1D779242927882F050B78C
+1067002C7F27084A867B674349EA2DF68B929005E1D4DE2634E26C023FEB66D4
+8EC105813EAF27F5B463D874FE25F4DB42A2779BE72D0B8EB84D46440BF780B4
+E40C0020A7FE0F75667721A41622BC37CE2232D8B38A9A5E80A400887A62011D
+78C2194AC5C3C47F9549C65B3CEA0B78F3DA162F6A566B367933F1AA7DC438D0
+66B6CC616682181A5C3D3100394772500D8C4B7FFF910F253D92C86CB9DD3724
+C6FD47B949F5F73482C131112CE1F431D69CFF6397E99F93C8319E749A0EEC11
+08A4F730E7E8045F51E6690569E188154BF6A1EB1262E798D842F8CEBBDDF060
+D3225CE9AAAD1C9EF917B99203C02CFF2924631CEC6503432576C10D89F80007
+E3D55AC0CD03D10C0D8ADB80E5401FE69B67D7869C29D0BE187C304F2A1216FC
+345BD2A76220FD93510D7CD1EF0AFD43C296252A6BA847EC0555A75A9192AEEF
+F5AC066515CCEFA0D92B0B4C50867E868A97A48E42F02E4C7DA0ADD1028053A4
+516ABF159566902AE5DF433E6B6F55BC400CCE4AB26E0DAC60272267E2B68238
+84A1BAF0711393758B36680ABAEACEBD4665CB03D963D73E059DCBFCEFEB1173
+E15FF86F663FEB2681EE9AB7A73C72049276E94A4372838882F62E0B0B3EBC7B
+59C827526E7AD090EB6087431930987812947D3575CD1FAF41E39EEDED6F43DF
+C89826B882ED56710C34033BF50D0BC1B62AFF156B7B94E32BF87F614F7D3D1B
+E9FC6676E84EFDD95192AC2B2A4A85EE91E139B7AB5D8DD329DB252B74D3291B
+9E615AF3EE7A5D2568C67502C894DD07322AAC0B5CF4A7DA4F3E2AC93186072C
+40BBFCFF67EBCFACBE22500F7807336B38271234BE99AAD357868F485EF0E7AB
+B58DD540D5F32478456A32A8F4DBBE0AB5CBC5824D0E880E8EB944009DAD5952
+592FB8F1A3DB16E0A055DB304F7FB1959147E01BC42CDEF7E113E1E0DA1B9EAE
+E1A05F88B5E7C81F01FD4F9ED84CB1EA0F470FB8ED67E58263E9DB9810774739
+29A0AE45A02A0584DCA2FD70285F332A97AED7DC326D5CE56FBE3044E69359D8
+280ECFD7BF3786B54D610E7A87CB5BA9C8BB60C30CD3A0B085790C23D47B7068
+26CD671E3A7159BAD981DEC64A49AB99EB1098FDFFDF3998C233878239EFCB4A
+591DE2852A26DE144BD41B6523547F1FB1C8610A5B7CF87152888097E80CCA64
+962B9B422FEB6A8428B232D6370CC9C2A752E6EF7240EC49289A5C3C7D9B188D
+1163EC9382C98D4D183546A6583A0C3249444EF7808326F0E2D368CCD9BE31E4
+A0C1F2F0B3253D61A99C57A64F91AB4AAE6D31C391C73DC9E765F2642956CFCD
+4D45DAB37BCC23AAB975DC9ED49FA3C21F9AAC31B72690F4A442073B944BEA73
+6A31D939B1AA02A87E2579404A07D3760E0B0ED7E4021F5264682E5E0EFA089F
+1005F728028B93DC0FD17184DFF5081FB8390FE6C0BA8BBCB2042EDCE2E03BCC
+41DF720F0EE15B888AB9F4CC87EBA8BF19D945311C5681EAD2DB6EB02F34EDEF
+7C5DAED979125E16DDFD4117BA1B9A1604F079E5ACBD2BAED6FAAE17084211B0
+A886BB089BF11A3389164FFB24C50800246550CB126B61015C523B40E17459F4
+A65CD8E951423799507A866513F2B3B0D2530554091550318B3B735059E67AF8
+B7A8B0FF324DCC37AB9BE86516F64AE929C350692DB6619B80206DA73A168850
+19DDCEA0A30550ADD8F61D77D8B6D555784B36B7AB82DE4C1079C9562E58904B
+E2D7DA63AE7612854680BB2B86C1B8DE3F5770934DDB2E6FBBE3656E0544120C
+C7CD36D04A45BDA6BFFFCC5E9CD4C9E05C249FD1F9139260CF64173F44544578
+254A0D2BF097B20BF4A81317B4F7E2226D73B483518D1DD1DBE51ED7F75DB8A5
+6AEA61A3B06F0B1143525D41347F514D19CBA2C5322CD34D6693556FB6D3E32A
+4D68B280466A5FF5B2F4756853E107DE645EB2FCE2566DB563047B20DF3343EA
+7276B3AD0B40423B5CF0B35FB656A8D7D4CB8C565FB1059E28F5E55BD58AF80A
+A472092136900D628F0962AEBC399658CA48AF43F379C2D7C9756AC8DE94E1FB
+239702EE3772B0077EBBE4B49022BD8C9208C2589F61A1E0E46AF7B5248F7298
+D646499B9BC45C8819C6C5B1A77DD055D1040BCE42B026D1B2D76230094C7615
+E652A9D8DF199C05716B85344E69EB14A628C2A9F13F534D41874F38733EF572
+65B5D8957294CAF2DB874AD4AC43578E13F77017D58B33DFB1E6AF08DE48ED70
+F6E6D89548E63008F06CBF24ED3336492F8CB1B6D1C94496ED35CE72CBB31891
+DD4D66F88A4D660AFCB0550206D549688A5F3FDF1AA5E8C23BA6409FD3C753FA
+260D53428BD97750473F05CA4DE404E85F40EA09A92C7A5A2532C929627861E6
+CC4E85662772D26BC2D8A2EDFA5452CD829961B772F44EB9B7F78C20383BA93A
+83894FA07D4D8FC7A5AB0BC1D540478A16002AF73B81C58DB3EC03D9FF15131D
+27D4085A2EC8A6F3F3C8CE307C7D8928EE818E519DEA1A5C50B7A7872E4221F6
+4DFD9EFD008699495117CEF27C9482B4F9E7CB9CBEC411E77BBAB7366236E530
+AA55A34E29DAFC781B4CB16457648E5CE32B16367428B0E2F284BF9DD49E398E
+D8F4DB1280926AF5DDAC3192C96416739B275493096355D19E3B24CCE3F557D9
+FA2A327284752CA1C08D930E74C1B3E31642C958F0BF15F3ACB99B8C28E822D6
+81F83748D8B7513BE1D4CC78930ABF167601C7935FBB9EC7E4FA3D75D07409E7
+2E410889B58C7450361A7403C0DFD5271B4414746FC787BF5924BFB6B2931B70
+7C3F4BC417916095248B9809EA272FC80EFD16CD7A8CFA9EB2CA95975D08E997
+1545AC6E760B99F4143CE1355C240533E002777DD71D4A35CA7A7209617CDA20
+FE37652FED099A82928A9BC50964CF1096D9A1CD73454487A8993C34803D4C24
+9532B94AE9B145D527715D96CF3FFF3F8AFAF5BC10DE5F7044E74616471EC2A4
+F9CEEC17F12809DDDB54AF3FAF269FB8FC361FE050045222ECB55A3B9DCC1BB8
+3CABC563AE2F8289010E4269A8CACE4252C1730B7F4E3660D5A2770F592A2803
+F3786AF66959CB4CEC86DD398D70F2E3B862B1CA9CD9A772DF763E6F916B0847
+433AD245A1BC623385FBD09C3166BD99224E1CE4E7725BA4DE2DD01F2DE6E542
+0E61DB0CC15810B23A2FF95A5DC1BB6289FE22837E2B2F967A2B82E1E75A62B8
+1B3F76AB743E41C1B108AF9E58EBC1FE28944EF0838084416C2A4283748CA403
+636A15DDA9EE7C8F5D9A7EC86C3E79098820485E9D1533E8FEB6328F272CB343
+AB4EA52EA83687CD4AB548CCDF4B88222A33EACD2BF1ED4BF8DECA7BE87724EA
+01EE164C9E764F664C6631B12BC7189CD8E203285EED956E156D837136DF77D0
+A06A98D378A5F360485F7E3A2EC654319765F0B27915D1B589334D5982A91B40
+B558BB1E6FC2FC45EC5F2F75B6462643849E8099D2FDF91BBA138FE220C7FAA4
+F11E5AE7E3717B7FEBE799D5CCD5EE9CF731C38BDCFDD99F3BFC98A03C4D62E5
+AF3F661105881B4507AAEE84F9BCD58D260CF4FBC5AAAA3679282E70E4D35A96
+135CEEF3EB45DADC5722E912DA9E87FB17B5CB0EDB984F474679072D58B33403
+A405A3E73D8CAAEDAE54A25AE5B5C9F9EE22B5C0D4ED0DB7F4633845AD7F153F
+CA8613275AAD7927C083ACBD5E0BA7EC3CEDB92CB0E703A9CD498B4FB8FE4634
+7C5758F73A5D2A7EAD569842605DF6ADEE9FE8925F35B84B2230ED504FA0E85C
+D7FF65CC9F7020F6101DCEDC025D363033E93C5B24DAF626C15B8F259D1964B3
+669F8E9F6712A7A0834ABACF8860D45D9EB69005AE7E9280B4D6C9BD389B1FD0
+0D69896583359F2EBC436802519FB7692876937023E6B3FFC24DF7A8D7D2963B
+015A0B0E06D998696E18BEABB3BC887EB95AB02F5572ECBE5946E067CDE55432
+9254CD967C4F5835A870421C16DCBF859B44EE874C15D9E83DA10278FE06BAEC
+83E9F7D5A4E35D458FBC23A199552E392616DA61DF8A1E730BC3F8CF67F87EF2
+9C2312528DDF1C7B29A57BE84DF5154292DA8CBFDB94EF9BA220F51D4B8AFDDF
+3B6844F81BF5F50E8B19D3A2058E70359B3943A620B5E3D67F3F8C6246834A37
+319FF75F47116561D644D843E712245DF78A111560B469B9EE4AC52D72D98A91
+D8512E98C7487CE056243B906634BF0450B5A71B798E043D716996B585D11603
+026AC0A83F86A779F4D45ED39C1D97097EB172315C07CB3BA65176C4124B0096
+5F92D467E306D3C47A2EC4D0249553ED0C71DBD6E53449C8BFEF672867088B4F
+9BB2DDE4D24AB43766FF48AB208A3EAB034153C1F56E5F5D187C28234BB665BE
+1602320624EF4A9C74EDCBEB4BD26267ABEC41A24A6E52B5526EB6983C052612
+DE8A3982F6401D8EF71024CC3BA136E5AF62FA64DCD4D2CBF35E36A11F9B0246
+4EFBED0D6967941CFFB3476E4B840FB87F2F277F28B5EAE7C349A10CBBF8B888
+BCF4FAEA1F5BE95F9DA866B4F6EDC09398378316D568DD8A62B3445563CA13EA
+2EF61134527E8F4998525D7C016AA390CEED8C68D32826A435AF7ED9DA028B06
+897BD56565C913C4FB5320BE6BB6C9F9185D0AA157A86F656D24542E29875569
+6EECA7760B91AC7AAE495D4D12B069BC850055B24AA4F34F37BBF89FB1B289BE
+D449087A230F649A0EF9ABDCA6150508FEF5866C989662CE087F43A39D3AE9EC
+955C8FEE805986B26BE4EC9CE6EAAC6E39C535EE1CA057B0B3EDBCD43331AF5A
+33F230445CC01FDF182B5E4D6497E556645F09A92E04C1DCB7715D744BEC6DEF
+899EB54C3C59ED55009EAD463330295896DCF8226772B2727644594284AE2807
+347760E3E19BF3B3A01FC9D2343BDE0F36512558A24D49112E2A8D2024DC4C48
+B7C3F704EB37379F1FA2FA27AFC7510C6D25B8C49EC648E82B7E70C3F3E649BA
+DDD15C25E9B97C6D85DDD5E87AD424D23126F6AA89D17C3275604746CA084E69
+852B5A96B84F53052E062CA2C81F6EFC3237C73D6C08E9172559848F60F09825
+F77D51B6B970A6128BB0089A549AA1E1E2326028311CBB31B176D8853804524C
+525900A7059EEC2FF426202591F3FB4B9559C1F39CD3105B11D5F658CD1EA148
+9417B0766609422300A1E3AA11BFBE291CF8DAF17D236DD5F6BC36E84770A76C
+1A9B1381FCDC7FDF0EDDA1E6932ADDB8AD3FC7A89744CC59253E5C5982CA4DF3
+D6DB7F42252697F63390D2B2D98379E8FB271E0EBA5CB0A41BE624B9F8F5332F
+F5E3AB7DAC3F09E27E849F2D67E640779693C2557AA20F156CE1FE87C5FA9A74
+5629D8A1E972F18FF29D7ECCDA8F00CB12AB9861B3340B31E870162E2F029E32
+4AD90CAAF7C13AD3D833984E103E425FF6D0A06C764C63A42426DD318C9CE621
+7E90FF7CC9FBA7F07364FCB9215F1676E665B61BA9FDC3424338085EC91B30F3
+350909CFA2D681B213AAC859A96F3BDB0FAEAFC42EA97C5076ACBAC79A2A5936
+F0E4A5B267B06AC9130A3133AC91C054A2644B4B62C35CD8554DD51C567F2370
+385F0456826CD57B2707DC993FFDC7D5B93D44D1F4EA65DD8BBACAB0BA812C05
+21B1A48F061190E3F2C69466AAB25AE0EA13569CA9A2B78678A6E3DE64F61FDD
+FF2EC99A899325E23C806F57BD41731F024C4E44F349C5F5AF6ACE27BD3407D1
+C3FA28BBDE9A4C5191ED8FD007DCF8191C6B509E328804238E81F69496A124FE
+3B9B0D52F7AABE1D9F82906CAA27D68C1AEFC9F82649350B1EDE6ECD8D946897
+BAD241839EB2B9236F0EDF5DB57D6CD9A9893A9A6E8E20A24811B8C65B319402
+1E39F07A5B65643A688F62AE53E41D2815D9FCE964EC6884856C7E321D023B57
+F6CF25295D68B07B8885F2A6D0696D8939D1FD885D29F35E0804621D6B03AE60
+162DF0F5177B7ECFAB2ADF28B98E19A1EC57CF22EADCD8C60F589A8D0AD758BE
+9FF3C78D5F585958036D1289841B4C902E3016C6B801DA4EB48A4E67D5AD919F
+E20C9AE0D06D7A0AAB04A4C9EFCB8EC48CFECD6BCBCB9DD9C5FD22DDC924DDA3
+146F757BCD1733800E357AB62F54E27FEACEDFABFBD5CE7C931FA8F2BB053748
+3B3D80BFB6D45676B40082A374B6AE6A3E5E47516B3F3ECC6FF7964F27C7E067
+CFC44AD6B76C67A29BB8D95F3165F1CC7CDA83707009D9D3DAF6AC1681AA2EDA
+13BCF09FE4F47AFA59682139F82B7EFC843547A7447D67331AE7D6F1909CA003
+10E3CF4284E288A0A84509740E93DF6C18C5C193617170EBAFA39AF411A21C7C
+B11F715DDB518A76DC3F3AEB6C92BFC62CB84B2FD2768CF3ABAFC360C62B8914
+3033ED3DF169DEC56964971F67632E880FA6AB7610C3E369E5D954686D70439E
+3E897DFF3A45D327EC8C99161401A2D6F0ED296FCABBCB5B9BBF18D3A6447CE4
+948BC4ED52CF06C928EE93C6DCCC3463B71E2D23DF8EE4640CEAFEF830DE4614
+895C4C3A5C006D78166F685CAD46A985B5B9B54EDE4507BD37B4A9497DFF1A94
+64C2F4BAED09823E1FACC9BEDDC2988B36468130AC07459B0C5F9921D559247D
+C7455D0976D07D8EA386CB77E60EF18BBD1197537D097AF336E7B97F7D2849DA
+37DF2EBE4766175C03E6F9B9EB1A2B1F3E60E3E628AB45E8244D47F69F7CC496
+99F45E7793E9160E69887E57329DB1373C12A5EBA3E02CDF02F19CBC28642708
+D783A235AC1A1E909DA80720D71F61E67296B783427A14865A067228F4C6
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMTT12
+%!PS-AdobeFont-1.1: CMTT12 1.0
+%%CreationDate: 1991 Aug 20 16:45:46
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.0) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMTT12) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle 0 def
+/isFixedPitch true def
+end readonly def
+/FontName /CMTT12 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-1 -234 524 695}readonly def
+/UniqueID 5000833 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
+016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
+9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
+D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
+469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
+2BDBF16FBC7512FAA308A093FE5F0364CD5660FE13FF01BC20148F9C480BCD0E
+C81D5BFC66F04993DD73F0BE0AB13F53B1BA79FE5F618A4F672B16C06BE3251E
+3BCB599BFA0E6041FBD558475370D693A959259A2699BA6E97CF40435B8E8A4B
+426343E145DF14E59028D4E0941AB537E34024E6CDE0EA9AF8038A3260A0358D
+D5B1DB53582F0DAB7ADE29CF8DBA0992D5A94672DFF91573F38D9BFD1A57E161
+E52DA1B41433C82261E47F79997DF603935D2A187A95F7A25D148FB3C2B6AA32
+6B982C32C6B25867871ED7B38E150031A3DE568C8D3731A779EAAF09AC5CE6C5
+A129C4147E56882B8068DF37C97C761694F1316AF93E33FF7E0B2F1F252735CE
+0D9F7BCE136B06EE967ABE0C8DF24DCBBF99874702ED252B677F407CB39678CC
+85DDFC2F45C552BA967E4158165ED16FECC4E32AC4D3B3EB8046DCDD37C92FDF
+F1F3710BB8EF5CA358ABACA33C7E5ACAD6BF5DC58BDFC3CF09BA2A38291D45A4
+C15FF1916FE2EC47FDC80911EB9C61F5D355BEDFC9DB17588547763AC5F0B1CC
+12D2FFB32E0803D37E3281DA9CE36C5433655526ACFB3A301C56FAB09DF07B5D
+048B47687348DEB96F3F9C53CE56DDD312B93D3918CD92AF53FB9461864D11B8
+0138918D0B1270C54873C4012CDE6F886DB11BCEA04B023EBB43E0D0A06BE725
+741D08B9DB688731A6C8F9F0B1FDFA20C46ABF1BE836FCA0757242BE4780A41B
+C19304DEC802CBAFBD0D116B1F98C01BF41ACD72DA8C56F8A03756E1850CF32D
+F657FFF4377B43F208A3F33191F9F6F36FBB0CDA3514D68ACD8DCB2FE67AB377
+C6BD16D11FFFD61E05B8B311EBE8D05013ECF1D03F574982E3581A188E337498
+3B68080D69F7D88F2863362577B6566B9526D1E05DCAEE47F7E336489F4CF445
+E5F4E1DD5EF2B795F184EC5B427C77D49CF637A3A593658E040602DCF0F801C4
+ED233C042DA9DED7B46056C1BE1C5226E4BBF67721881B8B10BB8B3B44A5C15D
+DB915593BFD21C1E826814BAD962DE25D059980B437799780D94B79BC5273D40
+0A2CF6EB797CD29DF2C3A6884CC114537BE8E576B5FFFB55874A6CA8DE0CCF4A
+0E2BACCC61F1806653ABDEA497DA2859B730657097828FC7F41A459329B8E06B
+04BBC2735BCE80A33068C52003C0DB7726D52F0CA07D5E90F7A3B4D4CACA8C01
+6DDBB344261BBBF19B60487E6A078E23F4146765794CDE1B696408ADEC91237C
+BEED26DDD11FF92C6206A38E683C6444ED05CF2275FBBF216937AF8A9EE257AC
+E2AF42B121FC3D1320608F3B072A5AB48917B719920D4D920B0ED3D36B763F52
+61182365F3FE177F7864D3418843EACB695F53B08C69F5AE843021816B4D9EFA
+60655CB5C1D57B0B89A9E31E44189C96E61C8E4C21BA987CF6E992FAB8ACF1B7
+629216A3FF2AE3BD8CB5BACBFF604D14C913EFABFAD30FE1F49EDD55DB655EE2
+2BF9A5565770851B4BD0AF197A9EF3F68CAFFC30955B9E08ACDD7C35E9F35F84
+B22BC7F7620045C1426295023FB4B7B6272F5495702B2F5AD5E67BE9B24F7A0A
+7780F752495B7B56D27FD494CDB9606F10E1D90A086614CDB693C4C78C598743
+EF33E3B7AD68D04A5509FC1AE21AFD9540462354DC62E269DE39263B018B6899
+4FCAE052CC75FE78F3892E661B7F74114A529314E59EB7489A649B4B1FF4EE43
+9D1C0B4CBC5127DD2F760BECDDBBCC398061E39F57F5DE0819878358C28CF7E9
+424F3A33046D2C358B5DEBA3F020FA49A82C05EA07889705FE7A6DE9C0642FE7
+9B3D2B742A9CE517B02A97FB3098DBDF53F9B38DEF23D31AA09DB629B855B66C
+8AFC2729C759BB1B8E648244448DFAFB507AE8B2AE1905E663B1E5403A64D67A
+84BAA04ADF48CC707A8F4598FEDD1A49842960C1897A63C5F06CAF67FE269388
+7F98B44513CD859B3D967F274A09BF22EABC72EFDED1F8F4D10F1534CFBD9B9D
+1BC496B8ECECE9407C993E12196EB4AA4671BC76C83D327400DFCD0B8E677D44
+3180F2B0A7300F20AAFE3218869435BE4ABF7EA0E3C242A13C18429F894C77F2
+F61D66A145C28E3EE97C34E2E77E305832AAD868A2D9E3AE4177E2010342185E
+9F1C9AEFA4DC403B5632530EEBA83FD39C0B3907B7AB2497749871AD41B056E8
+3AFA7F6C589FE0014667E088523A126A9A2875257095A65742F4DADB48B397B2
+B635CF99C6FBEDEE07D336779221081D799962B7193C86634A1D631ED52870A2
+05D7F8FDE0298E1EB1131707B0ED3F8BF4B7308B95CC8A500DE3DEC9C69253BD
+91C3095800A701BD246F4E959D386D28BD1EEE76CCBA95E8D9F0C0D523913D1F
+7DB268768F7B7134A1406984278AFA97B08E50263BBFF532F5D40351E9872B61
+D83C08B7987CD159C97062E341713A382F503465567D346AE4812026696591F0
+B862C8D861319B2EEA2E93D3C96425233C7263E49DCDA4A6E10501D534E81C69
+DAC56C15BCE391EF25992AD076D07737588A54567F52FC8A6FD662CA1C1BF59E
+35A8B641BFDB725F1F6320D0DAD709E80E803AFE8F0A1A610571083066A7371C
+C71F771232FFDA31ED347996963854715D734551D17BB7848FB5B64ADBBFDF1B
+843EC1032219A2F89A9346F874CE9DBD0A39C8ED6A1425D0B1599B8B5A282809
+A1477414FD97D21B6B546762BBFB39C5479009D4834232127374B42C5039D5B6
+43EFC7DF8F2B9CF6521E275B59EEBA0B9B22D34EBD6FA350594E4F21E83E4C98
+EFBE135FFBE7636705C021A78205D7A3BF03ED3BE2D7F870BB22C98B34744E46
+231DBCD121E00115CAC05946F4E170BAD502B7309D34C0AEB8EAC3E98E22D27B
+BD0463186681157590B9C2219C71F0BCF7EBAF6F7636686ADDE238CDE9B03E64
+32D9583F3493B1636DE9078F102405F5B5C17B98A8CC488BB6A9C4465838404F
+08E3D2EA753A516983095C74854C204EDCA61F89A1E43A4DE555747A10398AB3
+91AD9A584309B8E33C67E4A8FCC7E67F70072C0B1E46606BF09026950F510979
+86B3D54DF188E8D7E4B164202084045D573E5D2028ACAADF6D1D03201AB6C0CA
+C8FE32305A965CE5C6892259E3F4E78AEC11A7B506626FD0F232AF9056D07555
+F08AF04E4F6E74E1C7A1C47DA921FBD879E523A6CF9A646C8BC481933DC846DF
+E76E287C56868ED9B5EDF70680BE44855C93689AAD0A00A3F09B1FB7461D30E7
+C048FEF5FF7CF6709C526481E77884EB150B223606B76E99AC248265DAB769FA
+84D4155B7E45B9C446E0F9F2A9382CBAF3740DD9FAF152B5ACD5954ED96661F1
+D477607EA8D93EF579D36D4EB5CD2A162FC2E5A1F9B96B6BD4621B9EFE26F6DF
+3A54301445175C965464B478E3EBC7515FC6C6CA77377EFB855912373BFD1FD1
+007CD446F28395C4A4203A008C2460141669890DC449EC501206C2E09C35741D
+9C385D19B17CC0D664EA8F05EFF98DF5DB5C1C9BB0A8FC59E2D201CCE7BBB54E
+6AECD6625FB18EA9FD955FD2A0BF106156C161384222D831ED83AB9FBC06D271
+AADC8AE5B7BF637DF45B630C5A61DEA164E88946273190BADAE3D0175D3FA2F2
+E959BAED4071EDF0E402EEE624EA641FC4F60570DD287017ED00B90FFE551402
+162DBBD4C0AAC4300BBF0591CA0134256A541208BBFB3E1C0B00C2B40219D674
+69629AF56B423B9D3AE80813CC1D15A406E3DE5896ECE7ACD8FBF0D6360997E0
+203B5FC9734D9594A9523E6BB915979241C89CEAC99FC41902BB6ED88B0F0807
+09ED566AF7939FCF3114459D3685D8E19586E20501CE50CE21024F47D0E68647
+0D9AE5ED2113FC3CE0CC3DCE3B8EE3B8C6674270E7119E7BBDF77281DF25732F
+75751B4259696B27B0865B7873FA798005988022AC9C71896C72E01BB529A3D3
+6FA6A722F9DABD40740E4261C5DE2680757CE54C7EFFFBE4221E735E6266D3F8
+51266B132FA8D24AB1353C0F767A430D2EA4B42E7693876C4959D7337DB21376
+88745BADCA288822681BEF6FBF724D6A4F9A7B03441D4D4DDC84856E0A9816A1
+0DBF9D071684DE7F5082AE296E838F9346A6233CAE86783492261B1B6CA53103
+E9FD0ED699C8B82F1132AEA1744A08583BE01423A37402F93430AAAFA97A4590
+95F2A443F048A2B0E4E17FE8A42EE0EDBDDFA33DB40AB20EC0104AEC3A5B61E3
+3E15BD6AFDDF7DFF00B36EF4B01024CB24C0CA925486BAB7B8D9EF18C87D6C5D
+6D04B16392CFED64B466CB966BF0D114DFD2A7969D2A28561999FEAD3C19FA38
+63E42D1CBFF10E60C9276E59315021BF02E6C215A40C850424D1C051E70D3DBE
+FC5500C3C695F99E828E1D50020BF0C211E07146B7F0486BCCB2D47028BC5E3D
+D1ACE5203C5BAB903832BDD4F8E68860697E1CC974FE104185DCDF6FFD424AAB
+F35CFF6F532D114D3BF75340DC90189C27B3E39E9B11985756B5D51F5F9C7C32
+ACF3646AF48AD386563BD1738CB7C899EC456C8ADF9B1C8BBD955D170F4E6344
+83EC7260BF5DB65E2271D2B66B29E8DD19D7549293305F4CD6C77729C8F585F8
+143C47F813B117E83EE2417F4FA6D0392E88301DB7AF36E850A96B29090CA5DD
+8DE88F0F4F1CC8EBBFC1F7E32A1980DA1AB44A6A0083EAF9AE1DBD33E5CCFFE9
+E39E6BB2A6D92EDFB6A5D32763E8DA63CF963944748016499F2AB3F18C666CA7
+EF87F36D27681983D38D097A5AAD9BC6D29A8EB71516596005417E9E2883071B
+4F86F322DF29063D5C5740B0544CFD2DDD2D5C177CF6A8BB817606D6BF5E6784
+77166B284C1929DB9B1518DFC61307A41094C78C185C01BBEFC30F17227D9BAE
+2B945E098FB2486C842566FE78E9EE99876D656871DFC80C6BE8D492369E5FF1
+ADEA0BBD0D0B5B09B2B3082F16A087D2F8EC7A695EE48F70A0EF04B08FB56D99
+3AA447B4CC5836A77FC39F6EB3195987783827DE60B4747037B675F09B86E324
+39F9FEDCD43EEC3B9C6D1225E3CDCE28F2F34EF615ECAA1F5B191EFA3BAFA454
+99B8FC2D74DA6C0F9656901AE06B4A3EFE6AF77AFDF0B97EBE310C2EF0D5289C
+E93F21C406F930D48B6127E60872BEB8449A36CA76E48D929166261311E25125
+18CD8BA711EF7B25730F46D1540790F2ED759DA3B9CA87961599821BF9756963
+5520C6800D2A8A35FE864B332A89C5B8DE90D78785EB589E15B83D44C5F54F07
+5146B8138B6DEB26EF5440D2414942C30F2407DC7D385D1C8B8452D2044BC8F3
+648531B51038EF2B859F9DA467C051F195752E199AC87CDF447C460612AEDFAF
+5768691BCCD9B07EE4A43D40B47EC5E38A330211A9ED69C7D7B61557BE250A1C
+2BDFDC5A9C4564DA6C30780170A817020A410DA076721CB4BEC742CA283555B3
+A508B3EE4BFDC4BE177025C8D3E67045F527E2D68683BD1B1A55791D0988AD4C
+6C7646EFA42176083FC116548162BA86F9D3A643E07DE282DEE641998072AD80
+4F25257CBE29F807491EAB6A537B183037DC3DFB79C0FF6F0404A9A982A5CE87
+0ACF2536CE01EB5EB9B4249DCA779FB70F152F4C59DF9320F1BCF7A890165E65
+D9E972BFD2257C14EB3BF5F1A4A6F92C9853EB4BBD47F79A1C00DF692BCDF46E
+A5A10E00EE973E6F9569BF8DFF2A6294923780B49506B85D940D89689B7EDB65
+4CB124F6059AA39E769D9DDFB0156A39844BC49764D09F94A43CE0F4812540B7
+48F1C6C6D0F1706EACE2E2C8A365522AD8C7484C936298C8132D2E57F9EF02B6
+F48AB7F8C25A9E08D99EB685517939DB3065A1F8601990666745EF7C36EE7712
+A9848098AA0970F1DD42B7B7939EE37BF21DDBFB6AD462D5E682B4E7F6A07888
+A9570FF202910B4E96046DE6398605C865CAA0B3A3E1242AD079B41C8514C06A
+0C21DCA9F097196024120CC58768C6B4086C57765A285CDD00D32AD97E4293A0
+83CA236730B58DC6DD796AE3500008A576748F8A8CE88BE8A9747DFE238D1266
+4FA8EE0FA2321279F6C7F9743FD3C3AFA8BF56426510616059D9DC026EBCC55E
+CB8091CAD9BA05B4EE83DD7B1FDE8DA8A0B6AE85CE6551D11A2A21CDA502AAF6
+1F03277DBA4B3827F516074C2629F082ECE837F25D6FBE72B080A4E445C8DDA4
+0118089A2061DFC59C59524EEB8F2B3DFF98C56D8427F38956A3DA5DA2C2F976
+B50F6B9C37F62DC3C58BC76B7121990DBA6FCF05CC5362A46815B300F0724697
+D30B277C38043FE92F858E855058705D9A8579FC25B83E8472E8AD76FC3BF150
+F1C6DF22140A105562212508CB3D40A139B2065110C8CF7C5737475F5A79859F
+272A596C25C57900DE272F2627FBEA9F2EC51E5BAF3AD06D2489C64F3FCF07FB
+13B6B7D1799EBE46554A7405FA368E98B672A2CB53A8B39578AF3B98DD5A46A6
+1A63C5B9D49A71A7B95D7A172814D4DBEB374FC6F56ACF67E6BED05277386C42
+D267C18F1B912EEF8D4582C29CE3A57B2180C3DA82E396B7B5C277B2A3AA5D07
+16647230758D21453F76A8734108BF18B6D272D333D906C5870A1A60332FEEC6
+60BA51EE3237D35114C8F56653158F9DE921686FA6A57CC9145B90E7E9A25C12
+FE5F6C97456762904B69CFBF649699180D2BBF89A1F6DBA39402145CD8E124AD
+16FD6238AB35205361D85448DD8A47F1FD8BF8DB033C8F577926FC26DF8B81F0
+76CFDFE4CE4726D6A25BCBB6E5CDD4254DAC9CAB40044215ED6FD3B03124A886
+07D17883DE4E644AB40535EE23D4B2A523189A356285A69E1D5B92873CFEB5B6
+8933AE03FA1A1FE7C68E272CC067DF970183F860E7E236F4ED5EF3B05461199C
+49DBA62C994E609C9BAFC0D67E430CB3271F7A339B95D5685C748AE8BE1B2A5C
+EEDE8EAEFE29B6166D300B7EF5CF291E75A4365C5C6A901EE82075E6ED768E06
+70744B6C59C6810C46339766BF82F180670B2230DFB02404887CDA4BE7F36806
+8A2EF495615DC6ABFD9564CEAA1C45DBD9236EC2C200F87B3ADBADAB6BB4F581
+B8AA22019EC8FD662DE6D2731FBA6989B1220A5ED00C748C12DAC4C6B41D714D
+5E33A50909E7513CE196D8617F1A12F1986598C2E322F2361F55BCC2F30920E2
+C79042D802E56839024892CE2217C2C847FB6E7BC6735723B625E856E96C736C
+D914D0ADA334AB943FA7A473DD8C452A21A5EACC91F25E5E6703C007A46AF8D1
+98D0D5DEBE08E4AC3DBD4F3FBC78A7D947DF2B3787F43DACADDB5A80296F5658
+632600618AD9DC1B506FDD9A04DA00E1DDF2FEB4AA75F63604C6C8C0E77C9B99
+FB9A174A021A7BABC9DD0590231E1EB88608D1A95B6D5D6473A1C60E3DC3EBD9
+2F0D013F29DCC3DFAC2BC0C977B88616780F4A77912F97EBC6CFF025819DCE1D
+4E285EB44BDB0F5F298EE0AF35B84F7C0D8B3322DD1AF3ECB7F00CD379C25411
+99F76454425C76B9122DC11E65B2273E4E834B1FC40754D9B8758CA32F38BE6E
+7D816DDB41A6F0CD3B737EF8EA2F0C375023E484B2DA32420A297D2378124038
+737819CD9E6BD3051F8C32E588A27FEFAACD25EE3F5C2ACDE23DA85BD77DD129
+65CA6E086B49E23A1F53D70516B0183DD0F3EE5E4648D0A1EF5BFC109132B61A
+E506EB085CF5ABD9DAF080B4DF79EB57F71572C7A5EAC9DCBC2FABCAD98FB4DC
+2FCCE252880960CF8424B6D265C7A389191EA12DA7424546B539A6D5908BD4CC
+F4BB266519D5389E708331312888E845A1D9A2481D55F2A74CF0A7930B67E9B8
+3297F26C140E1B172F987E6DD7F74806F8C518F1003F58B0DC5523E7E315905C
+2DF346D2D1364698111CA4380B2F0611A3E7A5667C275A80DEBF8F95353FE4B8
+FC6EE89131C0E2A36ADB66047FD9B9635C31416FC79472FE9BE3D6FCF618C0F1
+2393433A4167B9CEDD07C1927F336BCE61C5D1C33D61BD772855FFFB2BBE66E4
+5CCA0ADC7B3B4FCEABAD8D73193A1D0B3954A03EBB481658FE37DBD27F831E72
+CCB34024DD5B6FC905E7A35B0EB19E11F8D936CE2635ED1DEFB0095D19C65DCD
+BC5536029DDAF2DA88E26870B0A3FF9F4BCB01726C9AD289EE580FF7F641C31F
+00C70D7F38C45AE2D1DC393A44402A757D26BAFA11C2C772CAFAD1CDA5AAE788
+FBA10D33ABD53A7F89BA8905CEC50FE172B6F4BBF4E28616068FE8F934C7B19A
+7F32195DA2FF4163CE45CEC55645031F796216DC498CE5F1B387988E3A1F0045
+5A49909598A9B054D12E5BAD95427E91302F72A1AC15ED7FD9EF402605AEAFEB
+67BACB2DC3D7ABDACB59639A7E080F99FB40376739AA971220064219C8F10579
+A4FE50422B1414D3F07FDC435D3043AEB891C754B5695BC6D438245CE667B43A
+6E78A525EB0B106CC36C854F9E81D19B0D3A68588B141445F613872C46AF7817
+C3AEB656A2099F07C2AC19C7328004BB8613E51DD6A6D5736C936AA76E7A4968
+354E380296E6D986BAF55635EB910F1E1BD30F0F712FF05B514534BD493F45B4
+F7AF19BCAE394E03AB0B6B280B3CF064D0AFF381B3BAC5B5308D279BB18B747C
+62C7F59820320F4F4F314CE8FA8EE95EFEE589576A560375B32D3F704B507563
+0A913DA501F8DBF47C5DD48352545C6F670AD1F632951D853E7FA1601EFE93D6
+4326C00739BBC9FA129FC91FA31BAF70B8ED64078F3F972195EA606BFD964E02
+6849B98554A34CF4F2D4D20678B41AF4E4FC22C2D73F9DD9D8DA91B0B43C60F4
+393570B4003990CDE9A053D691A2F475F6B5349F4DF7BE1E5E3686F3545E042C
+F58DB7238F2AF8284A388260169A89B6B4203B758381E375D6B56D6D9607C36C
+7DC3B4A1CDBA4C01EA54CCAC0938F69F6C9C7492606C9AD9E94E3E8D8392B744
+BAD0A412084291B8E8AF22DFA49FA2AC91700F4AD89245FABD3195AA53652786
+A888FEB158CF11FB5641EDB3BD66F9B609D4B8C403DE5E0C8C2DCB38E40BF2AA
+18834CF86827B0C9ADCAEE31AA390DFBA685CFA82C96F504C5146F4B2E6A8597
+7C355CE95C24BE1503FDE6F35EE270CB22B1B33BD23B6D518F3ACFCD5C13AE8E
+6E68794A656279D52E6EF0BCC8D4F14C167C7F32801B0CEF5E5728BC8801F543
+2E5DD08D63F13AB8FBC4081BF2E2A69C99ED02FBD2B303EB1F46DFB0380E8211
+DD51CBD686629CBC185B1A2C0CD96D22D74B42D613B3FFFBC9E1BC9116236284
+835E30C183B43A95E8B80B9774A364666C205D69883C1A3AEC6BEE397258A865
+DD2862C4C5ECF8540BE0A3B13B9795E1940C40FCFEE843125F579B19056761F2
+FBC2E29919BBD0E620D2FC35D6F28B9B75EA18ED95B28E0807BCF66EF27DD93E
+303120671FD027CE639566A99069AA30A960C4F8EE434B1A9CD415501D90BE12
+FC8512C91F1794D223649FEBAECB7F58BB2E3399C74ACB310D68EB39241D25D3
+4F4C0F9B0F6F67E38204BB6B0875D64BD93F9CA944959C3479A4CD53F87910CA
+79B71AC7E3C1933C748E56FFA2BA0FEB1BE3C0310F3988262E8FC8E46094F879
+7B961973A7264E3D8414A1F0538A6895B4DE5DDFEADD3944004CE96C5AD37C87
+062A82AD597E737F4AF6954EF92864461D886FEE97B20E3B9A897F03DC7C87FB
+06A2410F7F6A39F0200F19FC5CF4A3A0EC16866878F4F49B04E0824BC87CFD6B
+3BA5A833C621A31AAF93BDB3298E4881BA49F5936352713BAD1E46376B598332
+27AD0239BF4E68D1E91256BF8ABB817283EA73DABF124A9068E3B01122B24DA0
+70CB476496F4A91772F5E7600B662625B1D42AA45B5361AB38D8C6D9DF41E24B
+EAF1209371284DDA3992D409CCB23813A4B66E652590C4FEFB3A4C5C971F7280
+58D04E4C749C9A58887D08BD468E629B1FA22DE5F177CA1A273550CB9B2EAF75
+B4554D705920D78161D3EB1DD5CC3A3FF68263DC168C696A56D1EBEDB464E45D
+21A468CBBD3710490D64CB48B5B2036A91DD1B3F95E51990C973EFD39A3E10D6
+87AA08678DB2F8314DDFD41822C74A8E6516C4E1EB863CE74FF81E33B6CD9A47
+84B8156DBF67EF23621129625D189056C3F64682A6723916B91228C47FF41A16
+3DC3EC343DA3EDEE67270497E139A053C4B066F67AC2635F00BE6B91D69F6562
+09F5F133A91AA64D2B3F218FA78C76F7D15C3553F644B2B6310987B30A27F51B
+69BC16BE79F442B9FC64AE0A954DD0086BF315A8DA207E28BFE4155ABF6C5827
+7A3D72DB686359085E96A8B9DAA88798B493DB4EAE0E945294C4C291CEC2E6F1
+BFCD0BC5AA104BD09A72084FF2882031BD02075D0D71500E6168E36503D5A5A0
+E5AEFC2378EFAB03A1B2599B653CD96E8682DED5869EAACB2D5879562E80AEEE
+ADFA705AC4A0D8A796B23F4C57987F7D24D1474E84187BFE00BA9FBCDBF2E54F
+8D6E59DD7ABA9DC9C1DD5A5D40B5E53709CE135EE2EB80F66DE29E2A9F34A138
+FC98D2345164CEF350E6E957A60A3B135641D5DCCF11690A2C54E865634F211E
+B7DA0A16757295025FB4411A78F05B9F1F57C7D33BD9384765D7B0C914B6656C
+71535A4E02FB43A41B49222261ECCAA20CA2AA4F24E8C329CD6B035DA5EAA02D
+4FA7B6610AE1FD6E58AB08B7E5B4DAF9E2A121517845594FB8778BB8933BC203
+43A47181F2380F791B4F3A247A20006608DCA85AB68089FD9C08B5839E1AD137
+EF82FA0629BF9C923566BBBDC93814FB41FDC75E35736E68E626E2505A013752
+08B34B50CC0EB6BB2D718D2DAA6B1D12DD3D8D015FE3077A61E3C48352789F6D
+6F50FB320E2B6CC5AACA3DCD1EC2972AF220AF34078E17DFF364EED7AEB7E299
+0ECEEFB7ED8077C96B4F7DFE94E83D70C5C9E50B42887522CCCC1CEBFF9EDD78
+1C23C7D5436873F7A882C0CB7AF80A05630EDF374F3BDB66BEBEDD8F4286834B
+BFE7A1924B41F58AA4FE3BE22657353F03D49553D53FD16A161019AE267F04C6
+B3BEF604DBBA8398D172828D429361367D2B02C70C5B7D7DF22A43638E914935
+36DC7E5F94971A47D4BDCE665F8DFBD9E46CB6DD460B6AC6CF7E387466D0364D
+F4A5CA6A014691E5DE042FFCC5E0DFB66DF4AE55AE3688FC73A56A3F2DCD040C
+8EA0B4488A9486E783F6C89206294C3A71CA430DEDCA0ACC95DB18D2BA3D0F59
+CF571A05FE0B86DD55AFA944E60F5DECCBCF9A208BD0E4726F27FF61684D4FCF
+02BB59A336574141E0DE21B4317EF94E30C3058985B716D71216C5CF16FFD041
+8B5B9329DF393CC7BD7207F3834C19E6EED721F5758E1A8A6A54E84EBEB828EF
+C2E18974029118D9FB6BF00F281F9426C1881E7DD32A3E2E0D94E0BCDC69F2BC
+267EB30CCD5F39773BF6D34A81025C1D827A3052B8DCD557674F8656BFA7538E
+A464049F491D1CA5D14B0B247858EEDF435F21335F9986026B71045261EE3E69
+1848512DA09350ED6150242EC80E0EC466CAD2E9D50991C25F7C7728930DB5F6
+589457E4788D293A5616FFE609203F479D0524A7D4AC1C6C3B66A8ACC0DEA715
+630A4E32D69CADFF1D8F4835BB64D97C9BFD678A7EBE04278314B3A85DCABD90
+3AC332AFC88FFC26799F9CB5BC927D069EAEE397580D079F6BE38651CB383CD6
+2B309560816DC98E88B340A4258AEA81B7C48443E8F186EC94041334D1A2DAAC
+FD64BFA84813936F6966DE258E9402388CB6B9D2D9996ADB036B5752AC803442
+D0DCB54964402DB2BCFA22F7E944DB4D4C804B3792B41BEFEFA2B5BE03D95283
+248B42DAC7C5BA49D342CDB4AD2BD62BB468F1DBA8B3497829AC7E79EC38298D
+A8D6F6D6032EF2ECC8E86AABCA7C18D2788792453E7DF42C1C000D25E56F4916
+145486A4D2F92DA3C69F4211CCD4FD49F3C9D89F91A2BC22EB880B82D4C966F2
+7C805E7D5BD32442BFA2703E3A28504FF57B9A039AF6502628965E1B2CF28F54
+0B3383BD6804E863A14EDA14F66BAE8FA8A509568CE3B34FE47A81CBDD8EF9D3
+7BDD9B240DB0492B70317D6A4F6A3D6DEFB016409AFC00C580BA9001F21CCD3F
+D42447D932A0643B4138619BFF41C41CC6124DCB3E42C96151348B07D1916FF6
+AC56F206E31CF7A4B3BA826B712DF06851ACCDC73F23DE9D1E116D4C67B1A1E5
+581A3C2F22EE57AE1DA948326E9FB7F95F383E51C9C14AF97F395CA525593F0E
+62238B3DCD8AD0E3AC799DBE93319C15897579713472A7C6F53F00CC533C135F
+80A5EFE48E0922E64B3118939FFB2AAAA2471B0B8225DFE22F13EB392E723575
+D1DF72D6CF35CC85D08B2F7DD46B2A4EEB4C8469D38B0642AC6AA9FE8EA6D36B
+0A164D2A915D9563F89A5ED5806BCAA07FA0B7AAB4ABD2257EE1142BFE3C1FC4
+5338E3466612EA60E78DF430C9B0B835B9061898B85F2675A2A3C4A1C4237D3A
+D47F4A004F2296359412E5C307B5A4231AFBEC5E7C32934F9AA73315BF26965F
+0B7B488C63338850809D9109797690AC74581A39772FFD32E8702CE7D5E3B1AF
+6FF86EC62CECE5ABD2CBB72995D7AF3085BE7E47A9392F2BA8E2E8A531D55515
+6366659EB4776C27A12D03FE511E25C940B320E69098CF312DDDBD8C7AD032C1
+8CD2EDF0115591BDB2FA8154BB1E08DCFFF012090194D0793069DFB86A66B39E
+7496861F8402E91030AD10C7170C5FB8A7C8386B3D1CC292437D0974C98A7130
+A205A1972D18457264275E483A3A466B5868EE9E84E1F680E4C037A001B8EF32
+2B76376052C0487F98998E626F8CB172265A29955D8A90D738CA9E3A16ECF9A8
+78AC7DD88C19CB5A3CD9D23B32AF10D34B79906C626AB95A3C61A050116B04E2
+6D05D56FA45B26B02EACFC66A8383AC97FC1512AE989723462E5F92A05915B39
+1B35CF3E8F0AF6FC7A4734763DA188EAC5BB49474C71B6ED5BC61B5D727128BF
+A6948BC2F6B4FA2490A18D4AA7EB37F96B1D6799E7BBE6A93C3A5CA78C75C093
+8514AB09D92C2EE26D422CC04E4734D512EA207AC720B9D9195947C8463C7E27
+E041EFA3891CCBC464D6F1417EBDEC4FE6079D27D06A97E0DA6B75616E9CA3A5
+7D8C3683E43347599D62E9DEE3EE862E3DC28451B494C63AABBA90A2C71B044F
+541344C94FB17196500737973BA9FB3F66172D9D0DDDD7514FBB4142B5631E43
+BCE4F217FE10D30CBB7EC98F96DF9E035904F7608ACCD1B38ED9CE353019834F
+852D07D63B576257005A2F7D241616E411BF1F91CE7C79254DCC83E38DCFA26D
+E0387D341C83D5FD6627E41F21F486FD9889A694886EC9F4C4431876E7B3480C
+5AD7879659A02D914468C33FB8F3BDF65B7B141360B719ABA01084D815A0F038
+C111DF6C6811CBFD5B067942AA1225578A20C206B636059B2B1EECE3A8D63D4A
+B178C6F351C6678F25538336762A07B8B67539CF12ED6AC83B70F94C7908EB85
+3D3394905B8AD93F2870502701F9E37C9D70D06BF395486935E3C6760D7705EE
+AE279EB03203ACA37C2C4404C5D0FFBFDD7FCCEE290CE2FFF187044B9E34D623
+3DB92D554345CFBC8D116806C14F892DC60424773D9478F922DEA211E00B221C
+292C2F3C559F2E6A9B84329060CCE497D2BD1E9A810C742D244C8B87871AA4B3
+E1ABBBFB1ECFCD0F0B77838C608E199C7CFEBD4875E87040A43E515F15923646
+3A8717D5FFCB9BE87F9A5E453DF9C80F4E4E5AB24267F6A79A06C24348DAEE4E
+F47508CE36541F5567E6CFA1335DF356112C9BED591688AFD1A8B691D0F583EB
+FC845C2CA178B71659713AAA11DFEB3D60B864F03B7E505DED520C5916F284F4
+06C5C48F16672AD8277BAE2A5AA3760D1464C6AE0E9438CB23B56E14A95DBC2E
+C513A79B053578D9830444415ED8837C2C3B4A64BD413042DA7F0220B7734C02
+C6D1F2F1D68CA6D5BA9E5D4CAC7D00CCE90244CB3B2B9E14798D1D5287118542
+60CB7A5CEBA405FF6F0D3FA7597503E1F375D96E185A35FDB2A66B53B29D6294
+A5E178B765D95E521BBAC1958B8071F8D5CA6F06E4644AEDCC99EC92EF0BE3D8
+98DC0E0EA30AF52D8ABBEF3701791BBC3E05337C8EDB4DB5FA43B83927D4676F
+A9A4002B34282EF64794BE45421C41711FD987D7D6091326550E59DBBDD8BC04
+C6172BC9D66AA2510356B02AA766E8CEE6F178E2E475DA1F73095DEE76BEA90B
+569BCC4B3821DCB8D27037E9F6431C7BC0C3945B1A950437355E6ED10A3DEEE8
+BCF82F3F005FA668D9ECD8F8BF4475F317D3E1AFC5D57415E4A740679E7574AE
+D323FEBFDFBAE5DFD4283FBC7F8919AA74ADD1310C68FB0ECC9F0F0CD23D1E4A
+42805F60D9B93FB1570A8AB156D3D45A4E10D2E77CBB125DC5956C36D728A7C5
+981B75110BFD068B1E9A2DC6226AD24F3464025DC63A6F0C218505D1CEC06CDC
+E660BE5E51E570DB4CAC6F02526042F764A3CE02F12DBBC93E15015779D8C5C1
+51FBA9EF6E1E5C67D009B55390A6F8B5110F49B7DDF88B7A9B15247C56723901
+42CCB32A46E161332CC5062DD7D48D6D04E75BB3E65C9F4F755B2DD77C121635
+FBB8E0730E0DCD50BC992FEC680E40D1D3BC6AB9DC183D7A7C3EEE38E89E82CE
+987BF65F4C104EF43DA66D306DB484CF57D54D9DA0DE99978A8F1EEE15A35ACD
+F45EDE0FA3B0EA0F206ED660778C2ADFA32E883B26B3611801DD078B07F3B0ED
+2CFEA4AC5B6F1E21354C865343900F808252B1406AFA82A47D5B0D5C117121FC
+3CF1B86CA8E662ED1C9F8004EF2E41ED01D9D56ACD19FA30A2A610F3840EBD37
+2A71D74BBBC1D17F6ABF88975231B65B3C01C9846C5AECADFBFA21569D775D97
+81428255DDFE6EE74796F7327C3A80423D84B484DA9CA4B4A82580ABD2747461
+CABAF162FAE35245E1B085C4D9ECD8288C4D41F693779C52371B20729F4790C2
+0275E46687600A848A97D3C5555FDC51255CCB48E7A352752BE30D7A2110ED7C
+21D659F96A9BFA119E8BDDA5F7ED53E568A06D19DF82C5EA01D8D7CABF805C36
+39F2BF2AD63137F66E2600CECA6E24847FB41650275EE6DBFCD6D452BE929216
+CA39D1A9F17BB50D85756ED2AA636E747DD7C3B8E6583645E2E300C7D67C592F
+4FEEDDF0554575420E1946F0032DD9A0C2A2C765564148A1E17D1E7C6B95DB07
+321EAC3426011457D2D0089A01EA215D36C45C29274016494C29627175D84D15
+6870F3F9D2B05642861C1229F403D39914AEDA313B9EF7BBDD3B553783AE616E
+6AF6ED8DEBF4B1EC0A5FFCB941A84561CD78511BAB8988BF57F1FD668AAAECF7
+EB49474FECA827E3BB0EE463A177CC207036892AE59421549AC07240294E8D16
+F3A34C95DA53A53F0E911C82B5C5567DC9FB55D00A6DE0FB3A841E2730927407
+D894FE2C68FDA006B5E043F239D942D4890913B085285E9B42CC4CFEBEA75769
+396D0561F4DD554FE01A371663215A19E472C050EA61E57A8D6A7CD9D892EC02
+C8EAC2B81CCDC3D8C25CC08201739B184AC179DB868181D9049692FAC830EFE1
+1F0727B10A8110372BBFB890481301C14E2597A6FA59488A86AD9930ABB678EE
+41F4944F10F9022145F9DD116AC99A82BA1AC7783057E8127477A5B53931A2C0
+0D77769FE61EEE304DB49B9B56505C4A2FB1B479816DF36937B8C090AEEB5DAF
+5ABC70C1A52BD94B2D900977DD73EDA8714C3A293EB28876FAE0BAFB06CB4C0E
+CF5A8CD03589716ABE81312E5BF6DDF4C10A2CC43B42C451BF5AA9A84CE1213F
+D0AAC7C24CE1A32E333DFFE2722BADDF86DDB35E91DF561B0139CDEA24681333
+AA386B2ECC79110AACC4D22D1061D50F8773B86493B7D10DEC5640BA7863CC70
+CAC90202DD6A1FB5A16B5001FECC76786637BE891DF2A223CC4BF6D1F347CA6A
+FA1D8AE2ACE0F81AA9B615000DFF595E44A47487498BA5B30D60168C71423925
+2DF6FC4C1D5F6A47A4205BA2AE3BFAA2A96A3462CA3F8C6B17FDA2ACBA5686F3
+A8B6A364F2E2B7472235C1A9DA732AEFB90DF8AE8559D9C5C9DE7D91FEFC105D
+D4F93AFDC6FAB8C02FBE5993EEC156DEA4EBD86CB3E4CD65DE6DBDE4CE19D660
+C0BF5E57D1CF0057235B93D256578ECBCD335C16C815901EFF399E716763C98B
+B7D3D241CC2D0B328873F23C327F9860B1726085365737F2C746257EF861228F
+8310682C95757B8D505ECAC755DCD44F50F6038482B457E882FA8EC32800AC84
+F3D0F9D0C4A595834DD3875A01288915F94CBBFB4D306A5F8051B83AB5C3062D
+0E6CCB2245C2F43E99DE758331DEB35EB31DA3E2D269333B22D194169E1B0D17
+B41E8386422CA60A73F49E59862D85B4ECF22D72CFF37B566CAF385ACFD329CE
+CCD400165804FDA31796D334762CEAFF2021A0BBBD711BC3FD87B5095BC3AC77
+3582D4C8CA4CB6CBCDBA8B5F3EF2ECB02DADAC28A8F9C160684DB62F4B7E57C6
+69D68D2B2810C3022E6CB4058A6E537263D0217F6E7C1E6F85A390EE8DF3878A
+7CF02554D2411CC99F288A696D25D22B6C33E4E0FC5761418327F52EE690D424
+568686D74E928121C943D571E77514235120685EF7CC4F3980D98824E48AE727
+BF73DE95BF9F7B1D017BA5661156E013DC92C4C73BF30ACF65FA24F48BF6AED9
+8CC4E49010FE14C3D8392A18FD6699FEE707E8E72D2C6501C8E388EC71FFE3DE
+A7195C53519D3EF1EADC24D6540A73149BC45DE31DB7B00DBC77D2637DB1BDC5
+6202AA6F5BABB661AF0E11DEFD11EA434D6D6EB8C1675FD8F350827DC9334870
+BD266623B4F11CA0DD1E11AB1855A4C63BEF4AD266EF79653C03E1F9AEEE7F98
+A286485D327CEC059DFDAADBCAC4E01396A3A5FDD3D6459B67BD2F2D7D256C7C
+6DA2EE1B55426CE43B740179BD3074940FB60143913DF2845A8DD24C7583C9D9
+10329FC0E518416495E33D20848CB9AAEBF530515316FBDFFA26A83918D63E9F
+69EE67E8126AE1B69E7EF9A2FD093C0291BD3B4E905FDC64C7670052D30D0F5C
+6F6BF733D43D49B3F25DB79354D8AFF0548D6F39BC3748AC550A43295348D104
+E090DFC4FA6902E97A26F6CCFACC0092E4722ACDA7E9924BDA17260E54CBD1C4
+E5D95E6815DD4A9828B07F4D434245832AAC6D0E24038B35F9F29B4DA65E0D33
+99CCFD9F7CE24F9899F4F98012F99F23522EE95F61EE7B47E0D73C97A1A6A63E
+30AA291560A7F4BF3C35AFCC7CDF5CE613C2A212B00E930DA46D80711A416B3D
+94313A7E62B72E011B684792904C5C64158054D5BEAD867554D088A977DE5F09
+5E873B014A3CC6D6A23C7827666A8D8AA7A4D4B15E5E8013636989F753365922
+E28E4D9B0C8500B5109FA4D16D2296F71C2D389DD0AD8F3AF1BC1298E537BAF7
+8D2EA028AF5EDDE862EFD799062998D65E000CD328A15AA27871F1E8D7FA39CB
+97EE1B8B1772E7E48EA3B5FFC0BE5021DD605280E00F1B6365E06E60E274D246
+674A4D8E
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMBX12
+%!PS-AdobeFont-1.1: CMBX12 1.0
+%%CreationDate: 1991 Aug 20 16:34:54
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.0) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMBX12) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Bold) readonly def
+/ItalicAngle 0 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMBX12 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-53 -251 1139 750}readonly def
+/UniqueID 5000769 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
+016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
+9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
+D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
+469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
+2BDBF16FBC7512FAA308A093FE5F0364CD5660F74BEE96790DE35AFA90CCF712
+B1805DA88AE375A04D99598EADFC625BDC1F9C315B6CF28C9BD427F32C745C99
+AEBE70DAAED49EA45AF94F081934AA47894A370D698ABABDA4215500B190AF26
+7FCFB7DDA2BC68605A4EF61ECCA3D61C684B47FFB5887A3BEDE0B4D30E8EBABF
+20980C23312618EB0EAF289B2924FF4A334B85D98FD68545FDADB47F991E7390
+B10EE86A46A5AF8866C010225024D5E5862D49DEB5D8ECCB95D94283C50A363D
+68A49071445610F03CE3600945118A6BC0B3AA4593104E727261C68C4A47F809
+D77E4CF27B3681F6B6F3AC498E45361BF9E01FAF5527F5E3CC790D3084674B3E
+26296F3E03321B5C555D2458578A89E72D3166A3C5D740B3ABB127CF420C316D
+F957873DA04CF0DB25A73574A4DE2E4F2D5D4E8E0B430654CF7F341A1BDB3E26
+77C194764EAD58C585F49EF10843FE020F9FDFD9008D660DE50B9BD7A2A87299
+BC319E66D781101BB956E30643A19B93C8967E1AE4719F300BFE5866F0D6DA5E
+C55E171A24D3B707EFA325D47F473764E99BC8B1108D815CF2ACADFA6C4663E8
+30855D673CE98AB78F5F829F7FA226AB57F07B3E7D4E7CE30ED3B7EB0D3035C5
+148DA8D9FA34483414FDA8E3DC9E6C479E3EEE9A11A0547FC9085FA4631AD19C
+E936E0598E3197207FA7BB6E55CFD5EF72AEC12D9A9675241C7A71316B2E148D
+E2A1732B3627109EA446CB320EBBE2E78281CDF0890E2E72B6711335857F1E23
+337C75E729701E93D5BEC0630CDC7F4E957233EC09F917E5CA703C7E93841598
+0E73843FC6619DE017C8473A6D1B2BE5142DEBA285B98FA1CC5E64D2ADB981E6
+472971848451A245DDF6AA3B8225E9AC8E4630B0FF32D679EC27ACAD85C6394E
+A6F71023B660EE883D8B676837E9EBA4E42BA8F365433A900F1DC3A9F0E88A26
+331BDED95DB0237E9B61C5470AD852E6E29B5F064570B12D665F0C33AD57055F
+6FE0B6EDBE28218F8B98D3477B80DDB7AF5E54E3DBD387C9BE1F9E4BA77EA434
+7957AF06C0342A30CA7C9AC24343D3A47574364E08F82BD3262E67ADF671CCEB
+0BA31264BF2D61DB6DAC28FAE50FC5DF06A31019330F0AD1F299C4DEAEE8D689
+624EF2DB936E533FFC6A051BC12261A989DDCD59ABE84B3CF6F2B610AECD0438
+C154D212BD8815A6034A0206D8D285CDB252D5E3BBA981C4483B96B8B47D90AB
+5EA6EA44EA13B69FFCD492B4DBF12F08E3D01E5234C30B3A9C6DC340CA9D148A
+D8686CA31F96B05AC37AE00F6FBA4A02342FFC11DEF8CC204ADD55CBE903E5AC
+380FF2CDF2EB5A8EAD7ED0783228D0D5FC65054B2547092C8C0F3D3B1B2E5801
+C94F4872B0E3866FFDBA7D2F9B788145DDE8DED00778578783299C5D385C22CE
+29CFCCF8C441846B344A7D2DA2837161B9D88FB721A0E73E633E5039F9704DC8
+D1252B4B96E5F28FF86AF9D9F21F0C0F931A6355A6FB09C385B001A23ED46F56
+3DC69B382CBBB23C7D8BB28B40443E3D3785D428D11A39A8554C30AADB2DDBD7
+656B0F2ECD7D11A3CE9A0442A7F8A98433519B5C2A05FEAC55C9BEDD29506A34
+C92A65B52782F36300AEA6F192FC2DF0F2A43AF35265B0BB0AEF105F2A1C1F63
+BFD8386C7FFEC43A677A1FCBC7C38B01685049BF3F58C8E4384609E6C2990FCE
+B61B41AA77E548924F89BBE4AD4B61A55E75659DC127C685F91CB204B696D96B
+815E7C98FB24F6B273ACBD729A60A899E5228ADA9BDF99A7EFE1FEC173AEA94A
+F7AE02D39A4D9E026B2FBB203C0DB3C8EAC2B81CCA00B2DDBAE4B6466930A66F
+A01F764B72604C96893B40A2F43E36045E6ABFD093DA9E59D28D5F9114C40452
+BC06B6BF2A2469FDD0FC563CCE87B0207E6F0CB2A73B723093BB002FAC2A283D
+805C2D5ED7A08DB87A8769A897AD1ABC029DE63ABD2C802CF719109CD4F77175
+45AFA784425464855EDFB1D11BC77B5B86A5D45810B26694953B4BFA1EC1DB9F
+E387DE66890D2A02AC66F43E596AAD8888CF73E25AC1BAF28030CAA0B8E58A44
+AD41630CBD7F3EED018EE0424BB084F3DDCB738C1A22A69300C578B62C46F3E7
+CEE7DA3C0F02E2AB8E08EF9335E941EDEC17C0403719AE0121BA95C2573EF03B
+B2671CE937FC02F9E46B5E2E030B849D7A2E3D77AB60E952FF8B8DD25B23562D
+CE0059AB72925E93ACAE91244A445CF6BDC9E4E64980B18779B94040F95E29FD
+8C8D313D8B124D4E2AA0F50EFE70E23726BAACBE44DD65D19499B20839B1662C
+8554B20FCC137ABB0D5FBA85211B16D80722CFDCEE3D2D4AEB76244445B6E392
+A00747C2A60725E04D39BF7518ED927FECE89C80A7B65FF239BEA8998BAF32AB
+C47D5FD78A0FD1070FB087B3E4B453C181E2CFD24A12515AA9D6714517A81B83
+9ACE0137C1472753178B33C6E0CE54B26776D53767237DDE923EEF1FCD61C41B
+05B443C7F33E24D61B77F7BDC00D1073A853F24A605047BE63270FB7E694B4FE
+98BBDFD025A0F273FBF99132210430BDC2DE86393ECA694843D350724CB02DBF
+3855DFD4E851E75FF8260B3B2A822A1BF40CEE60020414A6FE1425D7CF23F2F3
+00A044A71F2894CA79BCD7C210FA3AC97BC4EBF422478548A3057CE066FA6211
+9D24E8EFC0AEF144D9E86B1CAF5E60636215A748D0530965DA6D31A9B62D43A8
+A5192903B021FE45621D5F3E8D51D63386202984A277742322B88B700061FBAB
+E84DBBBB4438F1733D27D5836BEDD524A3C586913A4CC250B1E412A1CF2562D1
+C19665F3327440567691C1F01F69F583702F866C1AA674C98ACF6DF5BF8C1C12
+5774509482F7545CB95503E4A722373F688AC485033C3E3F3CCBB2C3C2B0EA15
+AA6A12DDB58A1980A767F979C35BAB9657B26EC8693C97E1EB0897FAC566FC16
+995C7FF80BDEF26E237F159DE3775DE83D43FC2A183965C2A7F43D7E395B5E0D
+4F3D35B99BA347F961A27B79B7ABEBC58EA6EDEBFD4C40116C7A3FB142519FED
+8222C5EE0C25889782F28D88CF409A8C8F53AB6EA49EA0887443B29327140A87
+054FEF87D7EF1CA2FA6BFB824A3782439AE4C284E5F14207AE339351C774565F
+F8BCE3E0F97D6701D1A34D943F4BF41FBDA295B6F2CBC876EC6633A0E7C1ACFC
+CFBBD65AB0573673B1D426846D6B72B9D57AB3A363721E124EF69D4B26B7513C
+64901CCEE9FFDB97C22668B5A8F096D1D4AC3D6786B1B2DF0153FCDCAAEC103C
+860A08BFA0A17BA440072203098A8A03E6EA3B29C00B828C0DEA7B188EE98EA1
+5B65AF4400F4F83348461A84E57162C65E708C36C2D32A6C09BD5AB27AE04EF2
+E3544028B3575EAEAED8C8CDD180EA8C46FC3A5EC96F03968F93C6C7548FB51E
+15CD817BDDCDC8C4103EE71732C0AE313DFA09C669460D8FAE00845B9863E7F9
+FE5D472140574A27B9EDC4AF17EB97836A0D9BE72BBB79350D94B9D7F67221BE
+646F8C0E0C6A6C8964A57FED2A98272FCACA2356886EF8770E289327EE916601
+60CEF8EE5AB2A03782BD89C8E6BB4188D5024A25022B1C4261BF0EBDF2DD58C8
+F7BE8C9516585133E67223FE21879C0A1AF12DCF4E25A9D72FFAA1B9F858C94F
+CDA18243EB66EDFA3389D14FD374B8E093EA68379ECB433A52BBBFCBCCADC60F
+5ADB0053BF575EB8A2204812C83F1BFAE83042BA1E6F9D616A41D385C2818277
+AF0CA12A73BD6E34B3C5494FA37B445864A891833470A4BAA3217EE0AEF2A5CF
+1DC60F1A660E1AE6AA5BBD63281FF0D57E08EAD0A94A07D79FF21A92E2A89B50
+F374D6C0D0963FB93A4B82D91A48D7131B5894C932C106BE0E74D2EA25EAD1EE
+AD46AA09FB21DAA79C26BC133F1C30863A55C401B5F2DBF4311DF6155981680E
+99E7BC0D0A300CBF4268779916216A646C4C04583793739E3D9656DACC4A6E7D
+B9A0A1FEAA6EEEEEA950F78A1897E2618453C1DD6495F044DDF0DF5786D79C9E
+A81C8AB1EAF150C08A1793FDAB0B746492A5C41121CFCE1E898D39107CB0FF61
+B4D73459697B5C4194BC3D5C431530B33B5162B9863448128D764C9F1AFE5D3C
+9761E76168701BE77AA6BE4BF9192DBB82D7B135C35598B6BA7A5466B5E17F1E
+FC5A22DA38D4D124447546D5FD2979C3ED20148C7155626C696BD2C1B3A9F340
+6B0E6DC84E8F30F979D3D29EF97F67BF67AAE71A834DBFBA70F3169E302D1D4A
+D89EA7D3A2746FA476E58ECAE9114794BC319F7181F46800BE86252E6E6B6373
+629EDEE545E2CDAF4B9D4A1673C28C082A93364FC3D864210F9D9260C97BBF62
+090EF1DC706B6FB9A885ED551ED55F31A9FDF68A5DB7051B4403366CB76251A0
+8CEEFFFB0D5E928D1B4027704DC63CAA07E80D5686191F1279A4956C70A73AED
+CC67568775BBD0CFE609D44E2F7156197BCBEE872EF3B38BC874E1A1A4E74DE4
+942175FCFF5670A8E3FB3123AC8E1441B93A16026547279721E9F16876DEE40B
+E9FEEF50AA8AD955F86A04C202BB22463756AF263E5F21D50D15798E4259B5F2
+11F5B7FCAB5CC1A6565F898A28BF72D9A6FDFDC76E70B198C2F850BA64BC89E5
+275CC7D58EB4AD3FC4AF41B7952D1B3671682F303A2AFCFFC8DBD4E580883C5E
+E3D2503AB85629CF013EBAF732A85CA59233E8B984023D19E6094870BAD56754
+4D6ABDA944EEB5C49BE9E9C581B32A8B5E6FBCA29D76BA93CE8D11A8EF0E443F
+870EA7F70CB714680D726A5E288B97C9A51D007ADEC117519441B57D7732B3F9
+708E4D282EA6A5EA0BF154EB26D1056EDCCBC97AF5800107DA7CF2A80E7F705E
+CC4B60ED99568948AF1D6CB3068A4F55036A3CE2B6A9C299A367C4693EAAABC0
+1AA243193740F919127BE37435CC9EB8C869A72FC6363376EA2D6C610CC4770A
+58EB2D66D54EB75BC09DF9CF0831C9406895A99ECEF0F01DAEEB0D0036DAF7BB
+1CA429D0593D6AD1B82245F5CD73CB33F30F803FB310E624819A8A656ED793D4
+BC9C76DFA374052CE2DB5BACDA9DE4B015EF3637D21642D4874C8FC8022C8497
+F58D7D549AB950ECC5914A4F5EABA8295ED047D8F787924E79E325C18CE406E5
+DF4796E21B2A01010831DA30BD7F641D08FED476A85537556DFC286C407F1B74
+9F4375D3468D6256F8D23F261AEDE5F64CDB6000CD19BC4B341109CD047D6B0D
+139079642EFC13DACDCCEA730F1678EB6475546DCE9E95732411FE73296E2581
+6D4E5E75E85F07A4BA61E711429AA11A337B98B4D11901CA495A55D420497AB3
+61AC33B14D7F2A7152C1DAFD2744441F08D8921D4C57F0E8209A2A1F065C1C9A
+F7828E9C4E59E2FD4657B50129F9379F1F1C49A4ADA2C0F935E48BE82DB5123D
+FB80F70369F1D5106ECDA8F4A00BCDB9206CBB8B775F55BDF8B5F14447C26C70
+1C98C1FCB06E656143D277DEC9C099345BAD3A30C507F50EE9061F279380C753
+877816340E2CDE9B1FC62E805027B6B1AFA2479A15C28A1D42C1BA819465DBFB
+DBCAC8DA2D42C25AB9022AD2549DE2D7D71412F8B8521A2751A6D59BF41C2A1C
+173720044A5A825B812110FF586B525BD2672DC14C617D0210D6724BC972F3BE
+59C097386B737846E6BF6C1D15524233D15432EE2397D377F31079861EAE7762
+A529061D7D9238CF9E5E4593CE86F7DDF9645D2B954F6E978E5120A623746121
+2D12022A2B64AB513CF7DDA22CA2A9BAE70A9080505F217DCF1EC3ED60ADBD3C
+F0DCAC39B73B685C72D4355A0C46DDD81ECC3BC007F8F8C6228A35D2B76CBE54
+17D1FC4086F5A080757A307156F799C695E978A111C2B9C6C8F202871E495F5B
+D00F179A412E5E30EE5EBB1B29E0B3E5965518D951995955CF0E96D362F5D43A
+CB799A41FF853C70FCD3ADA7CB8E445AC4F1A660EB55F61B59AF0C47C115E7A7
+478AF19B10799C73B2883149C18BA8727EA2E3BD7A0211550CF2CBF76CD3843C
+E977D7B81C1F7690CE54075872C6943B5B2E7E2B8937D5BA7822AF2DAE1F29A1
+46FE023F5746A644C162FDECF5C5B2AA5AA41F26DD75DA6EB68BAEB95C908B26
+C4E607A17D26D2B86479706C78B746A328064F36168FCA2712CA4DF6D1F3BBD2
+4CFEBCECF51E7794A6D514335C83817784D0692866F14F89C33D32361FE5390C
+F415D8ACBC073221F6C6773324CAE8203A1EF984D94F505236EEE229ED393260
+FAE7E1DB35C47D26C5E5C5E64A2FDB4E3E1FD03A0ADA22A9F1375F0F0811E4C8
+55FC55F8F3072CC7718D3128C10F701DE353EFF8B4F7DAF9379BEF4F3B0FA5C3
+BB8815EA0BE95877CE0DF0B5509D17AF9D6FC53D62D9064722D9748CEF45BBCE
+363E730F4E21921A4619343BADB683A4BBDCFDE632599B6BFF815BF5B12B34FA
+E577585779985B370F7CFB8E772E43C6D8CDDFA76B4501350991A9DC8317A227
+37FA6417F4E2060B8E584A4C839FBAD9BEC5F46F283575E6D4B6B60647FC09F1
+3A7F2EFA91872FD20663A4131F6C94DF890AF883C75EFCDF46E3B24119BF90B2
+A73EBA3923439EA186CC29BE707B1F7E5AA06AAB245210C44A9CC3F0A19E34EB
+7516D8F4F4F1CB97C3F3C93F86CF07CD939BEDCB4EB6063517FB8D32FCD3BD6E
+A09F8529C03CFC75BB548E2CC42CD897FEEE06C1E535D6B43A5C4F5C2FA10F8F
+D019C4805075197BC47A2012839480B7E6DF966BF1A882F8838286913535AC92
+BF4F454DF1834B13BAB1314FAEC0670AD9F7B8667822531FD8252FE893F1DFCC
+651F2150F1B3EF211C25AD5F2F60AAB46CF37573EA6C4D3FFA67146EAF2554F3
+4D5B8C018A2DA0A002F7D68F7586117EC37E4C77AF6F39B5D51CAABB4668716C
+161CAB64489F3339A0309951BA195A2F346E2B4BB4F5FE025951374B894616F2
+7D9514A76406FC545A0506B6A5E0495E6B5C4BD6DC847E91345D496DEC4DCFB9
+A9D1B684D63396750ADC84080DF3C76626C2D4A57925F9749D11578A73D361A7
+33FC675A5B4FA381BF2CD039A7E2A043AA04C7303476149710EF98129DD4A670
+943BA1D1BE37EC5E62CCE314F5957FD59E6ADF9565655F29A0AB3457CC166F8D
+3A814BED13E4E38225E13F0A5CA87F1693D9C70EDB221259653DE5715A50B028
+36FBAF84D2493028B00D595777DA9246E61D2057C66A2C83CC20473FB0EF6F79
+F5A8E324273F3862C038ADFC34E4FBB205FEBEE72BFEB604592F292BF79266D3
+6119AE8BDF3E9202C546AE22360E92C2A78C5A992E0505B0E012C612B4F0B47F
+3A448680DCA89467904D2FCDF3031CE612A1B3C528674BB03C6FC9E5A9F12C23
+868887E7F6D77414C58BE607EDDAFFAC67F9C21BC80F00EF3466D1E29913A49E
+BE6F7455D0429FAB1977A157ADC8FDABD34729E8004169F365D182D82E3B8D44
+40E69E9885610E9693F836E11671E28DC3288679A997FAF8AC137FF00B2DE7F8
+65B4E9103A193BC5655F3A4489F8AFDD13DD4AA3A6A33B0F57DB102623DE6E1C
+DD34F00B71C8A65FD20E298AB949A9AA81969BC07620AB2D90C112DAA74E64EF
+8B01AE69FC4687EA11655D7E27B0A70D4DBFB4305326A3D6DB4CF8E9F4A7CDF2
+744ADA66A435C30D25819940636CF8D2677691599FD646F290BBE400C0672DEA
+5DF1A9BFFBEC2B2B3E26C9AFE2D16EF21841B2DE95C4388F8E0CCFBC96B89621
+71E3A3DCD70FB0AD73A4E1847868599A56DCFBB8C5BA7EE50CC33EA8C1F55AFF
+F3606D8BBFED54AEDA56999B73D35FDF53622E2D605DCF6CCD979DE587B33031
+F2B9B3DBF73361501E2159B90336C4843810746187E740D87B6AAF8D5A042858
+40720CC51EA677140A56719910E531371B1B59799123F1771963B8C16F31B673
+D7C3078BE963BD8B5AA601E19DAF17DC0D87B194F263D7BE136A3D905097A4C2
+71C3A9CB4E975260A73BAB40EEC957EEEACFA28067060897FF8926983B84BE21
+BE57F66C27674E6980F77AB99CB2CEC55255E6137DE712C1EC1D11CB2FBB7936
+F6F939B5055FEDB674D6ADDEE81EE383805EE1FF1CB9BE754DB4C6494E5E56BA
+547F6602FA643AC16B8CEF18E16BE83D6083B7E73524D8950DC61558C068DB4B
+436B6FEA7913896158CA35E975B7E7C3D9EF9FD4AA4D216881929F6DFB3B1294
+4FA65EA0F098E02E5312AE53EB9E8D1854C4F2CB09A82C990E604FDFBA3880FD
+F2EA3A3047DF8E2BA3758AC959C563F6F1381578F684B2B52D5EC6E68B71A48D
+A88D16E8609961DCBA605DF75760B77A44BBAF5A17AFA5564C26C5FE296D78F3
+5CDC2C5771549FD87F1D881B4AD7A5B33BD8C99F3577F8D3511C6EA0389EAA82
+4CFA924F40A4BC28074DE8B3E9166D97FECD3C71B6903E0E6FCF3E9CD0FB466F
+0E547D725C09253EDC25562C4CCCA19D63C539241C45C8A2817A2F093D016E6A
+11B0D7C132C50C11EEED9E108DE349111AC5BCFDDE37D8ACB486B3E0EB2CE1A5
+8E2F0BD261EA69DB7044C66C269C493EBF65BB1763316CDCCA703C896A7EAD88
+06BE3C87BB9F7B24A007F270E6F14809ABEE9AA9EBE13489DA624BDB09E5A88B
+40E0D30B86EA0A3D6E0BE565DE3147A8CA38422AEFD6E26625261407D0D4738E
+E3AC836B923CB3BEE91A60D7CE0B3CB04799A31C0700AA2204F5171B70EF23AC
+540697DBFBA5002400ED270B4F604C9F0FBA5546EE96112D727740DA24647CC6
+902F1C9B27F4488B7737D4E8352765734D0FB89FFAAC48E1932F870E7F3CDF25
+DA7C2B399CE37FE1E571BB35E20B3C1E6B5DC2D8E2301701D1BC1073405AA705
+926D20D0E7A8B1AB93AAAF5B0EBCB5067A30DAEFB47DD991522F23F87DDA0DD1
+CD18D07E28B203D020891023474D93E06E1CA68522967D8CB2B613950358FAD3
+6640FF7AC7CB0CD742BDCF2904DB16BA8A3C9E71DA0732D45C1C9DBB082A99BA
+B0548BFFFBB01FDABFD329655D6275044F51A4D640A923FB6F4EDEBA4A1EFF61
+A5513471A7E77D63DF881F0226298C5D5B200A3C8585DAED13CFCE95114114A2
+58994F962C05F74C38F659BA1164C0BB871E6B10AD2B590B9F6A273DFC7956BE
+4AE9B39014793D1E551FBA8D4C651B596564B776DD29C19F238A6DBAF714C7CD
+C202BF15ED995AEAB0936B650A3662814E785EAD71F1F50853B0D26D66BBA954
+C98C77B14A1DDB4B2E0AAAC41338D508B49ABF4E22F42B790E958A72C9FC99BF
+5048C1225D46A9671298E08AEAA382BE1E1FF878889CECCCDB8FB190FB127817
+71AB45ED9A2F5F213A4C3A7C704FEEC64E555EC70741B5C4A840EA034A5F906D
+5B9B70A336328078A6DC5B8866AE4F05024EA9DAE51F07B00E81130B088E8EE5
+BFFB096E85726DC84416CF282CB6EB1DC1C1469E3F953E9C04C394449C8F3AB6
+B8094AA66F4C9EF689EDAEA13EB8C13DC06821A0939EF24BE9924C02381748F1
+73941D5421A703D9539CD1EC06492A7EF23EF4DA790FA5FFDB196D6C45784F70
+88D626A36DC972BBC0D83C43BD16D0C73DEC52F3961956B8FC5F6DFF3F3B011C
+E2F724BB54A6C4E350A2D579E5ED4BA8EB3CF8762B71D6A4F9BC01DB34FE5EB8
+AAFABCB042EDB6F3BB30B3B221FF8558E2718CC9F0B947B572126BF36FDD9B2E
+36051D1EF6789D8C9B111BCE345061BE5DA17003463050BBE07D15481A503F4A
+4D42D4DF32AA792AE0F7EB0D3C6B04164BA52C18CFB332711CD6BCEF78DE1815
+DC7253AD4D63F01B34CB953D6D147D1E80B1F292D4C6B81D92AA5D363542E2A6
+274AA69B83F7B429DDA53546912402D51F19CF8CF2F381B43993E710763C4416
+DA5836E4CDBEEF1F6A6EBCABE7157AD16C3B72DE6C18234B2FE2DA1E5F2BC7AC
+547CD27D84DB1BE66E9A4CDC3E1CF38F186945EEA24619B0E9FAE8779C0C58B0
+0AAC002F4E617DDA6D2AE88B176E86C6868A17DF7387FE6ADA02D8A3AB2EE755
+56B0803C654D0C86122DAD2CBD6C8584511968D6B02B9AACBD139E5A8039C3D7
+EB3905C3256443434BAE5B70031F697B46160772E6570BB17F750D67B4F55723
+3403741DCEFB6A5D879E3D12526EF1DD552CEACBFAF6904580B962D4D27E34D4
+B568832D321CFDE2645458916E837FFEF43382FFC5B78BD4167851A343E73D3A
+DDCF53E6DAA25F6CF3B3ED7B772CF8EA122C17174314BE74C7CCEBD4B2622167
+D8A6D2DD1B69092E483A419D0365D429251F653DFB59E8D12D354E37DFE4DA91
+516F8A256E04F213CFBDC05E5819DEB7E5D936E8C138D44949AE73318543CF5E
+B6A9431DD672D32364DC89E856965199FD6ECBB7BD36991C67552FA5B8239992
+CA52BDE4120BEF57CB54FDE7793BD752252146DE415BAA0D4947509343B36E23
+5560CB1AB79E383FF10D22431BE0E15F6AFFAC009361B5B8DC5649F4B01738E3
+7050B5995E78B3B141CFB20A7C213F137AC1CB7BD74506AE7677F7D3FE803394
+90E695D0D9A722820D12756CCD39C1405B4303B7ACFAD4FD05C29E936E630499
+223CA44A4EF2390A805317F3BD2A2F6D7A2ADB4BEC9A303FDAEF4A0A6A9B96CA
+8B0D7CAC37C11C7020864D80A29697C08EDE9AF2728E506C0770F725FF49E2F2
+BCE05D37B73DFB042988A685A220A7F449FFAA9C0B98686BECBBB33598044757
+53F7EBB2085573D4C1B61A6C63C81115B3743DD9B97B5FDCAB502791BB7FF264
+9AACA02E19CB60EA9D84AB2AFC03FD95A0D1EA976587A7D67DCF806562626256
+C4FB0CC18D30C849488F3BD1C197C0834CAA696CE1906FC3B1D564D9DA2B662B
+CBA56519B8311DD58EBC2C5B79C635B837FA09058A94F7630C2727C8C83B3CD2
+37FEAF2F0C04A7F1AA5296F1BF5276ADD7E64FE413BC09D1F11A97C136E0FA3D
+083A8CCBD35638BD6582C7963A5CC39DFE9B2A2ABB9798BB518D8BC31AC5C5E7
+10FDAC20E5614CF47F43877D8BA207B76D0CD1F651441130A4EAA7BA063962BA
+995B6DF3CD4CDD88345E7F5EE739E644E3875B478622B357F1BF6B7DA5217A11
+3207824920D23EAFB1AFA4ECF80BE13F028960B0A858F54A7B16D8E40B814C15
+90C94C0C23DB1D6340C37997DD04B973CED17E00061C8D9D9524194EAD6A769C
+844D298029275321BC64AB5D0B3F7D0834D48B151A2AC4620D456BFE71724123
+421FE887F84AFCA8DBCE03E8DF1AB0F62A7F8CEFEA9D5B3DEC863251386C525A
+B85BC64D45AC4F15E2E781CC3E7DD4C14405BFB681155406307D3567F0EF41CB
+FAF21CA22A1DF36001F411457C9B1AC9E086BBDA1F4C90E5B7D253F2BB720D0D
+C150B46265AA7E931B39AB3759489C6423901CF7DCC52AB8F6E2E4154574949F
+084433DAB22A764D83FD9758BE0370BB006D9631C53B3E06631BD90F16055B8A
+7A3BC6C03A13507F63468340C489AF2B93E8D2EA8AA5301971CADBF054BC167E
+7C255E2B235001F9EE5E4014DA942B359A69417F8BEF7B36486CE906915C055A
+13F79D4A67408D02660B8835DEEC1B87C9A4708ADA8201ABCA14B4A002B6C853
+D4250FD771D0C9E16B5729A585D919D35461B242E733B7C1FCB1FE2C3487570A
+42F24F7DCDB9F29841A7EF4BA5AA852D2B3D942E46570F1B767E030225F6AF33
+A58A770ED4E9285BF06E46159EC689C6E72ABE38F4D37395BD871455C5F4F460
+0AA0952EC4A3E609C88307BAB294CED344E3E7AED80480B909C35940F992D692
+E01271C8777660E53E4BA9365DF9047E276C5916475C0C09D24136CB3D7A900B
+715F9EC7B374F3B109E9402091FA6B63CB30BB6684A5780F72A538796D7A8811
+3EA647C8E33D56748BE5E35E1B4653C3364781340BEC262DC5F58D295610E49A
+01ACD1F4B59E2FAA6C44AE1EDDF4AD9F737938A0FDB320DF52B8A2F742C48FF7
+B19AABC1BDB7699BB415363A1AE6289385222FBCFFA96182C89A5FC6EACE0943
+D17302329FE38B207098800858B25E51E570C8A56789978A8D0DA14AE315B026
+250ECE870B1F6F3B3B568AB65452A1B0B12463985F59E032B4A1BCCEEDCDC04B
+73A4D9A3E35D5E72173A65AE9CFA58489A05C5CC4738D634ED53B723337AEFA8
+62C72A96990C8B8050492FC4BC2F62902E63975C0D16E05A55F55AB11D7496AA
+FE9C5107BEAD8E677E46AA090053790BAF290012AE52F728D93B4BCCD7811803
+C15666A4260712C7B64361E179B8128FBC7E3BD08CC4C5C05EF35F3BBD934020
+997E3F0E3B38C3FE16AAAEBBAA25B11DA250ADB0FE448749409FD1D9DA5F6DFB
+58640D26C107A697DF5E6815934D536ADE45F430B4E64950D48F8C8DF27AB37C
+3D91362423DEF9AAF1F913A6586601D3DEFE1CFF1A3F5004E59E69B2181B6554
+1291F4725D63EC18231CE53E31FD49A876AD8524E3E6D07CBFFC90343834D9E9
+A6AC7A307BC167926AF8359EF946C04298224D278163852DA1F4D05F0CE39585
+A631169BAC9BD29D54F317E0283C2B8C0159883444E7F7B1EC7C38737A609C5C
+84C6727882C893DCAB95638EA8DD0AB53E75E0DB5D0F5839F8D1E152F248B155
+D884636778084458F8D5EBB809986AB44677A5620446E3648C6199E0C8D21827
+D7607B790CE9273029279725AFD180E28D664E28B09E441206E9B99E5F8CEC35
+3BFBB672EC8216FD6CE6CBEC31A2FC2B5AD5A34C5F50D9445BCB656B4BC04DE1
+AD107EBC8C087A1A394D4B662949671672B89D0E1659F3B1EB1B53E041802039
+FD67A09D65D97A008CAA1EC783F2E36C66669D794C3018B9C34770099D93324E
+041B14E4EB68E54090D278F7DB079E5C8CDDF6A564DF927B35FEF7FEFCF4C2B5
+DCB8F19DCC46F0981BC275A0EC0BF7EB1D2A0A75679D4A09B9A63972BCABC4CF
+0185C104228F6BA3BAC9DC4B5213014D1099994AC525CAA53F44DD578D9F20CD
+84EF29D00EB854B1064B51E788750C9BBE8A01D9E2AFAB5A22884170F4454605
+4159A5E381EAA029E53B6053AF1A9E19BA8B510FF25631EB5FB6B56BF3B00A0D
+3AB47E14E13A9552EBC2E4D73B
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMR12
+%!PS-AdobeFont-1.1: CMR12 1.0
+%%CreationDate: 1991 Aug 20 16:38:05
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.0) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMR12) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle 0 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMR12 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-34 -251 988 750}readonly def
+/UniqueID 5000794 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
+016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
+9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
+D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
+469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
+2BDBF16FBC7512FAA308A093FE5CF4E9D2405B169CD5365D6ECED5D768D66D6C
+68618B8C482B341F8CA38E9BB9BAFCFAAD9C2F3FD033B62690986ED43D9C9361
+3645B82392D5CAE11A7CB49D7E2E82DCD485CBA04C77322EB2E6A79D73DC194E
+59C120A2DABB9BF72E2CF256DD6EB54EECBA588101ABD933B57CE8A3A0D16B28
+51D7494F73096DF53BDC66BBF896B587DF9643317D5F610CD9088F9849126F23
+DDE030F7B277DD99055C8B119CAE9C99158AC4E150CDFC2C66ED92EBB4CC092A
+AA078CE16247A1335AD332DAA950D20395A7384C33FF72EAA31A5B89766E635F
+45C4C068AD7EE867398F0381B07CB94D29FF097D59FF9961D195A948E3D87C31
+821E9295A56D21875B41988F7A16A1587050C3C71B4E4355BB37F255D6B237CE
+96F25467F70FA19E0F85785FF49068949CCC79F2F8AE57D5F79BB9C5CF5EED5D
+9857B9967D9B96CDCF73D5D65FF75AFABB66734018BAE264597220C89FD17379
+26764A9302D078B4EB0E29178C878FD61007EEA2DDB119AE88C57ECFEF4B71E4
+140A34951DDC3568A84CC92371A789021A103A1A347050FDA6ECF7903F67D213
+1D0C7C474A9053866E9C88E65E6932BA87A73686EAB0019389F84D159809C498
+1E7A30ED942EB211B00DBFF5BCC720F4E276C3339B31B6EABBB078430E6A09BB
+377D3061A20B1EB98796B8607EECBC699445EAA866C38E03ED7D4F3EDBCA1926
+2AF6A41F67AFCFBF3630C943FA111E4CCD988A7363F7C2B75EAF5830B049460E
+0D2B337988F150B9182E989E7750C51BA83DF37685483F86D1F47478883F3F6A
+4B7F768DA5AA89E8F163029ADD4A9209DE8A4F285766C06EA859639B92CCCDCA
+F59B1C2BB8D588CA754D1257BFF76B53984DF4937093AAEF79009D32A29A4C16
+FB610C7D6713482C48D7F9E8410C0F00AD6E67021056B6035534E79F05D14EF2
+4E8D877D32C6541E46518B5F7B9992CA0CE392B97D857EB6310712B9E3E6FC58
+44826152B5C8EBD21401B11713AFE32E275792300C18DF24D1F5E8DAF784992B
+4FEBC7DEFB31D48CDC7E9F316CE394E71713D1240F1DC33761B447C3C68EB785
+A3445F6B017C509FFBEE39EFDFFA5E5BEEA73265763FCD5BE91F8EA11ADD66BF
+FF346732B01E78E4E3AE10D34F555247FB16B5E7EFDF5E7143429DC90C869B57
+2F0170E9D0D35041D6A148A556B5A71A3BD427578D63538D879DEF993334587B
+9F06AEAA27D3CD10956B4DD478DDAB0D645415BF6D4089BBD6C8DD2AC633F4D7
+3391CDC71FF329178B86FAE26366173AE1438F8AF2EE22FD39B42A75F23E7271
+35E3907747372545C40EC9386640B0CE7DA4217D8519E400B105AE1B85F320D1
+4C60B6A8DF1E06D767DB774D9B1F92AA492641E48C225EC67948F950F9BA58B6
+97C7525AEFD6B16C5D3FF360DAA15CB00A5937B1E2332FCC2DEC0FF1678B79E9
+433325E57BAB75831B10457A77560023B54B7BFE7C77DA1B05BD5B9A0CE72E77
+385D0831AC56BA8C9B9648E85B4C2FCF1C26700221701183592729514994C23E
+4A216062CED3B8B808B313A2174F5A107C04F0E3E82DED2501A4E6952E858422
+FBC2E238E60752E00893DB037C4CC69FD3869002AF02A92BDCA27DD128D2D969
+DDF41E24D8D86E7D6B4C1D3C0C5E72A0981227E854D58E8A8547BA6906EA0F07
+D4EAE39A2BFCF2187AD89F7845EFF2D9682D8AA1FBA6C177F679B9C0FA2D35A3
+C1AC0F4F2AF50FBCD5B6839D945DBF8BB0FBD3F432C3B712896B275CC48EC2A2
+B484500D2AB284BBBAEB30AC1D69E1C59337580F1BD079764583848672C2CBFB
+C10B140E1E34BC5B5C185566C96A3802A4743A7C9F1EF5C908B2AD2A9D9B3FD8
+EF93D95EA8B8C9AE947BF27BA2E04A34D0C12C1F979455E33895EA89846BF55E
+27EE59EE6CF10436FFDA9EBFBA16D2B468833CBA616B78BFB0F4EBB5CF46B258
+EFD803F54F0BBA85194C8FDE179E29D260CE4135483D47663DE413F2BF598A17
+4832B3B6B1824384450DCA8FBD6C11EFEC231BE76DF364335D84BBD68C3DC91C
+43937C926E87EBBA9D20C87F042F8269DFB9D3F70AE3E0C2E55F0E9BC4B9F4D1
+24BDC14D5FA8784C210977CC38F349DD4615FCCC8CD70BEC91EBAC87E487FA88
+BF650D98D03522811748506C2B3B68F62C12D153A031C06B8BCFEAB02290F4CA
+105FFA39ABA419C362709202FBABC33D732CE34DCFDFEBCABEFBF47D31491B68
+CF9E79E3AABCFB2C105A558487BD0387E2AA50EDECAEF02AA1BE248BF718F676
+CC94B1E7F767D4C06CDC0C01FDD87424D75BC819963DFB77ADDC3056ADA7ECD6
+0A2523585922390300112E015085AC4F70157AF43F5B6E2B84E2D679C7A64BC5
+1A29A965B9507B488D882E719001E8F063356D39F3C82B4DC8D5A9CFE30E91F7
+C37A55546971CBB1E24221E97E74F117215DB6A11043E62D4A2ADF8E1FC98CD4
+C69CFC1017E1468C69C881CEDBC8B1777C7102AD8FC70E33056C93CF60AD43CC
+A23CC17CBE8AF023F20EA838E1F2ED7FE0F173A4CB41614391757D52755B4792
+685F47C3922813183037775082216CA7AD01CD3B694AEA01395BFB4F31711498
+8B03945468F3CFC895DB8026917AFB140EE8096506E01E0170C5A28131603D7C
+BD0A31057CE89D2580B2EA7A5EEAF9DABEF60DFDB2513E820B503EC43A91D138
+F85F7D0E4663879D258B14D27DD17187515ADFE6A0B9A131A06FA5C73A8E6E63
+11EB656E1196E944832DC80685DC30C46BD45F5114F6865F25A28EB69116B075
+9552BCE8FEB0B5C3309337BDCD7577EAE6192E85F9279584429AF6A04A2889F5
+E70CD4EAE7CA83EE81BDF1650FF1A7EBA8D251F046ACBA66BC2A0962AC89F28A
+97007AD95F7DE8E95FC2E32ADF53FD4E28AED33FB9E9F4A4A2CE93A59CE27BEA
+8AE2B49B55151F849BDB30EECE65C17BFF95FB4BE081243FDEC3E3767C239BFD
+1F234B8200AD809FDECB384E69E8CD01B0D45DF85ACA866A6009632862DCF07C
+970B6EB09EDAFC65022E18B736B89AD4D6411E77EE34374A8FB0D982A2E15F6F
+0A684F822CB7BDCE57EB52CC71A958FD6FDB62BB08B107AC3C07BBA1995D119C
+040F901698F482A1040950396D01E6F14E8B1D2A0924874674FF51E1C0F3107F
+BB3DF93C669A05B087405AE9DFC1B8797A7561F32767B7B31EE457A0F0FDBC0E
+E4CD1D32D5339BD72D03C3D5C766AB5E94D9C5E86AA071588DFDA25359D769E9
+ED022C3DC91C8628644684FC6C9126F26488D3DAD98B325E2745AC2AD29E8E3C
+08DFF9FAFC5E98FF2812A69A69180A65FC88CF25D13526B2DA253110CE946766
+63CBE147FE2CE98326DE0366708BC4FE4CEFD61BC0049B0F4EFA9C11A6BBB2A4
+C5B675E556673E6B980A7E912F8775C41D1F58803D4E21AC5FAD1D82E05453F7
+AFB6A6B614D4FA6670DB86C232443E62224D7A6D00F78E096DEB801519D922BE
+D937DA2AC67EBDC99C94CAA0A01EFF18210CE5DF9B52B18E4C89A3629BB74FE2
+4C0B582747B6FAFBEFF1BD26409FCCA08F376AB6D55F42FA9B13509322EE53E1
+20D3F9E8ADB3FCF8CC17FA58A209294BBFB197FA2652FFB700CAC635BCCE9E2E
+43B61A1D95B220EBE0DD6638136375642FE837972F83D28D8698CB6447501986
+9AD3C219DC01F1DD5364B2E35EE3322ED390855D70AF22A875B4E85913D56FA6
+DC7BD9434585C106D739793AAFFBCA5E4A8B9DB36A3DE73295DD2BC53129839A
+4B82A1BDC8A9FE0178AFABC079CC76D45E7E139D05D8693224C3108C7E1A68B4
+CBF6665D9443EE3B0C85B683FF74E8A1EB708D2FA7E654594C67C124978D6799
+4EC7FC022BFF1AA65226271511BBA770589CD1AF7D7101C8A6059F289135B86F
+674BC5810EB3727E840E0393E684566825F2A95A286D3D3C69DCD3A56CD17ED7
+22FDFB89AD49AD6CC99650A94818DC6766ACD51776DF5AFA7F64C78CBFA592DF
+C4EB540F7B277551D7F52D9603F6DCF99BC54C7F688878141689C3BBD4A6717F
+B0766C08296496A737BBE16B09780FF95ADD7CD450B2FAE51256DA6213373B71
+9EE067D7611475EF20D643CCA31029F88F279BE06491A2B592AFE0DC8331D115
+F3706D82259339940229172F6433EED0FEC9094A23791DDB5127BD0E48110C3F
+6F2CE671CA075BBC2A13E09BD45E94322EE946429558D300B91A789479E30606
+16507E770CFE124A3CF4EB9FFAD773D7A33ACC628E21AE7288EC03AD51DFB224
+AB9F2AD510CD71BF42FC3F42E76BDBB0DB93CAC408B270D108C0A55819D88267
+2491B878A8CF34401CBCF8B791D66482075B689EA82093A992EAE033D5DE19BC
+8C3EA89EC08AE470BEEECA648A12AE4E7AEA599BD88768C42C44B5D817E5BD9A
+BA0F0C161A37D8C109196AE7971F6F22C4DEE1FC4A80F07742273D17116975AE
+E760BB8EBB4BBBCF91F3CDC46CD291F85F0EFC9F843F56772D8FC3C2C6EB2DF7
+47B867EF56F99151C6E1056F5422073D8D7B1472E09BB64A41FBC8023124C828
+11067B21EC039DC9381E675F4FA3B32F82865E477D31AF452931B7045D3E4905
+3788766AB03B5669FB11D233F0E1DA8AA5CBF24A060A7CCC4AFAD007364D6BE4
+42EFEFBE33EEB8AAFF2479EB998DA842D6FF2073DAF06587AB02F73C9EA7647A
+091D29B9F6D75ABA498DACCEDB264AE375CA584011B54FE41B17B08DB1B9F8CA
+16EB943085598FC442BB66BB76B0643D709BB285085F368409B9607886DC7AD7
+D5B07D74E6A2F98A914DFDF7599E0363DE4E064F6D1B24EE50138F6B88F3A1EE
+D6651E7D1C8F5F9D52A87374C5A26ACC7745FA579075A0204974C15A3DE4B010
+415FB3A059F2200C40DC6C9F94778FB2E948BC8BE91754153FDB14BD84408404
+BFC55E1A0BAE683382A06872EA567029A24A37FF122F90F5CF41DAB5F1E52158
+43649C5F9FADC8B96F06865D30144CD6F810CFDF3A883A5E8B417786DC895205
+A32361334A4115046C7238EF987A4113136271FA92DEB950B877A33BF6106AEE
+E48550C40692F86453C96FE1535771064ACAE59E7604BACD2560103AECAE0738
+DDF535494ABA590B564B03D86531AA886660415BF33952BF14CFAD57F2CCC8D9
+003AD96D00996B02340E42C11C0A2240E6EEC5663040B02BC36BDC90AEB0D3C7
+77B21439FB58948FD9234BEA101AD98C6EDB79DA391E3610DD27C710613C281F
+F6F22BF1C5521A6EEDD72BE4593D32C005899B6940A4D38F214B6CD00C7501F9
+5FBC617964152D8B0672FDA213B64F6E6AF4798AD53E755B06BA5B92BD22386D
+E983287CFCF2C7EEF9385D892C92968B71664B014902B7B8B305828606AE7663
+43BBB6865379D92E40784FE0325A27C16E843D8E910B1EAD2F0B2F96412DCBED
+319710089CE36ADF3C2AEEE0A136824A087FF9BD112B95BA2D5EC58A78052862
+37455E083F8172E8F1E55E8FEE6901386761E4CAD22A4F9CF7A71E41F0CF4A14
+D8426414EEA749B04A8955C31874901723DA64DE023CE49DA138C69408350290
+D349BD1F2B17283E9BC866AE5C766EC91F79DEBC7C0652B83AEC8496D281E4B9
+01229E30E280B43C91162D22053087AB36567A7B4E941F13ACF174FEE4FF4C1A
+D38726D27520DD12CF948F32223E39FC00DD2B61DA580F0BB1BE0D25AC2F3641
+5856850642B9BB34698C13AC27BF61A945994D28B294A4C466366D42165320B8
+A075EDD510F64F0B058C293185AC6A1BA35C54AD324A41A2A3C3440C3694113E
+9F8E1CC571DBF4C65CCEF07760455597B465B309555059CACC3D3A3C5C1B8D25
+6391B6B4D902ADD76C3AC6078841FBA0FEBFA29869B9285B5BFAA5DA2BEDB08E
+14E136ACD101F05CD59613B5E6CB74BAA4633E9ED556A249E96D2A55A4166505
+75251E67EE27794B65275364E17EDF12887F438CDF892B15765C781740AA7BC2
+6EE1D38DF8FC73F7A6BBDA6A12C4FC8BBED551DCB7DD3C3389A1DA9ED85AEC0F
+F222A168CED013C8BDF2D222F15229C6D8149852466F6780C558F1F85BE59BBE
+D2079BAC703B10AC9AF76F070E949D6D51F54FBE7C02DAA660CE83A4C739CD9A
+E4D6F378DDC943DE8D3567BBCFA2F8A41B2E499616AC59138E0093A8D920790F
+57AF174DF4E91F3F78E0E9B65C2C8C1F2D0DF1CCBB2CE31EDEF0C3B7B8D9EE4F
+369D3CCADE5EBE5BF1BB807E4F171101DC641578AEB91F411AE127CE614F4D23
+83C0EE89F30C27FCE1888446ED385212A1DEF7537ACF7D0BE7E319E95DDCE0A5
+2E3C6981FB7C62D1E05BAAF0D4F9E4E2EAB7128888F0CF187BD670AB003674D6
+BCB9FBC42D12FB023A91C216ED2921E66A7D233A611A18785E9B0A2FC699405D
+C1226CDD529A7597B618F04B928BA605517871514F8B58B8FF203D42D1E0164A
+B30E44D4A189D5D3F9B6A955C17B1247AA6D6C82203A0F66D6FB9D705A64F7EC
+F6D2E61D4058D18C12B8FE5BEAD26F57EE9A2BA9DE3F448C4116BC281CF99AF2
+1E90D267D8DFEF84618DE042FA6C848F5B9E97543F110206E21FC06CBEF2C939
+869AECA7AD636AF40404815CEBA01195E55C7BC8738D4E2174E4A87284820202
+D055DF6293B56F8708437369E769847B4748A49BD271ECB8FD8C0A0DCEB62D3B
+EE0A9A1512FE60EB7735B5EBB9DEC51931AFF65C98C8FE7F43F5E98D14E820BC
+6673563C16EF4CCF20B6DA8DE0DFAE30CB4237CC3D3EA5DB0B6F3520A887DAA2
+A78047290DB21EE4B147CD9B830C5F33133E9F6AAE63BE0F9585857A211AE7EE
+71328D0A39F75874914D377210C720C519175B91001ABAE2DC2C2340A1DA3F29
+B12310C48EF7ED17FEF8E877699E41C29C5475A29A5EA0A2CF6F2FAE7A3F8C67
+8E98A891897D0A4FBE0F34C4D8D071D9B8B9B8258A1BBA02EBCF65E941C9AD0E
+8B227A2C38A36EBD9A4C8C39D614019B8719688F2F5B30296A0A8F110443BB16
+3A3A353C42C0621477C6621CCDCB180DBE450C969ADC7CB0DF91CD300AB52C14
+1450B078B00AD0FE524DC0A4014C36FCD0613F45BCA62608049D692465A9F43C
+7B76C6491FFC243F301F92B304AC3C2B2F7FA1B7281F9F9976BCC72019CAB3EE
+5B3B22F1C5DB6619694D22DCF2B9D25D6E81E1CE4F9F2D518E7ECAA7EC3AEC55
+F4D5A017DA266E4540CDC4A364CB04C31505D1638C53662FB65F16C616EA5CCE
+3049A67F9E58C706B07B35F87866F3C013E27DC92826F1470306C47BE416B53E
+C9E208C9643D1029314D00E525B091A0D41066AD341C7ADA61A0036723C6466B
+45EEFEB8694010E645A223FBC032CFF72ED0784E759F0539AD0EE0CFF7A50AC7
+9B780F67FF8A51C2766DD4E678E49AFE9DFC1E992E64C0E5AD405186AFBA3427
+07118B1396D68B2AAC75846DF2125CAC70B1CDFA182D26A954D07650C259713C
+8EC8617D21F48BC0A29E59E3A6A3C63DC528D3BA3B49C03B37523BC8A6ADAB53
+D6629EC742EABFCFE79FD7C733992F838F2BE873FD24AD439EE527D1590AA95D
+72D527937741A9E6309AF30C0E5EF1AFD4024032EED815C6A90F1B3A49ED046A
+8EB75FD86CCF8579D47DD17AF5694DD7611C21928AA06A5571A91BFB953449C4
+5BACE2F48A37DA2DFDA092B820EFCFD3F026088C03FC50DA2583D33D76DD5A2F
+8E16219003E5595A682EE6FBC22D5AD944141D2218228AA27D87D48B4B1C3B1B
+378DA9D91221B07A70A0EDB21564DE53DFEE56A2022F060BAAE9C19E7021BB2A
+506BAB77AB71E24057F19B6C18637501380503BD3E70BA781B12155B6A740F27
+C92513DF313C885CAF1A006ECDC93BD8303B55F86AEE149EDA70717C11FCB7DD
+AC2807EB3DFE2E4AB50A7F17E5687C84C93BC94877C3781A81C968E67CC7305B
+06EF56C0BAC646BA5513B824DED33FC5CA1C66F5A2BDD95C8EB47B49AD532CB1
+BA4122E4D62523724012E0778E937040F05D4DF951ECBDFCBC390C9E58338E2F
+AD62D6DBCB5FDCDF7BD656CC77F77F8F614510290FDB121F77CABF5AFD80CBC3
+96626D91F2BACD63D7E23576F354AC2399A2888267F18F9A0C446163136360A7
+828CD11F1199E883DEE76E7D110014D6AB5A2BFDF8A3FA87D4F7E26C62A93269
+BDC451D38C1FE10E1BB55B78F5BBC446F45EEACB15445EB42215324FC7D3A214
+EF9AD286F62FB2F9CB5CB382181BBA7C8C81A51F90D89A0F0FDDDA7BA1604622
+765A4C05716E4E2C7B0A532418057D171D3938636215F496913571BC0242ECFF
+9DFA2B0F9E42BA35312CFB976B7BA9905BFEF24B9606B4242A9779490B89E208
+00F30ED62C113672E4EC16245DB050D933F62D38D66CD0F6C47AFA67074657F4
+69330F72A7F36050535EA55E158194FC298CE3F6504A96FADA6D7C3B394544A7
+841AA6234EFE01C88F7D969E8946A5C0355DBA3431687982E5E8E58066A2E4B3
+F2FDE7CFF32F6C2627B07284EAE2BB967BF431A9D3848AB50CC2EF258CE8D4C4
+438E7103A61988A5C36FB499A45F288B920617AFB1A172FD51E13D6588EBECEF
+007A512398662AC2B9E5B11A8E80664D31CF416C95DB5CF4AF0524F99DDA3746
+288C60FA31BF75322199BB75A521BE165C65DBE0A9AE246C4F1ADC9D23F9CCAB
+EAD9F3C4273293F71D8A7C7A43A6B729225A4CA582D9E509204E36A559BEC3FC
+B58E356E1A3126FC940BACC53A0130753C7CB22805BC71579AF57354167696A0
+5889F05CEECE83665514BEB5B747307C2BE99DD6538A24F57A2C54B215C27023
+2F6CE962CCCF0915F2859115E328B8B2DDB66B51198AD3D3A0C10AB04A06972F
+2539C6496D43296ACE0D8DE9FDBADB63C15D2D0036B98CDAE276F4EB7CA77F87
+8A37D2320A90839019F63FB7D6E10BD3460D63C1551F1C618EC58AC09AF3E4CC
+757EC84602EEB935A2C1292ABB1659BE7433E59BBCEBBAEB8592B020341F8437
+9BA8BBF205AAFAC66963C27982B60EDEE80A0C6616E8D17314BAA31CB95FB41F
+9E9C0037984D1015E6A15689FBD0E3FB744C6E2D43CF6BFED8780AAEB03A8C3B
+5BFEB44FFD489B1C1B3DC7E29F9C855152106AF752D4FE6E54FA3111CEED7787
+E8A0727B8EEEF9554B3D520A4BC9CAFBFC3A183E0A08E83755F0D94381F053D8
+97A48ED941A8E486B43983BA1447803CD142272598F51DD784B576908610F42D
+AC8806F2FB07453572616A4895289B4FB62D2A28C5FABAE2FF77ECA176DB65C3
+1E5C3E09D19582F8970B6084E83C6150643AC1BC46EB6C82695776143F0F3E8F
+4244871F4C550F4A15A737CA32C1B7782B122D4B4AD93553DE18C91CF80D7732
+6373475F8A92D245C73A10CFB82B27BED6A0137AA2871F02CF8CC762899C67F4
+A59DB68672FD126DB2BF4C8D93E8E97110A1B1B96702502BEBE4F7EC7E85CF91
+B564C43C19C3D35DA94034664599004658310AB0CF692FF4D3466FB8B316DDFC
+FAF9CA8F5EFEF14197595FA52F70E549E05086D02FDC2860A91D38F419959B19
+945715B3F670DCD4C7F2590E93BE9D28DC80756B1EECD85E82B8180BFB569EDB
+B8926B91F3BC14404EB5368E24C281D080DB2E1BC9EC60DD7D02EE6045C6C13D
+8FB423049CB4B44FF602EF79197F9DCAAD04A62AE944A4017FD90ED98BEB3969
+77FEA0CCDE2327D6A09275B8AD7B2A5A4ED6A5FB72644197401B1F483EE2213D
+96BE1406729A4AD012B908787354D2002234C7BE3A2B86FCF4746E0E5E38D8D4
+3679AF83506794177F0DC8C45F8956478F0B6D136A0EAEB459076536D6AAB062
+0270E7A5D3689EBA79C12263A2E42B9CA414B90410CC85378D96201601A2D607
+476985493F9D85A66EEFE74C8BAF12B08F73C4F7424BE823BC0CD86A24359183
+9F514FBB8BD544658A82753C66E341CFFDAE1549E716A02ECCF3C4292C4FE7D5
+261F7F777EFDE66B0DB0C94B700185D6A95CBAFC02E675E044761B26653D7A78
+8D92F139435C8DE92DBB5FA57990A16498D05AA164330887ABFC570EF77751E1
+342C5DA950228AE48A920DD6FD79998086A9282EA7E43CA3C426D3CEFDBD2D85
+D7588A1890024B22074C363E5421C5D4276799C2416F2668E851BCDB1BDFEA0F
+52054F76C259066CADB3FF6D9316EB2F5B651B8669BF34CA8EE03751D7B42119
+0280523EC990C7F944E258BBD32FB4FF29591835FDA450AFF21951B554D61FDB
+0E4107DC804F57C4B86DA2E13C1E5A0444B16CA643ED01884490F6247B769BDF
+DB93B46C32FC3DB5AF74C2FCC92009C1B10BC38DFF72FA8CAD1C6F243602F830
+E02812CF551CAF04F086EDD05DDB0D9D1A4AA07F3128AC8E6389C2D24656253B
+2E0CFC0255275949AF6CE7C365D6E51AFAE127AF0682E07F091BA8A851F785A7
+982D7CDFCF2CCFFAC4C54B944661A459D7A0CA00DDDB73CCEBEDBA2F4716C71F
+F895E581085B1A6BDB5D0B284EDB9E168D9AE26E277C5A736BCB95DB9365ED4E
+FBBFBA31D79E37C6D78A203C574EC99573AF125EF78B3AEA16C6AA66646ADCB1
+D2D836AD020789D371C5C06AADAF03164C66205E5BC5763BBCC4BFB47CD1D88A
+6488CA0249A67521A0670768D9660F30F883446A8426591C2C80D32DEE9EA9D2
+A05DACF42B367526ABE2998E931BE887EAD725F7AD81C5FCA41906A83E055AA8
+8FB9139D9A78C072D5F6CA18245C8A530408C9B6EC51582612FC3211285161DE
+7CEC6A7B14EFE084D79AAFBB7F51A2F227BBE03BEAE3ACD455AC364C82245669
+B654F2BF7010A7B89BD214CB80E183D763CA5622408440AFFAFE14D90253804A
+C7CB009D2422A87FEC4161730634E051E246DE4E7B251FDDED57D4BE2C07E7B8
+62E17F1A3989B82553F01D03D2D7A238DE20EFB57DD1E304C99A3E52049D6BD5
+8D3DB6B78E7A479F751120519DC8E30944B319EB64FC44C3B6551942A0C0D1EA
+03E3DEAEF373C8F40EBF57C31A85CA1B40A6ED8F99A71DC25D0796AB86FF8165
+ECE494D285DB063C3A4DCDAF151E72C5849203E55E6CB9DAD01249CFC9AB91D8
+AD92EA5DBD066F917E2F62A7E7C775F625636D382736EFD25F6A82D5B54FBB6B
+9020F4F82B96C1533D5F186EF35D297424B96DA06EF6DFA2F151A89272AE1ACE
+63D4B4DEC8BBAD0371AED5366D4A076B54D74FDC4C082792913D64D811281E50
+03705DC7FBA9CE298C6AC272DD1708780F5436EB3697759C9D00147FD9735FA3
+625AA9E158F7626614BB2AE7265A88B74E8517B81BED3193B7637EAFEA5D9D75
+B62C5ED0F7B90EEE53896717E8479DB7A7A3118E92242504770B46AEC08023C9
+9BE44B6DE381EE92CAB6FB7C5BE9731689CDFCBDAC916716FCB5846C84D9046B
+9BDE23E84EA5AAE6A56F1630357A1EF8E13C038CAF0BBFCFC39B936D38506309
+99C92EBDC8125453381A8FE2B380047BC90F91CE7E80D95366E9FDC725BD859F
+90DBFA6AF949EED21B10FACE9D5E6DFEDAA63DAE4BCD648C416C8F80E41F9B52
+F8EBEB523F4BE191E535649820EC1C99528114AEAB13BF6BE5A5C646DFCB22A4
+B4DBB2113D7DD5B57C60A8E9596CBF739FF49907F3929D61DF482B4723731536
+0294F78ABE44209BED7D5D1867664B6C2BE9F91F4DB0E498063CE744EF8743A4
+980A56772041EBC81EF0DEAC15BA03FE2BD4159F324456672B3D58DEC88A7652
+53775CFD0520F521BC2FD385C15BC4D7F4CB596D9CD675ACA3A9F8F9DFDB162E
+F06EBB415EFEF8165069292467460972287B4DAC29AA8450783FC99670F3ACF4
+1FDED8B3FB5D2392ACD0FDA260A3B567C7135386E3515C41D80B854F59663662
+71884448219C4DAFECDD0A9A92B2B5F747F7A122BA7D7DD2CA58EC825991001A
+7F06A264F0C9398DFDBEA58D69028931986A23E4923FFEA7BAB090D4E90684AF
+F570CC9BE63CDB0D682AFE0E5A140F986B5188EB9718EDB32423EBC4374AEDCC
+0779EA5B0EBBCD5BAFF016BDADDAEDE6587CFAD3992531162D216CE4F9173F8F
+F6E95DFEA19314B0F5E299EC1AB37D9E9A3B99EC2C9977894C9C42519352766D
+80941348EE17455A107A42FA54757058B1169E0D70F09598A8C6351B5EC98708
+8E53745CB9D8343E702FD62B539314EA04A2DBFB093BC780F49F1B6C4ABA20E1
+0E86583CDA36B584A6AD5C8858D4D824A33A0A3B699F4A9BBD5C26746D11F79B
+AFB676502DAE0F5F103E30C04C11E617A22489B5F08843EC2F6806B60BC58BC8
+FE5EF8F3EC92FB350B9253AC60B32E4563965E4C535CFDEAAF4209AB95A23431
+7E3D78076F7C039F0DD40FE4C27661F40154E51A5DA4CABA681BCFBA6017772F
+F09E307001558735D3133DCFE60C6F581940FEBA09713989E19A2E2187C7E46B
+995B31BACE6BB83E9193FEBE291FF21F15E829D11C67AFA2128B1F1B2B976E70
+2C181672FBDD6EDD3A3D8576262ECE04B5BA9E9C9A66E9028A743E50BFB604FE
+6980D19095104F77CE0154E3EB4D1A239AE97B229B54EB6E23C2E9EB0AC45D3A
+228A1FB541310811FE46DD0FD907397069A47F3CA4EE358DDD5CC8CEFD8C92E6
+E8A70A950DD375308B2260CB342444421F305F6A2D315A841B1E8FFBE0FEC347
+0356D69D3E2B8794E8D56D7B5F6E3BCC914D5832AFF0B21A419CB71FC37BA652
+1B415B1839BFF05BCDD4751C463ADE893534DD65F5CE32C761FF0065ED4A3552
+2AA17C6D63314FEA502A2CC3A15F98337B0AE130F5D80C47E5251B8C9F243E48
+BD29A0FCDC81999E7F1825F0ACCB45B1CB20DBA762FAA4CB4991A0AB32A2326D
+A499C1E30DD306BDBA96903B84202CB61337EE9B0BC8DC9F708F1CEB459CC1BE
+DC6BC7F30F8D1710EAF21BCAE939C20FF82022CBAF5F934A966B87B7E12E6DF3
+FC3843981440F975BF2C6F1C71C0D59298B98854724C2A5156DECCD0755029CB
+A24A5D95A0A45B1788D8745AF1470BC652CBD30CC27828D76A5410551EDA0A83
+37E4A3317C642CE75C3F4B3AEE51616B3A86AE3E9BDBFF2BDF76C9CADF5AE83B
+E4604ACC5B2A162471243BB2EADD6F196A75EDDAF5769BF6935095E3740392C7
+E5003B6DE8680E168A498A5673391D450B5BB2050CF9090D31A19CD8E6B6C236
+83254A257A87314D53C6D90E923072F1BDA36FB7E1C0B06918E0191F7C2A8952
+1781F6855988A315B33492CD41B63751B7B269878CD6A793F0084817BE219A47
+25D79CEC396781CF39386480DC39FAD57D7D97F9D703DABD1FB25E77F669C983
+366F894726738B9BAE97FDAF94040F81E708E42ECEBDF1FF3BE07E708580724C
+977AAFCF8722D17626F33CA6613384961B0850E3305D0E4C3108FAC02E9B6B4B
+F849DDD91531116A54617AAE6FBD93C58973A17B43960682B6388A840FFCB736
+3132BE45C6C8BDF42F1D7549ACB6503AD536DDFBFDE8A8B83C64AD74835D9087
+4C710B1105EC72AD9AD7A04F7EAC0C0DC1010FA65520D1350F28DCE392B833C8
+ADA817B3A5F2667AA57246A638B59BD7030D15091A2BAE1D9EC9E008CCADD961
+A5B7825FDCFCFFBE5A26CBB7BDDB4FD69FD3F71C030CFD82C8EAFB3FE2AA305F
+F5069D89C0F781B036601DE6422E14B4FCCCE9BC61346F9F5B8986FF3A4800D6
+36BFABFE17289B79FA9FE2DFC352EA42F581FC08570F192C6AFE70EE05049662
+B09958F21022C8624C66F3C2289BD44688597305A87329522001110765BC6DB7
+8CC6C83B1C340AC7710476A3DAA7DD948A541EBFAAA5ADC441CE7CAF91B7F3AA
+5D09829192A693EC1AB175CB32295F3088C93D99D6C0E97C57A395AD8B226D41
+65E617CD77EB759DA29CBFAF0BE5FF20E6F38047F771882768E7CB8B390B1E06
+3E1AB5664DA929B6FC60A68FD11C80708ADF81E20E3C26EFBEC9088214D11291
+C7BCBB0B362FB93F6BCFD1A27D8815626015F8C2E7E3D6E67EC8608A6750F39E
+D0687E9D9E0915BAE519285952A970C9F5BC7C3D5191E5A833031EB8B7A8BEFB
+EB907A32FA8792400DCFD1275297E376CD13DF7ADA604BC20AD6EC3973C3904F
+7EB31604E5A3EFE03E45DE3852E8C8F8493BB04076A980EB76FFACA7148CE531
+20B44C43C93487A1369E979411A4A876320FCEFF84BB2D6E1C4CD6C85E7198CB
+90CF2EA77947315AABAB220210E5F35FA5832E3066277D4CC01BF9341D4B37B0
+4064FFD97C64C2E7277EC9CE3529ED2D883EF08E87F1C47B2D84BF6F98610E8B
+64343BBD5535D1123703A9BA8AFA2A87375FADBA630E0348313AD2170A326167
+B5A6D04364E869703A1B67111D80F930A57C8806DAA3472296D11C58DF4A3BB6
+5FEE327D8BD21317EBAC0502E5EC4A97B1DD2ECCF6E0C63F24AC38637F5923DF
+17619B2DC66CE99429109E820DC2A25ED3FF1290948392EFEEDD0849ECFDEFCE
+4E5424079D9AF6C86D6014463331017FA71FE293B4A3E7860A77757F0CF5E53B
+9810C458E04EE8AD0836C4CEFAC563FB097D98E7763034DBFB17C64D66216641
+BEDA75F316F5EA506602BEF72CB06C84D0C5C8AB4999A009EFF66FDD92DF8702
+4CD014212355BD32FC7C27F2B9F264D35CEA69D7C628E445E4A0C5DAF18AD72A
+B176C0367DE95810892B7CE9D62AA700103165E6FC2EFF3DC1DD0016FE4F73BB
+011500F6356719495C52828CCEE2770624AD10819F339D093838CEF920678D1A
+928BED3976183857ECC94FE6E7517B5E56ECB31687AC9366E8B57C64294B30F1
+762901861AB0491B5EE293C8422BBD00D18FAFA0FE01AE5A92B1680690627718
+7D7A2019743B7AD016C0ED25BC2C60628F93F856BB8B0CFB87CDA15E2B049DA6
+849B63930CCF152D3B6E3C8EEEF854A06126BB8452D72BD24673CA93F7ED4A2B
+45D9A71322381A93DE176C820F333DE3E085F9433D4C5851235C802DA0677C6C
+69CBB71921DB791A29259D565AB00C952D8B9D594803B9CD6FC54A1ECAEEEF8A
+ED8008E0437759A52C3B73FD9586C4F5084FCB1914EAC761DB529D79E9A01B12
+ABADED0A9F6353B000C3F27538535C85E14912463C47A8FABEA8B3B081432FA1
+A17230710EDDE6DFBE6E5CA0DF3332C87F5B89A0663B1BD11E9C92F021252469
+2A0D3DCF6F067E6D33DDA1F0E7194FB2DF2FC529636E5A57B81B48FF1F732E4F
+6083B63C1655447A8A44688F27DEA1AF1ECC290BA4AEB79644354E6E275D3702
+27AAC36AAF8E50E37BF141F615485A673A18724AEA7E130A7EC023824E8A4C88
+084E61D7B1869928AC7FA235D6A3E48D047187BF2749F497336B118923302B8B
+724DFBA9A272036DC6CEA503AB12BD2DC13B5B31DF6185E77E10ABB8E3464CB0
+66FE7916EC811329FD60CB451DF3F6ADAFE9273317580A1C0A98E6569CA7658B
+82452CC4749AFE025EB21D6FA3C02A94FBAFD30F03AF6A774E98F7E3383278DF
+6C81B5D41A41CCC92778322106006F089F21C04767909AC12533C609F1705DB7
+08748BB37ED208CE6C6456BA0A741F726A2ED112041B87EF71C2622329AF6DB4
+DCC8D3EBC97D1A4A96B2EB8B15AE81DA1E32E90F78A3AE2A494C4A1EE3F702B6
+227B87C8EA025262CEFFB33AF90595192897D8FA0E19E05CA076EA4DA20681A9
+825EE0992093D4C969F2C987A9D4DACA0FBE52C43AAD30B1284316B9439B7D95
+6F2BDAFB9C044B377952864E178844F4751D1DE76AC5CFE09EA5546F9B335E33
+4E60B2706C67E26906C95A6E428EBB3F813674EF2033D8F4707AAC5EFF38642B
+9C70008FBEAFE92DCD33A922CD942CF4A4EE6FE175549290F95B871E66C469FB
+298F9893A76EFAF68809AA74E6364710209C9107AF7F3DE4A459B98DA142298F
+9A10E75C27EE943016A34410BE7C64F15A91CCF7872DE618472E3BC1BF4C442C
+57F9E73C5F09F7297BDFA43D2F243F599111B95BE489D814644313FCB6BB9A75
+805C6BE08B509D12FEF7D40E216267503CD629449704B65F2AB1977934B8344D
+6FAACE5E46DBFACC12FB1D2FC0BF25975C8C9A207A59F9725463B6CCA2441C94
+2E06EBD3B3E1960EDE9B0126A0A11833DC7308A7A0BE1E79526B1412A602B384
+62BBE32D7AE53A99709D464D6F634BFC32E47A3CD5087D06629AC7BF80EDAA79
+C6E1F208E8ECC0D1A8536612BF1A50D4B0849AF5BE0D1179A86D04608DB8569D
+365F8561072042824EEF7C7E04AE2FF6B84CA21DCB53212B67A962D8468E6892
+9D51F79C15AB5EEFBFA4B6B8DC9511A520809B5C8FB4EE0B7F4D7D9FF2A5C22D
+6AC8F47AF103A6E880FAE40068437071D40B01C30DB97460F485CB881AE805C1
+1F2D5DA702E01788186A729C1747972544665E0B1433540EA440D40776985808
+0B52176DA443229A755C9E691CD1E203CF875EE4D7CD7A31F68AB8D7051D1ED9
+3A7894C5C2133658C627DB36B87C90822297FB5F3F86674CE28D54265E9AAC9A
+3B83B378FD59DE17AA670786198160F7F4027F1A8D9F759E1CA37B72EFB7CE9F
+01F5738C7E2EEE2EF9649B20AAF4251B11A138078287C3A7AF24E76C1218C553
+FDC0E3E98AD227BD7ACEFCCF081FC0694CF58944B19EB0DD4A15BEBFB1D45F74
+92319A1687814AE147234A95C77233C712BC9F3A9F8AB7BCBFA7057C0AFD329B
+187EFF92E89F7B035A73CD786A2EDC89B5ADB3BA9EEEB32B8504B0A572354334
+24C1E2328F0588EBFBE32DF8E452169E653101C63DDE0050460EC82DAACAA407
+A21EB29F8AA522705C221D852AC47BAF892FC9421DECCF5354156A8BF6EFFAE4
+31CCD42487C8739D67A2391A8CF378B4B5BC7C309D23EA13D0BBB9593988B489
+4A7B2E4D54FA618803EF2463C6903D3DFA3C42435189DC2E82DC4C64FC0C62DD
+1ED7BC46D7C50E55541673EF8C28C23C36A0A2A91399026064B87EC51C66F6BD
+2E734793E7284224A72210EADB54580683065F874325DC8FE0EBE1BDAB45C0F9
+BF6B300FCA24AF9DBA9D3028DC54651521FE29D2A72B728686A2736A1795A33A
+C41A6AB2D07BA186EE6269C57B419062A38375AB76F5DB4CC46F9D2583682FE7
+57A9FC16564AF5811BD91B9479993D6839B1316DE74900B761C4AEB32FE726F8
+7C6F4AE1883E4D104A078CE504891375DC26F6E181C80B05CAAAB496DB38F9B8
+0EB969DAA27A725D3DFCC44D09043FF1FC0AAC4ACDD898FDF535244778825F44
+C0D4163F332A391311506F83BEEFA63FFF411933E9F5AC7DFED7BE94173C9B03
+2A1CCDB3723EA8B50828BB2513654F627719B4507261310A9F38FE3C1FF35A45
+B14B59177E97DFE82AE60E5BFCFA6F813FDEBF48A61B539C7D583620FBD73B66
+3ADD2F40EF2B2C127050676496E7E5CEDACE76FBE9462F671E926031CE26065C
+0CCD55DFFD1BE6E301C64E1EDF9EA75E4B659740BE9DF48FE0C5074BBD7E8C89
+24A469D43299F6FCCE9E5B1CF811A625EEFC69DB159FB91B3F162A55E8564223
+4BA2848D50F9E65ACF9E718260AC925D57B4B1D82D40E8A705AB6EF32E460685
+962B531982900062D33897B5E30C5C1ACC41DDE010DDFE15496AF901508E74CF
+5DD3044C3809766753247A2C6E3CEFB4F06714B25BFFA9B5802826AF2CEB9E3F
+F11A92C835677A70B72B72D674CC45C010770E0C56C935B3B9C00C4AC43FC747
+6F774382FC49E19264EA3918625BF2B4E02E691A01F9E2C35A423854D4BB3049
+7F97FDE8D836CF162C77C31C493E9B57E8505F9B4D971982DC5B72BD3660401B
+287E4B6D9A4C9CB22CBDD96D7344AD5B5A43F9157AA0C087C837085AC31EBEDE
+D10D5C5E03AD4289BFE2075C4DE32A03A80DAFDADA33A290E4E305BDB63B477D
+32B93DFBCFCF2C83BFF7E5B8DEE203024139A90F0E72B7C4C472E0F0CB2D074F
+C79A276793F1DC94EB8AA4A0042CED68EE2535CC246EB648086D344E13BDB010
+6A3CE8C705FB8F4730E1FB30C0DC9BE3EB78815D3656C4B04828A2AD9DF52A01
+03C153954E8496CDE66A928B7734D20E6079B690ADF73C6C3E9F93C97414F219
+2A9956D342C5C949B7369F2A11FF892A687441E2C526C867325E6C93E04FE371
+1DB580355ABE5DDA149EC1574664612923463F8F7965276243DC5B83052A5C59
+E5191A64140E92256A4AB1B610D9E6F4C6E2FE6AA3F4387A6B86BE67926A4254
+5A748E44226C59AE563ED2D63E37C8B6E7C184A430103802886044F6BE10DC33
+C590B9378AD9D6F2C4F465F8B7A2508E1DC2F5440B49901A991763776242A335
+957D867F00D1492C30DC76EDF71BFC523D898C79E1AECD922F51C4B118D6332B
+3A33AD5B05E0AB0BF838C1D0ADF73BE5ABAF5D1518AEF0186E6B58A44A9783A2
+D460C16D3EC943E502B19B5F1628FC47D4E02E5F97893D86B46CABE06FC7F2E4
+160F3BA37BCFEC499D4EB1655F21577AB1AAA78FCB3B583B7AB5685E27C2CD53
+7D32EC650402811242008493CFEAA2B901439F83CCC347C8B91BE9EE4F2B82CA
+8C328179FE1D7227EBAAD3A31C00C480BD73A67FA2B428F1D4D34D3C016D57EF
+BBA2E7D9085435B9CE1A8D250076C81ADD807745D16DB311B9EFD1AC4368AB5E
+C66AF2C65690F1F874A9919782173FE0CF349769816B51872D672C4D76594614
+0E07B951F6B15E34BB0837A9A7DEB4A13D2DDC51688321E2E5F4D8D6E8EE4501
+9BD3A7D0B9876F601A0772D897818CB16D26791588FE8FEA98C83AB6E70CF8DB
+969FF736EF36573692513CD95DC3904A24B29DEF73660F5BA36D220B8E9A3E3D
+2029EFAE695D857F01B557C3B083716810E90CE133917312A154205986BCFCA0
+D539114585928D4E510AE4DAEF07A085C2539B27D15C58BB2372FA59B1DABC61
+4BC73D815F36C4A8197E178A62983C15EFD2BDAE95793DC710C239AA236F9CBD
+57237DB7EF496721493793BE1046F4B96C7A7752AAE2CA6EB720258095C45D33
+0969ABBDCFA218DDED050C3B5F06A83D858EC009F80AC8A7A49699DCF6B44A25
+62E2606E9CE2BA93F8B9B66B807D0DCA9C15B01BBBB2933506C616ACC0B4C0CB
+E467DA41DC3A3988B8DEE38F093CFA512506AB1A0BCC9D8A11D67C63E1F121B5
+0FBB79C1330096511AAED8B372ED959D65ACB9A22C8781C34C25AF681CA4977D
+9ADEA005E7903E85AF00D37795B5E92AA184C68EAC9FE051880FB4C9CAC92F58
+60AED0838911E75548614E20C430876C94546237CA54C3D9250DF3F05DEB59DD
+30738830E59E70133109471D0BE6DB6FDAC0A8CDAC50E9AE67DF9EB780AD6C68
+6DDD21E33292786C1ED68233E715FBE0E899B86BA29E888335A0326E7A893895
+6437D4D6563B56D2D6248138F7F9FE912E13AD47EF5C76098DACB2B57F414FC6
+BF7E91386DC060070BD8F8FFB18A67ACEBF6504DDC75FC4AC7CDF60C6651904B
+368B97E7187C07A1971A1295A9CC7EA6A5884008B68830B44FB995DA3D5707F5
+F200DDD343CF218CA8B6790AB516FB9195ED05AD36B78243FE39D1D56916ABE5
+5FB2CDDDD6FD36CE652520D7E26D8D981DC5531FDD3AE8D7AF603575206A30AA
+25E4ACA1D8DEBFCDFC66527A98653DC20AC7C204CD58AB26017C7B8356FA8AFA
+FEBA23B24912ED3676790E55CFAF2712CA5572B2A5B5CE36BBDEA59D5678B1B8
+FA94FF5BEC7BBE57E67DEAE7E24FCC4DD56BADCB935502E39C2AF6F5DFACCB1F
+70583799255BB08594CA305069C2DA213CCCD0CC6002A9AB8515E12A19BC9B09
+4BF1F1122E63638B05126DC91AAAE706ACF3EA05C07C81CF47E83B562912E462
+4C7234868B59616971FF7D9BD4730A25AE3B7D8CC09FECA1158DE03862DDCDDC
+AC2C9638052C8AEC894DAAB762C1BD75842E0B07D717AE899BF58473B11D3629
+0EF8FDE9D1E8C71EFF15B0C694A08D2E22215D2974FE6CD9FFB8484BA7CD2E13
+0D99927871DF73C5166B6A597C5CACEF9C4D7668F6C5F5779DBE1B6D514ABACF
+6CAC8D80BEBD4B84E9BC8070DFFC9B5157D0DFC83D63FB348EA868B09FF11C99
+4A8874EC2D4D10EFDE557D358D56
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+%%BeginFont: CMR17
+%!PS-AdobeFont-1.1: CMR17 1.0
+%%CreationDate: 1991 Aug 20 16:38:24
+% Copyright (C) 1997 American Mathematical Society. All Rights Reserved.
+11 dict begin
+/FontInfo 7 dict dup begin
+/version (1.0) readonly def
+/Notice (Copyright (C) 1997 American Mathematical Society. All Rights Reserved) readonly def
+/FullName (CMR17) readonly def
+/FamilyName (Computer Modern) readonly def
+/Weight (Medium) readonly def
+/ItalicAngle 0 def
+/isFixedPitch false def
+end readonly def
+/FontName /CMR17 def
+/PaintType 0 def
+/FontType 1 def
+/FontMatrix [0.001 0 0 0.001 0 0] readonly def
+/Encoding 256 array
+0 1 255 {1 index exch /.notdef put} for
+dup 0 /.notdef put
+readonly def
+/FontBBox{-33 -250 945 749}readonly def
+/UniqueID 5000795 def
+currentdict end
+currentfile eexec
+D9D66F633B846A97B686A97E45A3D0AA052A014267B7904EB3C0D3BD0B83D891
+016CA6CA4B712ADEB258FAAB9A130EE605E61F77FC1B738ABC7C51CD46EF8171
+9098D5FEE67660E69A7AB91B58F29A4D79E57022F783EB0FBBB6D4F4EC35014F
+D2DECBA99459A4C59DF0C6EBA150284454E707DC2100C15B76B4C19B84363758
+469A6C558785B226332152109871A9883487DD7710949204DDCF837E6A8708B8
+2BDBF16FBC7512FAA308A093FE5F075EA0A10A15B0ED05D5039DA41B32B16E95
+A3CE9725A429B35BAD796912FC328E3A28F96FCADA20A598E247755E7E7FF801
+BDB00E9B9B086BDBE6EDCF841A3EAFC6F5284FED3C634085BA4EE0FC6A026E96
+96D55575481B007BF93CA452EE3F71D83FAAB3D9DEDD2A8F96C5840EAE5BE5DC
+9322E81DFF5E250DEB386E12A49FC9FBF9B4C25C3283F3CEA74B8278A1B09DA7
+E9AE4FBAAF23EDF5A3E07D39385D521547C3AAAB8EB70549756EBA8EF445AF4A
+497CA924ACCC3DD5456F8E2C7E36946A5BF14E2E959895F7C94F49137256BE46
+4A238684D52792234869EAE1A6D8ADF4E138B79472D2A90A6CA99E2394CC20CD
+3841733046175B20CEBE372327BF13428EED6A3E2FDF84C2DBA4B0AD584EE9DF
+B51828D3B8F385846158C29C9AC3496CB9692DD10219697B2ED4D425C3957FD8
+C4600D76E045C561216EF05D38177243C314877A69A1C22E3BEC611A2EE5A216
+9B7C264CF6D1839DBBD78A40610F2C0D7C2FE09FFA9822FF55035AD52546970F
+83EED2D30EABB1F303091EBC11A5379B12BB3F405E371519A53EA9D66174ED25
+A2E55463EC71A97BE4C04B39E68112956117C8252DB6FB14AB64534B4BCD568B
+246DB833982B38CDE7268BBF74B6B0C18091E1B1F87D32D66F4DD023D1F10D2A
+7736A960F72AC01F733A11023832CD68FB6288A5977743F781214D8FA9C0C3F7
+80001321D4397771F728FD9EE57CFE7D9192B887EC883EB1505068261DC40089
+7B7D2820F06515CD74513521F6397FEAB3AD3572D9A8269430E407E357422461
+1785FC2782047F4C0339D79B16862D939F3A37F78E4E2174E4FBF132539CB760
+207999FF86F6A3EBE48EB0A1CA635450FDEEF79EB16D853F3BF4B4189AF61712
+FFCF3E6410EB2AFF9D3978FAF613120115B7A7276E357779008BB7133C31DEFA
+E310DE517D8DD955719FE8DB2C1CC902DAE65E169F68405DD07BFB469E6198A8
+EE21E804E87E38ADCC94CC7F0DC45717A823B0E0AA26D308DA7680D818DF13BD
+0F7D405D70F18FAD27F4074C8B835B0CE4FB2704EEBF6141429034ED9F383C42
+D3D891CBB1BEDD8D8AB35E70B094383790C7ED06A137F93568C7C19A7ABCCC5D
+4AADEC659EF0B1850ABECDDDBE7CE0ED2954EC0DB1D70AF18E3A1DDDA732353C
+012DB5B09D71B5E457AE6D961CC621A5B138CE8D238285EAD95257FC8B1A0D77
+B9CF05283BF86705032C4267F159913E52BF1D27195928BF50A7B2D984E8E8F2
+8E4BFD751A6B1883AD68131910A444F75F40148CEE68CD0EC68BF68F0D19C439
+A6851E625817DE493AD18765EF2DE0C788BFA1DB3E2D950BFDD8E97ADA595F6C
+4CCD63BF24389F28D60611B4F8802E4C83E9E119E2A8B8C2DC701514A245C410
+8341E226518681BDDEA0318CB69764D0AFBDB87072CCCAC9E0DD357DF4A7079C
+A64C0CC91D3342559DC45E1DE63C83996CFC2D19966F70DA34D191632B8992ED
+4A46C3B539AE31B8679745F9C1942764A6CFE3FD008A6937E4C6824BE6E391B3
+F9E5E661C8D8F53BF8FC45A9B71B6C96FAB0A5CE1B7783FCFCE4ED985CEDB1DD
+0D005747D02E5F0BD84C8D797805827265028C2091D0543FC8BA3C4520CD176A
+6EA456C40E395C34999C0C26B995970F28F4ABB3A5C877855E870242A24369A5
+91B748158D7C44109EE19177AABF0F15B73293F677B605F001EB5D1FDABAC04E
+C94FDD17AD3E12C6305E4A31752573C102E01FE3ED09DB57847FEE995612818E
+BEC06E22F5858EEC95DAB86618D62EB704D493264F5339229701F5031DE4DBB8
+D1CD0DEF5A59E498B5ED49101E8181402D967E065FB75A090094A8A6A4DD7352
+E810484BA04646DE5023092F08EA9D798F2DC12059B8C1ED664C6A119136E7B4
+A4BF7E7BC2670D866560A38847D4C796CEAD4F14AAC2B94F70E11ECF3003F84F
+B2826A6AE104A8EA959D32FA1F6FA4AE38E5662419C9D7EC854423FAADCF70A6
+10696C37C304CFC959C7F6094F152DE770AFEF793F40E2204B61190B6858DDDA
+F725068167AD727E1DAC12E34F21D5221487435913B345D247318F4E6CAABD88
+C13F6317B68BF79A27D1626EACAD7EF3D0DF662F29CB3719E2FB9BA3FDC9802D
+738B832622F8B89252F2977E109CE90AB037EF48D1276E68020827A0B7E72837
+3397F6F3EB70E43B1786A5C8DF3A0602D0E63E15D2C067C0FB2B96A8C5C99E11
+1FA3E1CCC7912C926418F8C2296406859B03FCAFEEC03E583433245B3C4E5B76
+ABF3607C98847F1B2D231762C3F8C8425AFF2A962A3CD8531C5E9860694709F4
+EA86C2E056D9998A355F62A867754F36721ACA6531F80D25E52ECBA7E0AC1F8E
+6BD8B69B0515ADE793867FE09B303C90ADAB92D79FF169F29C4D562A9B58C277
+A03DB399EEA518B3B8A6053A1E5CF878566DA083B245DE1659A218FA5758C392
+C7E857C23A6C20604B19A4FE74CFC6A8C701152B198713A316447459E904E09B
+104F6193DBBFC04F64D72DEA8CD7A8B4AAD18E9908F0275063FCCBFE2E707E1E
+A54B83934898124066733A87524A4732F306C88F5EFA5EF03A3A2D6881FAA7DC
+13426274050D1D8538E5A994D565A7FC1E278913E80BC1428FE0EECE64FA17C9
+FAD9A3AB999EEFB2B34F4ED422B99E20989C7776AE65D72B28582869A48B383A
+76A1A436A7B43498CB1E43A2FE0F0FFC1E5FDF0F58024E0006A9D034E6E2B939
+CEA573C60897B7C7165DCEA59172D5F8A6C8D419E639697820006BA0DE3AF379
+A2D30155C28FEE49A64D72DD1D5FBDB8CDD772523B3ECC6DF23311A87353D9DF
+666FC164EA17BBDC8251BA4CF227A66C878DCF5FF3F91A550BE40E76A9635182
+A528720B50F220A92C52B2615D0AAACD5F86BCCE1B91D92FD773028CE5C19D95
+449CD14D87905D9BA840ED0E3C4AFC14FA0544431477061B159D7B9BD0607689
+B00511BE221EA158B7F4EB3644694E6186A9683BAFF064704980564D055A57FF
+D0CA3F41BF44A26EEEE7C33D5714936A343812B235882D062AFE71B64A408509
+34C74E6BF2DD62859E543197BD5CE3586505EB09F556B73377913E60459327E4
+E2BDF1188B2DEB54188C276629FF1A0ECBC3B13CB57A950994528A208ABCCCA4
+6EDFB9935169B32ED0AEB50A638BAFA011A3844EF556BBF3CCAE9A6FA59F82BB
+769389BB71B67CF3117DE593B9E2D00C2F86AC8FF975F9CDE0831A679EF26CD8
+1BC2E3072FC2857CDFD7A3A6B8B9D4235787C798B7B05ABC18ADDBF94FA77837
+EB577432D22706840E68ACFCC0DFAC09AE127AABB92B7EFCE027B9A964C38ED6
+53D5870DB47A3241C64071CED44AEF9C2BADF7327E512A02632759730A7EDD34
+1035CD271FC99DDE9BA03C63256E5BDD0F78DF8859D5471A9A9BDA5C2CB8D7D9
+610CC111B6D9BB34B456AB03A1F5AF3078D495C84E1D7174BEEC9C939A2821F2
+AE8C951FE77B0FD3990F370427ACFE17289B5B175A4D080744ACF0AC1EDCA6B2
+9CCD7539F6F1C7C717E82CE8AAFAFD3185F523F9C5CCCA410D01040437F6F1EE
+186EF518D6A00E1572C8B79FADEF4ECAA511D944BD7638E3455673965E997CCB
+74FCC0E69D3D113EA9663F2577949C3EC41EB054F7BAF16F5CE20D4FBF83DCBF
+861F713CC1156F667E695B638ED370AF3AD8677D09E72C78B17D4937B30C6C7E
+07ACA29290A21FA04FDE586566E7613254CC2E6561E149A75C52012E6EEC502D
+9546409F56146AC21106C82F300E09E4EABC59127268F2D56879D309DB3B2DBE
+EB184C735B7FEBD82CDA647BD5F01FD7DCDAADF77A29D506D30E0A6808EFD850
+C6E0A39CA113C37A656E63CD0D0CF9C47F8CC8A2F5D3ECB230B533082535375E
+8351922762887F1B4D9826B0F881398563E3FDE4203C4E2E5B4300156E428CB9
+95715181B7BD4158A991FA6FF6169395F3AE6DF8F2758A90774F3044362FC554
+D8041FB7E5202D19E86AF5668E7969AE06A6AD474C1110CFF3C8B0E61ABE23D8
+41BDE82542CD6C1F82BB6AAE5C01DF2472A5BEAFEB4199F266F4700E0389A701
+7DBC926C3840DF38D7ACD68299F702647CCBA67B49A10CF96975C2B1FE78466F
+12C20119
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
+cleartomark
+%%EndFont
+TeXDict begin 39158280 55380996 1000 600 600 (tools.dvi)
+@start /Fa 240[45 15[{ TeXbbad153fEncoding ReEncodeFont }1
+90.9091 /CMSY10 rf /Fb 132[52 8[43 1[58 52 1[87 29 6[48
+58 46 12[79 6[79 82 1[63 2[40 2[66 2[76 74 7[29 11[29
+46[{ TeXf7b6d320Encoding ReEncodeFont }19 90.9091 /CMBX10
+rf /Fc 132[45 40 48 48 66 48 51 35 36 36 48 51 45 51
+76 25 48 28 25 51 45 28 40 51 40 51 45 25 5[56 68 68
+1[68 68 66 51 67 1[62 71 68 83 57 71 1[33 68 71 59 62
+69 66 64 68 3[71 2[25 1[45 1[45 45 45 45 45 45 45 45
+25 30 25 2[35 35 25 26[51 12[{ TeXf7b6d320Encoding ReEncodeFont }69
+90.9091 /CMR10 rf /Fd 195[71 60[{ TeXaae443f0Encoding ReEncodeFont }1
+90.9091 /CMMI10 rf /Fe 134[47 1[65 45 52 32 40 41 1[50
+50 55 80 25 45 30 30 50 45 30 45 50 45 45 50 10[72 72
+1[55 3[75 72 1[61 2[38 2[64 1[74 70 13[50 2[50 3[30 6[30
+26[55 12[{ TeX74afc74cEncoding ReEncodeFont }38 99.6264
+/CMTI12 rf /Ff 136[66 45 50 35 37 33 1[50 49 50 77 23
+2[23 50 49 30 43 50 43 50 47 7[64 64 92 64 66 67 54 63
+1[62 72 68 85 53 67 1[27 68 65 1[58 70 62 65 64 8[49
+49 49 3[49 49 2[27 1[27 2[38 38 27 3[81 49 21[52 12[{
+ TeXf7b6d320Encoding ReEncodeFont }55 99.6264 /CMSS12
+rf /Fg 129[44 6[44 44 44 44 44 2[44 2[44 44 2[44 44 2[44
+44 44 44 39[44 4[44 5[44 44 46[{ TeX09fbbfacEncoding ReEncodeFont }19
+83.022 /CMTT10 rf /Fh 139[25 33 10[41 104[{
+ TeXaae443f0Encoding ReEncodeFont }3 66.4176 /CMMI8 rf
+/Fi 135[51 2[51 49 38 50 53 46 53 51 1[43 2[25 51 1[44
+46 52 49 1[51 77[46 19[{ TeX0ef0afcaEncoding ReEncodeFont }18
+83.022 /CMCSC10 rf /Fj 134[44 1[60 44 46 32 33 33 1[46
+42 46 69 23 44 1[23 46 42 25 37 46 37 46 42 4[42 9[61
+2[65 62 76 2[43 30 62 65 54 57 63 60 1[62 6[23 10[42
+23 28 23 9[42 21[46 12[{ TeXf7b6d320Encoding ReEncodeFont }43
+83.022 /CMR10 rf /Fk 203[33 33 33 33 49[{
+ TeXf7b6d320Encoding ReEncodeFont }4 58.1154 /CMR7 rf
+/Fl 203[35 35 35 35 49[{ TeXf7b6d320Encoding ReEncodeFont }4
+66.4176 /CMR8 rf /Fm 134[44 15[28 4[46 2[46 6[56 1[68
+1[68 68 65 51 66 1[62 70 68 82 1[70 2[68 70 59 62 69
+65 1[68 7[46 46 46 1[46 46 46 46 46 46 1[28 33 45[{
+ TeX74afc74cEncoding ReEncodeFont }34 90.9091 /CMTI10
+rf /Fn 133[48 48 48 48 48 48 48 48 48 1[48 48 48 48 48
+2[48 48 48 48 48 48 48 48 48 1[48 4[48 48 48 48 48 48
+48 48 48 1[48 48 48 48 48 48 1[48 48 48 48 48 48 48 48
+48 1[48 1[48 2[48 48 48 48 48 48 48 48 48 48 48 48 48
+48 48 2[48 48 48 48 2[48 35[{ TeX09fbbfacEncoding ReEncodeFont }70
+90.9091 /CMTT10 rf /Fo 133[45 5[35 46 2[49 10[45 51 9[67
+57 81 1[57 66 57 60 74 77 63 75 78 94 66 2[43 1[77 1[72
+1[70 74 73 2[76 49 1[27 59[{ TeXaae443f0Encoding ReEncodeFont }29
+99.6264 /CMMI12 rf /Fp 240[50 11[50 2[77{
+ TeXbbad153fEncoding ReEncodeFont }3 99.6264 /CMSY10
+rf /Fq 133[50 61 61 1[61 61 59 46 60 63 56 63 61 74 51
+63 42 30 61 64 53 56 62 59 58 61 10[81 9[68 2[40 2[71
+1[83 14[55 7[38 32 1[55 22[55 55 18[{ TeX0ef0afcaEncoding ReEncodeFont }
+36 99.6264 /CMCSC10 rf /Fr 133[62 1[62 62 62 62 62 62
+62 1[62 62 62 62 62 2[62 62 1[62 62 62 62 62 62 46[62
+1[62 48[{ TeX09fbbfacEncoding ReEncodeFont }23 119.552
+/CMTT12 rf /Fs 134[71 71 97 71 75 52 53 55 1[75 67 75
+112 37 1[41 37 75 67 41 61 75 60 75 65 10[102 103 1[75
+2[92 3[81 6[88 103 97 8[37 3[67 67 67 67 67 67 2[37 1[37
+31[75 12[{ TeXf7b6d320Encoding ReEncodeFont }41 119.552
+/CMBX12 rf /Ft 133[51 51 51 51 51 51 51 51 51 1[51 51
+51 51 51 51 51 51 51 51 51 51 51 51 51 51 1[51 1[51 51
+51 51 51 51 1[51 51 51 51 51 1[51 51 51 51 51 51 51 51
+51 51 51 51 51 51 51 51 1[51 1[51 51 51 51 51 3[51 51
+51 51 51 51 51 51 51 51 1[51 51 51 51 51 1[51 51 51 34[{
+ TeX09fbbfacEncoding ReEncodeFont }77 99.6264 /CMTT12
+rf /Fu 132[49 43 51 51 70 51 54 38 38 38 51 54 49 54
+81 27 51 30 27 54 49 30 43 54 43 54 49 27 1[49 1[49 1[60
+73 73 100 73 73 70 54 72 1[66 76 73 89 61 76 50 35 73
+77 64 66 75 70 69 73 1[46 1[76 1[27 27 49 49 49 49 49
+49 49 49 49 49 49 27 33 27 76 49 38 38 27 2[49 1[49 19[81
+1[54 57 11[{ TeXf7b6d320Encoding ReEncodeFont }83 99.6264
+/CMR12 rf /Fv 132[56 1[59 59 81 59 62 44 44 46 1[62 56
+62 93 31 2[31 62 56 34 51 62 50 1[54 10[85 86 78 1[84
+1[77 84 88 106 67 2[42 1[88 70 74 86 81 80 85 7[56 56
+56 56 56 56 56 56 56 56 1[31 33[62 12[{
+ TeXf7b6d320Encoding ReEncodeFont }51 99.6264 /CMBX12
+rf /Fw 134[85 1[117 85 90 63 64 66 1[90 81 90 134 45
+2[45 90 81 49 74 90 72 1[78 10[122 3[120 3[126 153 3[60
+1[127 101 1[124 117 115 11[81 81 81 81 81 81 36[90 12[{
+ TeXf7b6d320Encoding ReEncodeFont }37 143.462 /CMBX12
+rf /Fx 133[52 4[65 46 46 46 2[59 65 1[33 2[33 65 2[52
+1[52 65 59 16[80 1[88 107 2[60 42 1[92 1[80 89 2[88 11[59
+2[59 59 59 1[33 1[33 44[{ TeXf7b6d320Encoding ReEncodeFont }29
+119.552 /CMR12 rf /Fy 139[61 62 61 2[79 1[133 43 6[70
+88 2[79 12[115 5[119 146 4[119 26[52 45[{
+ TeXf7b6d320Encoding ReEncodeFont }14 172.188 /CMR17
+rf end
+%%EndProlog
+%%BeginSetup
+%%Feature: *Resolution 600dpi
+TeXDict begin
+%%PaperSize: A4
+ end
+%%EndSetup
+%%Page: 1 1
+TeXDict begin 1 0 bop 850 525 a Fy(T)-13 b(o)t(ols)52
+b(related)g(to)g(Meso-NH)h(mo)t(del)264 821 y Fx(N.)38
+b(Asencio,)g(J.)g(Duron,)g(J.)h(Escobar,)e(D.)i(Gazen,)f(P)-10
+b(.)38 b(Jab)s(ouille,)f(I.)i(Mallet)1584 1055 y(Marc)m(h)f(21,)g(2005)
+88 1496 y Fw(Con)l(ten)l(ts)88 1715 y Fv(1)90 b(In)m(tro)s(duction)2960
+b(3)88 1933 y(2)90 b(Compression)39 b(of)e(FM)h(\014les)2383
+b(5)234 2053 y Fu(2.1)99 b Ft(lfiz)34 b Fu(to)s(ol)96
+b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)
+g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h
+(.)g(.)141 b(5)234 2173 y(2.2)99 b Ft(unlfiz)34 b Fu(to)s(ol)71
+b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)
+g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g
+(.)141 b(5)234 2294 y(2.3)99 b(Usage)c(.)50 b(.)f(.)h(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)141
+b(5)88 2512 y Fv(3)90 b(Con)m(v)m(ersion)38 b(of)g(FM)g(sync)m(hronous)
+g(\014le)g(to)f(diac)m(hronic)h(format)832 b(6)234 2632
+y Fu(3.1)99 b(Sync)m(hronous)35 b(and)e(diac)m(hronic)g(formats)26
+b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)
+g(.)g(.)f(.)h(.)g(.)141 b(6)234 2752 y(3.2)99 b Ft(conv2dia)35
+b Fu(to)s(ol)45 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)
+g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g
+(.)f(.)h(.)g(.)141 b(6)234 2873 y(3.3)99 b(Example)53
+b(.)c(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)141 b(7)88 3091 y Fv(4)90 b(Con)m(v)m(ersion)38
+b(to)f(NetCDF)g(\014les)2215 b(8)234 3211 y Fu(4.1)99
+b Ft(lfi2cdf)35 b Fu(to)s(ol)96 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)
+f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)141 b(8)458 3331 y(4.1.1)111
+b(Usage)90 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)141 b(8)234 3452 y(4.2)99 b Ft(extractdia)35
+b Fu(to)s(ol)97 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)
+g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h
+(.)g(.)141 b(8)88 3670 y Fv(5)90 b(Dealing)38 b(with)g(diac)m(hronic)g
+(\014les)2185 b(9)234 3790 y Fu(5.1)99 b(Extracte)34
+b(\014elds,)g(domain,)f(c)m(hange)g(format)f(with)h Ft(extractdia)j
+Fu(to)s(ol)30 b(.)50 b(.)g(.)g(.)g(.)f(.)h(.)g(.)141
+b(9)234 3911 y(5.2)99 b(P)m(ersonal)34 b(mo)s(di\014cations:)44
+b Ft(exrwdia)35 b Fu(program)26 b(.)50 b(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)
+g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93 b(11)458 4031
+y(5.2.1)111 b(Routines)34 b(of)e(reading)h(and)f(writing)60
+b(.)50 b(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)
+f(.)h(.)g(.)93 b(11)458 4151 y(5.2.2)111 b(Compilation)48
+b(.)i(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f
+(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93
+b(12)234 4272 y(5.3)99 b(Compare)34 b(to)e(observ)-5
+b(ations)33 b(with)h Ft(mesonh2obs)h Fu(to)s(ol)89 b(.)49
+b(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93
+b(13)458 4392 y(5.3.1)111 b(Input)34 b(and)e(output)59
+b(.)50 b(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)
+g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93 b(13)458
+4512 y(5.3.2)111 b(Usage)90 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)f(.)h(.)g(.)93 b(13)458 4633 y(5.3.3)111
+b(Metho)s(d)89 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)93 b(14)234 4753 y(5.4)99 b(Compare)34 b(to)e(observ)-5
+b(ations)33 b(with)h Ft(obs2mesonh)h Fu(to)s(ol)89 b(.)49
+b(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93
+b(14)458 4874 y(5.4.1)111 b(Input)34 b(and)e(output)59
+b(.)50 b(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)
+g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93 b(14)458
+4994 y(5.4.2)111 b(Usage)90 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)f(.)h(.)g(.)93 b(14)458 5114 y(5.4.3)111
+b(Metho)s(d)89 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)93 b(15)234 5235 y(5.5)99 b(Catenation)33 b(of)f(Lagrangian)g
+(tra)5 b(jectory)33 b(with)h Ft(compute)p 2625 5235 31
+4 v 38 w(r00)p 2816 5235 V 38 w(pc)f Fu(to)s(ol)40 b(.)50
+b(.)g(.)g(.)f(.)h(.)g(.)93 b(15)458 5355 y(5.5.1)111
+b(Input)34 b(and)e(output)59 b(.)50 b(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)
+g(.)93 b(15)458 5476 y(5.5.2)111 b(Usage)90 b(.)50 b(.)g(.)g(.)g(.)g(.)
+g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g
+(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93 b(16)458
+5596 y(5.5.3)111 b(Metho)s(d)89 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)f(.)h(.)g(.)93 b(16)1953 5941 y(1)p eop
+end
+%%Page: 2 2
+TeXDict begin 2 1 bop 88 123 a Fv(6)90 b(Con)m(v)m(ersion)38
+b(to)f(GRIB)f(or)i(Vis5D)f(\014les)1807 b(17)234 243
+y Fu(6.1)99 b(Presen)m(tation)43 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)g
+(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)
+g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93 b(17)234 364 y(6.2)99
+b(Usage)c(.)50 b(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)
+g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g
+(.)g(.)g(.)f(.)h(.)g(.)93 b(17)458 484 y(6.2.1)111 b
+Ft(lfi2grb)35 b Fu(to)s(ol)92 b(.)50 b(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g
+(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)
+f(.)h(.)g(.)93 b(17)458 604 y(6.2.2)111 b(Example)34
+b(of)f Ft(lfi2grb)h Fu(use)68 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g
+(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93
+b(18)458 725 y(6.2.3)111 b Ft(lfi2v5d)35 b Fu(to)s(ol)92
+b(.)50 b(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93
+b(19)458 845 y(6.2.4)111 b(Example)34 b(of)f Ft(lfi2v5d)h
+Fu(use)68 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g
+(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93 b(19)458 965
+y(6.2.5)111 b Fv(CONVLFI)33 b Fu(program)50 b(.)f(.)h(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)93 b(20)234 1086 y(6.3)99 b(Short)33 b(description)h(of)e(the)h
+(program)98 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)
+g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93 b(23)234 1206
+y(6.4)99 b(Some)33 b(tips)h(to)e(use)h(Vis5D)39 b(.)50
+b(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g
+(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93 b(24)458
+1327 y(6.4.1)111 b(Utilities)81 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)f(.)h(.)g(.)93 b(24)458 1447 y(6.4.2)111
+b(Options)83 b(.)50 b(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g
+(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)93 b(24)458 1567 y(6.4.3)111 b(Con)m(trol)33
+b(panel)68 b(.)50 b(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g
+(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93
+b(25)458 1688 y(6.4.4)111 b(Adv)-5 b(anced)34 b(use)65
+b(.)50 b(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)
+h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93
+b(27)234 1808 y(6.5)99 b(State)33 b(of)f(art)86 b(.)50
+b(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g
+(.)g(.)g(.)f(.)h(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)g(.)f(.)h(.)g(.)93
+b(27)1953 5941 y(2)p eop end
+%%Page: 3 3
+TeXDict begin 3 2 bop 88 123 a Fw(1)161 b(In)l(tro)t(duction)88
+342 y Fu(After)28 b(initialisation,)h(run)f(of)g(the)g(mo)s(del)g(or)g
+(computation)g(of)f(diagnostics,)j(output)e(Meso-NH)h(\014les)88
+462 y(can)g(b)s(e)g(con)m(v)m(ert)h(in)m(to)f(other)g(formats)g(of)g
+(\014les.)43 b(The)30 b(presen)m(t)g(do)s(cumen)m(tation)g(aims)g(at)e
+(describ)j(the)88 583 y(di\013eren)m(ts)38 b(to)s(ols)f(whic)m(h)i(can)
+f(b)s(e)f(applied)h(to)f(the)h(binary)f(part)g(of)g(FM)g(\014les)i
+(\(their)e(su\016x)i(is)f Fv(.l\014)p Fu(\).)88 703 y(Most)28
+b(of)g(these)i(to)s(ols)e(can)g(b)s(e)g(run)h(on)f(the)h(user)g(lo)s
+(cal)f(computer)h(\(Lin)m(ux)g(PC)g(or)f(HP)h(w)m(orkstation\).)234
+944 y(First,)36 b(the)g(compression)h(to)s(ol)d Ft(lfiz)i
+Fu(and)g(the)f(con)m(v)m(ersion)j(to)s(ol)c Ft(conv2dia)k
+Fu(dealing)d(with)h(FM)88 1064 y(\014les)d(\(sync)m(hronous)h(and)f
+(diac)m(hronic\))g(as)f(input)h(and)f(output,)h(are)f(describ)s(ed.)45
+b(The)33 b(next)g(sections)88 1184 y(concern)39 b(to)s(ols)f(dealing)h
+(with)g(other)f(formats)g(than)g(FM:)h(con)m(v)m(ersions)i(with)e
+Ft(lfi2cdf)p Fu(,)i Ft(lfi2grb)88 1305 y Fu(and)34 b
+Ft(lfi2v5d)p Fu(.)50 b(A)34 b(set)h(of)f(to)s(ols)f(for)h(reading)h
+(diac)m(hronic)g(FM)f(\014les)h(and)f(dealing)h(with)g(diac)m(hronic)88
+1425 y(informations)28 b(is)h(presen)m(ted:)44 b Ft(extractdia)p
+Fu(,)32 b Ft(mesonh2obs)f Fu(and)e Ft(obs2mesonh)i Fu(\(the)e(2)f
+(latest)h(aim)f(at)88 1546 y(help)33 b(users)h(to)e(compare)h(MesoNH)h
+(outputs)f(to)g(observ)-5 b(ations\).)234 1786 y(The)29
+b(\014gure)g(1)f(sho)m(ws)i(when)f(a)f(FM)h(\014le)g(is)f(either)i
+(sync)m(hronous)p 2078 1819 522 4 v 30 w(\(con)m(tains)g(the)e(v)-5
+b(alues)30 b(of)d(all)i(the)88 1907 y(\014elds)38 b(corresp)s(onding)g
+(to)e(the)i(same)g(instan)m(t)g(of)e(the)h(sim)m(ulation\))i(or)d(diac)
+m(hronic)p 2779 1920 437 4 v 38 w(\(con)m(tains)i(time)88
+2027 y(series)i(of)e(some)h(\014elds)g(obtained)g(during)g(the)g(run)g
+(of)f(the)g(mo)s(del\).)62 b(Then)39 b(the)g(\014gure)g(2)f(resumes)88
+2148 y(the)23 b(to)s(ols)g(whic)m(h)i(can)f(b)s(e)g(applied)g(to)f(a)g
+(FM)g(\014le)h(according)g(its)g(t)m(yp)s(e,)i(one)e(of)f(the)g(t)m(w)m
+(o)h(previous)h(ones.)88 3560 y @beginspecial 0 @llx
+676 @lly 567 @urx 842 @ury 4819 @rwi @setspecial
+%%BeginDocument: fic1.eps
+%!PS-Adobe-3.0 EPSF-3.0
+%%BoundingBox: 0 676 567 842
+%%Title: fic1
+%%CreationDate: Thu Jun 17 11:02:56 2004
+%%Creator: Tgif-4.1.33 by William Chia-Wei Cheng (william@cs.UCLA.edu)
+%%ProducedBy: (unknown)
+%%Pages: 1
+%%DocumentFonts: (atend)
+%%EndComments
+%%BeginProlog
+
+/tgifdict 86 dict def
+tgifdict begin
+
+/tgifarrowtipdict 8 dict def
+tgifarrowtipdict /mtrx matrix put
+
+/TGAT % tgifarrowtip
+ { tgifarrowtipdict begin
+ /dy exch def
+ /dx exch def
+ /h exch def
+ /w exch def
+ /y exch def
+ /x exch def
+ /savematrix mtrx currentmatrix def
+ x y translate
+ dy dx atan rotate
+ 0 0 moveto
+ w neg h lineto
+ w neg h neg lineto
+ savematrix setmatrix
+ end
+ } def
+
+/tgifpatdict 10 dict def
+
+/tgifpatbyte
+ { currentdict /retstr get exch
+ pat i cellsz mod get put
+ } def
+
+/tgifpatproc
+ { 0 1 widthlim {tgifpatbyte} for retstr
+ /i i 1 add def
+ } def
+
+/TGPF % tgifpatfill
+ { tgifpatdict begin
+ /h exch def
+ /w exch def
+ /lty exch def
+ /ltx exch def
+ /cellsz exch def
+ /pat exch def
+
+ /widthlim w cellsz div cvi 1 sub def
+ /retstr widthlim 1 add string def
+ /i 0 def
+
+ tgiforigctm setmatrix
+ ltx lty translate
+ w h true [1 0 0 1 0 0] {tgifpatproc} imagemask
+ ltx neg lty neg translate
+ end
+ } def
+
+/pat3 <8000000008000000> def
+/pat4 <8800000022000000> def
+/pat5 <8800220088002200> def
+/pat6 <8822882288228822> def
+/pat7 <aa55aa55aa55aa55> def
+/pat8 <77dd77dd77dd77dd> def
+/pat9 <77ffddff77ffddff> def
+/pat10 <77ffffff77ffffff> def
+/pat11 <7fffffff7fffffff> def
+/pat12 <8040200002040800> def
+/pat13 <40a00000040a0000> def
+/pat14 <ff888888ff888888> def
+/pat15 <ff808080ff080808> def
+/pat16 <f87422478f172271> def
+/pat17 <038448300c020101> def
+/pat18 <081c22c180010204> def
+/pat19 <8080413e080814e3> def
+/pat20 <8040201008040201> def
+/pat21 <8844221188442211> def
+/pat22 <77bbddee77bbddee> def
+/pat23 <c1e070381c0e0783> def
+/pat24 <7fbfdfeff7fbfdfe> def
+/pat25 <3e1f8fc7e3f1f87c> def
+/pat26 <0102040810204080> def
+/pat27 <1122448811224488> def
+/pat28 <eeddbb77eeddbb77> def
+/pat29 <83070e1c3870e0c1> def
+/pat30 <fefdfbf7efdfbf7f> def
+/pat31 <7cf8f1e3c78f1f3e> def
+
+/TGMAX
+ { exch dup 3 1 roll exch dup 3 1 roll gt { pop } { exch pop } ifelse
+ } def
+/TGMIN
+ { exch dup 3 1 roll exch dup 3 1 roll lt { pop } { exch pop } ifelse
+ } def
+/TGSW { stringwidth pop } def
+
+/bd { bind def } bind def
+
+/GS { gsave } bd
+/GR { grestore } bd
+/NP { newpath } bd
+/CP { closepath } bd
+/CHP { charpath } bd
+/CT { curveto } bd
+/L { lineto } bd
+/RL { rlineto } bd
+/M { moveto } bd
+/RM { rmoveto } bd
+/S { stroke } bd
+/F { fill } bd
+/TR { translate } bd
+/RO { rotate } bd
+/SC { scale } bd
+/MU { mul } bd
+/DI { div } bd
+/DU { dup } bd
+/NE { neg } bd
+/AD { add } bd
+/SU { sub } bd
+/PO { pop } bd
+/EX { exch } bd
+/CO { concat } bd
+/CL { clip } bd
+/EC { eoclip } bd
+/EF { eofill } bd
+/IM { image } bd
+/IMM { imagemask } bd
+/ARY { array } bd
+/SG { setgray } bd
+/RG { setrgbcolor } bd
+/SD { setdash } bd
+/W { setlinewidth } bd
+/SM { setmiterlimit } bd
+/SLC { setlinecap } bd
+/SLJ { setlinejoin } bd
+/SH { show } bd
+/FF { findfont } bd
+/MS { makefont setfont } bd
+/AR { arcto 4 {pop} repeat } bd
+/CURP { currentpoint } bd
+/FLAT { flattenpath strokepath clip newpath } bd
+/TGSM { tgiforigctm setmatrix } def
+/TGRM { savematrix setmatrix } def
+
+end
+
+%%EndProlog
+%%Page: 1 1
+
+%%PageBoundingBox: 0 676 567 842
+tgifdict begin
+/tgifsavedpage save def
+
+1 SM
+1 W
+
+0 SG
+
+72 0 MU 72 11.695 MU TR
+72 128 DI 100.000 MU 100 DI DU NE SC
+
+GS
+
+/tgiforigctm matrix currentmatrix def
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 368 16 M
+ GS
+ 0 SG
+ /Courier FF [17 0 0 -17 0 0] MS
+ (prepmodel MAINPROG=) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 160 64 M
+ GS
+ GS
+ 0
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_PGD) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_PGD) SH
+ GR
+ 0 17 RM
+ GS
+ GS
+ 0
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_NEST_PGD) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_NEST_PGD) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 336 64 M
+ GS
+ GS
+ 0
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_IDEAL_CASE) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_IDEAL_CASE) SH
+ GR
+ 0 17 RM
+ GS
+ GS
+ 0
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_REAL_CASE) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (PREP_REAL_CASE) SH
+ GR
+ 0 17 RM
+ GS
+ GS
+ 0
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (DIAG) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (DIAG) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 640 64 M
+ GS
+ GS
+ 0
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (MODEL) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica FF [14 0 0 -14 0 0] MS
+ (MODEL) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 160 160 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (physiographic output) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (physiographic output) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 320 160 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (synchronous output) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (synchronous output) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 576 160 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (synchronous outputs) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (synchronous outputs) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 864 160 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (diachronic output) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (diachronic output) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+GS
+ NP 137 161 M 183 161 L 183 180 L 137 180 L CP 1 SG F
+ 0 SG
+ NP 137 161 M 183 161 L 183 180 L 137 180 L CP EC NP
+ pat26 8 136 160 56 24 TGPF
+GR
+ GS
+ 1 W
+ 160 176 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (PGD.lfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 1.000 0.000 0.000 RG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (PGD.lfi) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+GS
+ NP 329 193 M 375 193 L 375 212 L 329 212 L CP 1 SG F
+ 0 SG
+ NP 329 193 M 375 193 L 375 212 L 329 212 L CP EC NP
+ pat26 8 328 192 56 24 TGPF
+GR
+ GS
+ 1 W
+ 352 208 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (INIT.lfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 1.000 0.000 0.000 RG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (INIT.lfi) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 272 208 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (INIT.des) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (INIT.des) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 496 208 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.00n.des) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.00n.des) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+GS
+ NP 577 193 M 702 193 L 702 212 L 577 212 L CP 1 SG F
+ 0 SG
+ NP 577 193 M 702 193 L 702 212 L 577 212 L CP EC NP
+ pat26 8 576 192 128 24 TGPF
+GR
+ GS
+ 1 W
+ 640 208 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.00n.lfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 1.000 0.000 0.000 RG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.00n.lfi) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 800 208 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.000.des) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.000.des) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+GS
+ NP 881 193 M 1006 193 L 1006 212 L 881 212 L CP 1 SG F
+ 0 SG
+ NP 881 193 M 1006 193 L 1006 212 L 881 212 L CP EC NP
+ pat4 8 880 192 128 24 TGPF
+GR
+ GS
+ 1 W
+ 944 208 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.000.lfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.000.lfi) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 48 192 M
+ GS
+ GS
+ 0
+ /Courier FF [12 0 0 -12 0 0] MS
+ (fm2deslfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Courier FF [12 0 0 -12 0 0] MS
+ (fm2deslfi) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 320 176 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (INIT) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (INIT) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 576 176 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.00n) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.00n) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 864 176 M
+ GS
+ GS
+ 0
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.000) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Italic FF [14 0 0 -14 0 0] MS
+ (CEXP.1.CSEG.000) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 336 176 M
+ 16 16 atan DU cos 8.000 MU 352 exch SU
+ exch sin 8.000 MU 192 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 352 192 8.000 3.000 16 16 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 352 192 8.000 3.000 16 16 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 640 176 M
+ 16 16 atan DU cos 8.000 MU 656 exch SU
+ exch sin 8.000 MU 192 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 656 192 8.000 3.000 16 16 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 656 192 8.000 3.000 16 16 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 928 176 M
+ 16 16 atan DU cos 8.000 MU 944 exch SU
+ exch sin 8.000 MU 192 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 944 192 8.000 3.000 16 16 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 944 192 8.000 3.000 16 16 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 800 176 M
+ 16 -16 atan DU cos 8.000 MU 784 exch SU
+ exch sin 8.000 MU 192 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 784 192 8.000 3.000 -16 16 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 784 192 8.000 3.000 -16 16 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 512 176 M
+ 16 -16 atan DU cos 8.000 MU 496 exch SU
+ exch sin 8.000 MU 192 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 496 192 8.000 3.000 -16 16 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 496 192 8.000 3.000 -16 16 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 304 176 M
+ 16 -16 atan DU cos 8.000 MU 288 exch SU
+ exch sin 8.000 MU 192 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 288 192 8.000 3.000 -16 16 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 288 192 8.000 3.000 -16 16 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+0 SG
+GS
+ NP 109 273 M 483 273 L 483 292 L 109 292 L CP 1 SG F
+ 0 SG
+ NP 109 273 M 483 273 L 483 292 L 109 292 L CP EC NP
+ pat26 8 104 272 384 24 TGPF
+GR
+ GS
+ 1 W
+ 296 288 M
+ GS
+ GS
+ 0
+ /Times-Bold FF [14 0 0 -14 0 0] MS
+ (synchronuous files: PGD.lfi, INIT.lfi, CEXP.1.CSEG.00n.lfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 1.000 0.000 0.000 RG
+ /Times-Bold FF [14 0 0 -14 0 0] MS
+ (synchronuous files: PGD.lfi, INIT.lfi, CEXP.1.CSEG.00n.lfi) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+GS
+ NP 658 273 M 894 273 L 894 292 L 658 292 L CP 1 SG F
+ 0 SG
+ NP 658 273 M 894 273 L 894 292 L 658 292 L CP EC NP
+ pat4 8 656 272 240 24 TGPF
+GR
+ GS
+ 1 W
+ 776 288 M
+ GS
+ GS
+ 0
+ /Times-Bold FF [14 0 0 -14 0 0] MS
+ (diachronic file: CEXP.1.CSEG.000.lfi) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Times-Bold FF [14 0 0 -14 0 0] MS
+ (diachronic file: CEXP.1.CSEG.000.lfi) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ [4 4] 0 SD
+ NP
+ 240 32 M
+ 240 152 L
+ TGSM
+ 1 W
+ S
+ [] 0 SD
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ [4 4] 0 SD
+ NP
+ 416 32 M
+ 416 152 L
+ TGSM
+ 1 W
+ S
+ [] 0 SD
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 64 208 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (\() TGSW
+ AD
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (on the computer where ) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [14 0 0 -14 0 0] MS
+ (\() SH
+ 0 SG
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (on the computer where ) SH
+ GR
+ 0 15 RM
+ GS
+ GS
+ 0
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ ( the file was created\)) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ ( the file was created\)) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 576 112 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t1,t2,...,tn) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t1,t2,...,tn) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 552 120 M
+ 24 0 atan DU cos 8.000 MU 552 exch SU
+ exch sin 8.000 MU 144 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 552 144 8.000 3.000 0 24 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 552 144 8.000 3.000 0 24 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 568 120 M
+ 24 0 atan DU cos 8.000 MU 568 exch SU
+ exch sin 8.000 MU 144 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 568 144 8.000 3.000 0 24 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 568 144 8.000 3.000 0 24 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 592 120 M
+ 24 0 atan DU cos 8.000 MU 592 exch SU
+ exch sin 8.000 MU 144 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 592 144 8.000 3.000 0 24 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 592 144 8.000 3.000 0 24 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 800 120 M
+ 872 120 L
+ 24 0 atan DU cos 8.000 MU 872 exch SU
+ exch sin 8.000 MU 144 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 872 144 8.000 3.000 0 24 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 872 144 8.000 3.000 0 24 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 880 120 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 328 116 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t0) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t0) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 328 120 M
+ 24 0 atan DU cos 8.000 MU 328 exch SU
+ exch sin 8.000 MU 144 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 328 144 8.000 3.000 0 24 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 328 144 8.000 3.000 0 24 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 160 116 M
+ GS
+ GS
+ 0
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t0) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Times-Roman FF [12 0 0 -12 0 0] MS
+ (t0) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 160 120 M
+ 24 0 atan DU cos 8.000 MU 160 exch SU
+ exch sin 8.000 MU 144 exch SU L
+ TGSM
+ 1 W
+ S
+GR
+GS
+ TGSM
+ NP
+ 160 144 8.000 3.000 0 24 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 160 144 8.000 3.000 0 24 TGAT
+ CP F
+GR
+
+GR
+tgifsavedpage restore
+end
+showpage
+
+%%Trailer
+%MatchingCreationDate: Thu Jun 17 11:02:56 2004
+%%DocumentFonts: Times-Bold
+%%+ Times-Italic
+%%+ Times-Roman
+%%+ Helvetica
+%%+ Courier
+%%EOF
+
+%%EndDocument
+ @endspecial 858 3763 a(Figure)32 b(1:)44 b(T)m(yp)s(e)34
+b(of)e(FM)g(\014les)i(after)e(a)g(MesoNH)i(program)1953
+5941 y(3)p eop end
+%%Page: 4 4
+TeXDict begin 4 3 bop -47 4212 a @beginspecial 3 @llx
+397 @lly 592 @urx 827 @ury 4819 @rwi @setspecial
+%%BeginDocument: toolstab.eps
+%!PS-Adobe-3.0 EPSF-3.0
+%%BoundingBox: 3 397 592 827
+%%Title: toolstab
+%%CreationDate: Wed Mar 2 10:14:19 2005
+%%Creator: Tgif-4.1.43-QPL written by William Chia-Wei Cheng (bill.cheng@acm.org)
+%%ProducedBy: (unknown)
+%%Pages: 1
+%%DocumentFonts: (atend)
+%%EndComments
+%%BeginProlog
+
+/tgifdict 56 dict def
+tgifdict begin
+
+/tgifarrowtipdict 8 dict def
+tgifarrowtipdict /mtrx matrix put
+
+/TGAT % tgifarrowtip
+ { tgifarrowtipdict begin
+ /dy exch def
+ /dx exch def
+ /h exch def
+ /w exch def
+ /y exch def
+ /x exch def
+ /savematrix mtrx currentmatrix def
+ x y translate
+ dy dx atan rotate
+ 0 0 moveto
+ w neg h lineto
+ w neg h neg lineto
+ savematrix setmatrix
+ end
+ } def
+
+/tgifarcdict 8 dict def
+tgifarcdict /mtrx matrix put
+
+/TGAN % tgifarcn
+ { tgifarcdict begin
+ /endangle exch def
+ /startangle exch def
+ /yrad exch def
+ /xrad exch def
+ /y exch def
+ /x exch def
+ /savematrix mtrx currentmatrix def
+ x y translate
+ xrad yrad scale
+ 0 0 1 startangle endangle arc
+ savematrix setmatrix
+ end
+ } def
+
+/TGAR % tgifarc
+ { tgifarcdict begin
+ /endangle exch def
+ /startangle exch def
+ /yrad exch def
+ /xrad exch def
+ /y exch def
+ /x exch def
+ /savematrix mtrx currentmatrix def
+ x y translate
+ xrad yrad scale
+ 0 0 1 startangle endangle arcn
+ savematrix setmatrix
+ end
+ } def
+
+/TGMAX
+ { exch dup 3 1 roll exch dup 3 1 roll gt { pop } { exch pop } ifelse
+ } def
+/TGMIN
+ { exch dup 3 1 roll exch dup 3 1 roll lt { pop } { exch pop } ifelse
+ } def
+/TGSW { stringwidth pop } def
+
+/bd { bind def } bind def
+
+/GS { gsave } bd
+/GR { grestore } bd
+/NP { newpath } bd
+/CP { closepath } bd
+/CHP { charpath } bd
+/CT { curveto } bd
+/L { lineto } bd
+/RL { rlineto } bd
+/M { moveto } bd
+/RM { rmoveto } bd
+/S { stroke } bd
+/F { fill } bd
+/TR { translate } bd
+/RO { rotate } bd
+/SC { scale } bd
+/MU { mul } bd
+/DI { div } bd
+/DU { dup } bd
+/NE { neg } bd
+/AD { add } bd
+/SU { sub } bd
+/PO { pop } bd
+/EX { exch } bd
+/CO { concat } bd
+/CL { clip } bd
+/EC { eoclip } bd
+/EF { eofill } bd
+/IM { image } bd
+/IMM { imagemask } bd
+/ARY { array } bd
+/SG { setgray } bd
+/RG { setrgbcolor } bd
+/SD { setdash } bd
+/W { setlinewidth } bd
+/SM { setmiterlimit } bd
+/SLC { setlinecap } bd
+/SLJ { setlinejoin } bd
+/SH { show } bd
+/FF { findfont } bd
+/MS { makefont setfont } bd
+/AR { arcto 4 {pop} repeat } bd
+/CURP { currentpoint } bd
+/FLAT { flattenpath strokepath clip newpath } bd
+/TGSM { tgiforigctm setmatrix } def
+/TGRM { savematrix setmatrix } def
+
+end
+
+%%EndProlog
+%%Page: 1 1
+
+%%PageBoundingBox: 3 397 592 827
+tgifdict begin
+/tgifsavedpage save def
+
+1 SM
+1 W
+
+0 SG
+
+72 0 MU 72 11.695 MU TR
+72 128 DI 100.000 MU 100 DI DU NE SC
+
+GS
+
+/tgiforigctm matrix currentmatrix def
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 40 40 M
+ 168 104 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 32 M
+ 168 784 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 104 M
+ 840 104 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 424 32 M
+ 424 784 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 104 56 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (IN) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 56 88 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (OUT) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 232 56 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (synchronous FM file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 496 56 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (diachronic FM file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 296 72 M
+ 296 232 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 552 72 M
+ 552 232 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 172 88 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Uncompressed) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 312 88 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Compressed) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 56 152 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (synchro-) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (synchro-) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (nuous ) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (nuous ) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (FM file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (FM file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 104 168 M
+ 840 168 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 104 144 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Uncomp.) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 56 288 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (diachronic) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (diachronic) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (FM file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (FM file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 232 M
+ 840 232 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 432 88 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Uncompressed) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 576 88 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Compressed) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 104 208 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Comp.) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 68 268 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Uncomp.) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 72 328 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (Comp.) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 104 296 M
+ 840 296 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 360 M
+ 840 360 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 360 136 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 224 208 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) SH
+ GR
+ GR
+
+% ARC
+0 SG
+GS
+ GS
+ NP
+ 92 92 45 45 -105 -131 TGAR
+ 2 W
+ S
+ GR
+GR
+GS
+ TGSM
+ NP
+ 57 64 10.000 4.000 -55 71 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 57 64 10.000 4.000 -55 71 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 104 M
+ 296 168 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 168 M
+ 296 104 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 424 104 M
+ 680 232 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 424 232 M
+ 680 104 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 296 168 M
+ 424 232 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 296 232 M
+ 424 168 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 296 252 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (conv2dia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (conv2dia) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 476 316 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 424 M
+ 680 424 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 488 M
+ 680 488 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 624 280 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 64 392 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (GRIB) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (GRIB) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 248 392 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2grb) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2grb) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 64 456 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (Vis5D) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (Vis5D) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 248 456 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2v5d) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2v5d) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 68 516 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (NetCDF) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (NetCDF) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 232 512 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 488 512 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 552 M
+ 680 552 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 64 584 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (ASCII) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (ASCII) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 616 M
+ 680 616 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 76 648 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (NCAR-CGM) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ (NCAR-CGM) SH
+ GR
+ 0 25 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Bold FF [17 0 0 -17 0 0] MS
+ ( file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 616 M
+ 424 680 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 680 M
+ 424 616 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 552 656 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (diaprog) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.373 0.620 0.627 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (diaprog) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 552 572 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (diaprog ) TGSW
+ AD
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (->FICVAL) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.373 0.620 0.627 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (diaprog ) SH
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (->FICVAL) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 552 592 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 488 536 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 296 320 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (conv2dia+lfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (conv2dia+lfiz) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 624 536 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 552 488 M
+ 552 552 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 296 488 M
+ 296 552 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 616 252 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 492 348 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia+lfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia+lfiz) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 680 M
+ 680 680 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 560 696 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (exrwdia \(readvar, writevar,) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (exrwdia \(readvar, writevar,) SH
+ GR
+ 0 23 RM
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (zinter,pinter,lalo\)) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (zinter,pinter,lalo\)) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 736 M
+ 168 784 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 424 736 M
+ 424 784 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 96 744 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (ex: diachronic file) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (ex: diachronic file) SH
+ GR
+ 0 23 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (\(Lag. var.\)) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (\(Lag. var.\)) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 292 760 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (DIAG with) TGSW
+ AD
+ /Helvetica-Bold FF [14 0 0 -14 0 0] MS
+ ( LTRAJ =TRUE) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (DIAG with) SH
+ 0 SG
+ /Helvetica-Bold FF [14 0 0 -14 0 0] MS
+ ( LTRAJ =TRUE) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 560 752 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [14 0 0 -14 0 0] MS
+ (compute_r00_pc ) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [14 0 0 -14 0 0] MS
+ (compute_r00_pc ) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 552 608 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (mesonh2obs) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (mesonh2obs) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 840 32 M
+ 840 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 680 32 M
+ 840 32 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 720 72 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (ASCII file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 760 136 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (PREP_PGD) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (PREP_PGD) SH
+ GR
+ 0 23 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (\() TGSW
+ AD
+ /Helvetica-Bold FF [14 0 0 -14 0 0] MS
+ (&NAM_DUMMY_PGD) TGSW
+ AD
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (\)) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (\() SH
+ 0 SG
+ /Helvetica-Bold FF [14 0 0 -14 0 0] MS
+ (&NAM_DUMMY_PGD) SH
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (\)) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 760 192 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (PREP_PGD) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (PREP_PGD) SH
+ GR
+ 0 19 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (+) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (+) SH
+ GR
+ 0 19 RM
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 344 392 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (CONVLFI) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (CONVLFI) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 344 456 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (CONVLFI) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (CONVLFI) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 96 704 M
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (other treatments,) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (other treatments,) SH
+ GR
+ 0 17 RM
+ GS
+ GS
+ 0
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (other formats) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (other formats) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 352 512 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz+) TGSW
+ AD
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz+) SH
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 624 512 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz+) TGSW
+ AD
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (unlfiz+) SH
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfi2cdf) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 224 396 M
+ 272 396 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 224 460 M
+ 276 460 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 208 516 M
+ 256 516 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 356 516 M
+ 404 516 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 452 540 M
+ 524 540 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 464 516 M
+ 508 516 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 628 516 M
+ 672 516 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 588 540 M
+ 656 540 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 516 596 M
+ 584 596 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 504 612 M
+ 600 612 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 460 700 M
+ 516 700 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 764 272 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (obs2mesonh) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (obs2mesonh) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 716 276 M
+ 812 276 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 764 316 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (obs2mesonh) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (obs2mesonh) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 716 320 M
+ 812 320 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 764 336 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (+) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (+) SH
+ GR
+ 0 19 RM
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (lfiz) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 688 428 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (MAINPROG) SH
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ ( : ) SH
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ (main program of MesoNH ) SH
+ GR
+ 0 23 RM
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [17 0 0 -17 0 0] MS
+ ( \(run it on supc with prepmodel\)) SH
+ GR
+ 0 23 RM
+ GS
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (tool : one of the libtools package ) SH
+ GR
+ 0 23 RM
+ GS
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ ( \(run it interactively on local host\)) SH
+ GR
+ 0 23 RM
+ GS
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ ( \() SH
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (tool) SH
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ ( with change of file format\)) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 744 512 M
+ 768 512 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 492 280 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 552 232 M
+ 552 296 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 552 296 M
+ 552 360 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 624 348 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0 SG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 712 524 M
+ 740 524 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 140 520 M
+ 680 520 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 104 544 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (var. list) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 112 508 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (all var.) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 140 324 M
+ 680 324 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 140 260 M
+ 680 260 L
+ TGSM
+ 1 W
+ S
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 108 252 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (all var.) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 108 316 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (all var.) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 104 288 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (var. list) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 100 352 M
+ GS
+ 0 SG
+ /NewCenturySchlbk-Roman FF [14 0 0 -14 0 0] MS
+ (var. list) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 260 M
+ 420 292 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 292 M
+ 420 260 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 172 324 M
+ 424 356 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 172 356 M
+ 424 324 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 552 M
+ 424 616 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 168 616 M
+ 424 552 L
+ TGSM
+ 2 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 548 396 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia in future) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia in future) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 548 456 M
+ GS
+ GS
+ 0
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia in future) TGSW
+ AD
+ GR
+ 2 DI NE 0 RM
+ 0.000 0.000 1.000 RG
+ /Helvetica-Bold FF [17 0 0 -17 0 0] MS
+ (extractdia in future) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 472 400 M
+ 544 400 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 476 460 M
+ 548 460 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 28 M
+ 12 788 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 680 32 M
+ 12 32 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 12 784 M
+ 684 784 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 684 360 M
+ 684 784 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 684 32 M
+ 684 364 L
+ TGSM
+ 1 W
+ S
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 684 360 M
+ 840 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+GR
+tgifsavedpage restore
+end
+showpage
+
+%%Trailer
+%MatchingCreationDate: Wed Mar 2 10:14:19 2005
+%%DocumentFonts: Helvetica-Bold
+%%+ NewCenturySchlbk-Bold
+%%+ NewCenturySchlbk-Roman
+%%EOF
+
+%%EndDocument
+ @endspecial 1205 4416 a Fu(Figure)32 b(2:)43 b(Whic)m(h)34
+b(to)s(ols)e(on)h(FM)g(\014les?)1953 5941 y(4)p eop end
+%%Page: 5 5
+TeXDict begin 5 4 bop 88 123 a Fw(2)161 b(Compression)51
+b(of)j(FM)g(\014les)88 342 y Fu(A)33 b(sp)s(eci\014c)j(compression)f
+(to)s(ol)e(has)i(b)s(een)f(dev)m(elop)s(ed)i(for)d(FM)h(\014les.)48
+b(This)35 b(to)s(ol,)e(called)i Ft(lfiz)p Fu(,)g(w)m(as)88
+462 y(\014rst)i(dev)m(oted)h(for)e(\014les)h(that)g(will)g(b)s(e)g
+(explored)h(b)m(y)f(the)g(graphic)g(utilit)m(y)g Ft(diaprog)p
+Fu(.)58 b(In)37 b(fact,)g(it)g(is)88 583 y(also)c(used)h(for)f(\014les)
+h(used)h(during)e(a)g(sim)m(ulation)i(\(initial)e(and)g(coupling)h
+(\014les\))g(to)f(reduce)i(the)e(data)88 703 y(storage.)59
+b(Some)38 b(information)g(of)f(ho)m(w)h(the)h(compression)g(w)m(orks)h
+(is)e(giv)m(en)h(here,)h(its)e(execution)i(is)88 823
+y(particularly)33 b(easy)-8 b(.)88 1112 y Fs(2.1)135
+b Fr(lfiz)43 b Fs(to)t(ol)88 1297 y Fu(The)28 b Ft(lfiz)h
+Fu(to)s(ol)e(w)m(orks)i(on)e(the)h(binary)g(part)g(\(LFI)f(\014le\))h
+(of)f(a)h(FM)f(\014le,)j(sync)m(hronous)f(or)f(diac)m(hronic.)88
+1417 y(It)33 b(is)i(a)e(lossy)i(compression)g(to)s(ol.)47
+b(The)34 b(compressed)i(articles)f(are)f(exclusiv)m(ely)j(the)d
+(2-dimensional)88 1538 y(or)i(3-dimensional)h Ft(REAL)g
+Fu(\014elds.)56 b(When)37 b(dealing)g(with)g(3D)f(\014elds)h(the)g(to)s
+(ol)f(w)m(orks)i(with)f(eac)m(h)g(2D)88 1658 y(plane)44
+b(on)g(ev)m(ery)j(v)m(ertical)e(lev)m(el.)80 b(The)45
+b(initial)g(v)-5 b(alues)45 b(stored)g(with)g(64-bit)e
+Ft(REAL)i Fu(precision)h(are)88 1778 y(\014rst)28 b(con)m(v)m(erted)i
+(in)m(to)f(32-bit)e Ft(REAL)i Fu(precision)g(and)g(then)f(compressed)j
+(b)m(y)e(mapping)f(the)h(32-bit)e(real)88 1899 y(v)-5
+b(alues)28 b(up)s(on)f(16-bit)g(in)m(teger)h(v)-5 b(alues)29
+b(\(with)f(a)f(p)s(ossible)i(isolation)e(of)g(extrema)i(v)-5
+b(alues\).)42 b(The)29 b(b)s(etter)88 2019 y(compression)40
+b(is)g(ac)m(hiev)m(ed)h(for)d(\014elds)i(with)g(small)f(v)-5
+b(alue)40 b(range.)62 b(F)-8 b(or)38 b(\014elds)i(with)f(missing)i(v)-5
+b(alue)88 2140 y(\(e.g.)55 b(2-dimensional)37 b(\014elds)h(with)f
+(land-sea)g(mask\),)i(the)e(extrem)m(um)h(v)-5 b(alue)37
+b(is)g(excluded)i(and)e(the)88 2260 y(compression)d(is)f(done)g(on)f
+(signi\014can)m(t)i(v)-5 b(alues)33 b(of)f(the)h(\014eld.)44
+b(The)33 b(minim)m(um)h(compression)h(ratio)d(is)88 2380
+y(4)g(for)g(eac)m(h)h(2D)f(or)g(3D)g Ft(REAL)i Fu(compressed)h
+(\014eld.)88 2669 y Fs(2.2)135 b Fr(unlfiz)42 b Fs(to)t(ol)88
+2854 y Fu(The)30 b Ft(unlfiz)h Fu(to)s(ol)d(will)i(restore)g(the)g
+(64-bit)e Ft(REAL)i Fu(v)-5 b(alue)30 b(size)h(to)d(all)i(the)f
+(compressed)j(LFI)d(articles.)88 2974 y(Ho)m(w)m(ev)m(er,)e(eac)m(h)d
+(previously)i(compressed)f(article)f(will)g(gain)f(no)h(more)f(than)h
+(a)f(32-bit)f Ft(REAL)j Fu(precision)88 3095 y(b)s(ecause)33
+b(of)g(the)g(lossy)g(tec)m(hnique)i(in)m(v)m(olv)m(ed)g(ab)s(o)m(v)m
+(e.)88 3384 y Fs(2.3)135 b(Usage)88 3568 y Fu(The)35
+b(binary)h(part)e(of)h(the)g(FM)g(\014le)g(is)g(required)i(in)e(the)g
+(curren)m(t)h(directory)-8 b(.)51 b(T)-8 b(o)35 b(compress)h(the)f
+(\014le)88 3689 y Ft(myfile.lfi)p Fu(,)g(y)m(ou)e(can)g(t)m(yp)s(e:)88
+3917 y Ft(lfiz)52 b(myfile.lfi)88 4145 y Fu(This)33 b(will)h(pro)s
+(duce)f(the)g(compressed)i(\014le)e Ft(myfile.Z.lfi)88
+4386 y Fu(In)f(the)h(same)h(w)m(a)m(y)-8 b(,)34 b(to)e(uncompress)j
+(the)e(\014le)g Ft(myfile.Z.lfi)p Fu(,)j(y)m(ou)d(can)g(t)m(yp)s(e:)88
+4589 y Ft(unlfiz)52 b(myfile.Z.lfi)88 4793 y Fu(The)31
+b(output)f(\014le)h Ft(myfile.lfi)i Fu(is)d(a)g(v)-5
+b(alid)31 b(LFI)f(\014le)g(but)h(the)f(LFI)g(articles)h(previously)i
+(compressed)88 4913 y(are)f(64-bit)g Ft(REAL)i Fu(with)f(no)f(more)h
+(than)g(32-bit)f Ft(REAL)h Fu(precision.)1953 5941 y(5)p
+eop end
+%%Page: 6 6
+TeXDict begin 6 5 bop 88 123 a Fw(3)161 b(Con)l(v)l(ersion)68
+b(of)k(FM)g(sync)l(hronous)d(\014le)i(to)g(diac)l(hronic)330
+305 y(format)88 524 y Fu(Short)35 b(description)j(is)e(giv)m(en)h
+(here,)h(readers)f(m)m(ust)f(refer)h(to)e(the)h(original)g(do)s(cumen)m
+(tation)h(on)f(the)88 645 y(Meso-NH)i(w)m(eb)g(site:)55
+b(\\)p Fq(traitement)42 b(graphique)g(des)h(fichiers)f(synchr)n(ones)h
+(pr)n(oduits)88 765 y(p)-7 b(ar)37 b(le)h(mod)639 757
+y(\022)639 765 y(ele)f(mesonh)p Fu(,)c(J.)g(Duron".)88
+1052 y Fs(3.1)135 b(Sync)l(hronous)44 b(and)h(diac)l(hronic)g(formats)
+88 1237 y Fu(The)25 b(Meso-NH)f(graphic)h(utilit)m(y)g(\()p
+Ft(diaprog)p Fu(\))h(w)m(orks)f(on)f(FM)g(\014les)h(whic)m(h)h(are)e
+(on)g(diac)m(hronic)h(format.)88 1357 y(A)32 b(diac)m(hronic)i(FM)f
+(\014le)g(is)g(either)233 1549 y Fp(\017)48 b Fu(a)34
+b(\014le)h(pro)s(duced)g(during)f(the)h(sim)m(ulation)g(whic)m(h)g(con)
+m(tain)g(time)g(series)g(of)f(self-do)s(cumen)m(ted)331
+1669 y(informations)c(\(e.g.)43 b(\014le)30 b(with)g(name)g(CEXP)-8
+b(.1.CSEG.000\).)43 b(An)30 b(information)f(is)h(one)g(of)f(the)331
+1790 y(follo)m(wing:)497 1950 y(-)34 b(a)g(3-dimensional,)i
+(2-dimensional,)g(1-dimensional)f(or)f(0-dimensional)h(\014eld)h(\(ev)m
+(en)m(tu-)331 2070 y(ally)d(time-a)m(v)m(eraged,)h(or)f(compressed)i
+(in)d(one)h(direction\):)45 b(t)m(yp)s(e)33 b Fq(car)-7
+b(t)p Fu(,)497 2230 y(-)33 b(a)f(set)h(of)f(v)m(ertical)i(pro\014les)g
+(at)e(p)s(oin)m(ts)h(c)m(hec)m(king)i(some)e(criteria:)44
+b(t)m(yp)s(e)34 b Fq(mask)p Fu(,)497 2390 y(-)f(sp)s(ectral)g(co)s
+(e\016cien)m(ts)i(obtained)e(b)m(y)g(FFT)f(along)h(the)g(X)f(or)g(Y)h
+(direction:)44 b(t)m(yp)s(e)34 b Fq(spxy)p Fu(,)497 2550
+y(-)39 b(pseudo-observ)-5 b(ations)40 b(\(ground)f(station:)57
+b(t)m(yp)s(e)39 b Fq(ssol)p Fu(;)j(dropsonde:)57 b(t)m(yp)s(e)40
+b Fq(drst)p Fu(;)i(ra-)331 2670 y(diosonde:)j(t)m(yp)s(e)33
+b Fq(rspl)p Fu(;)f(airb)s(orne)h(radar:)43 b(t)m(yp)s(e)33
+b Fq(rapl)p Fu(\).)331 2791 y(A)j(diac)m(hronic)h(\014le)g(can)f(con)m
+(tains)h(informations)f(of)g(one)g(or)f(sev)m(eral)j(previous)f(t)m(yp)
+s(es)g(stored)331 2911 y(at)53 b(di\013eren)m(t)h(time)g(frequency)-8
+b(.)107 b(F)-8 b(or)52 b(a)h(whole)h(description)g(ab)s(out)f(the)g
+(diac)m(hronic)h(\014le)331 3031 y(t)m(yp)s(e,)45 b(reader)e(m)m(ust)f
+(refer)g(to)g(the)g(original)f(do)s(cumen)m(tation)i(on)f(the)g
+(Meso-NH)g(w)m(eb)h(site:)331 3152 y(\\)p Fq(cr)499 3144
+y(\023)499 3152 y(ea)-7 b(tion)38 b(et)f(exploit)-7 b(a)g(tion)39
+b(de)e(fichiers)h(dia)n(chr)n(oniques)p Fu(,)32 b(J.)h(Duron".)88
+3344 y(or)233 3535 y Fp(\017)48 b Fu(a)30 b(`pseudo'-diac)m(hronic)j
+(\014le)d(resulting)h(of)f(the)h(con)m(v)m(ersion)h(of)e(a)f(sync)m
+(hronous)k(\014le)e(\(e.g.)42 b(with)331 3656 y(name)24
+b(CEXP)-8 b(.1.CSEG.00n)25 b(where)f(n)p Fo(>)p Fu(0\).)40
+b(Recall)23 b(that)g(suc)m(h)h(a)f(\014le)h(con)m(tains)g(all)f(the)g
+(pronos-)331 3776 y(tic)35 b(\014elds)g(of)e(the)h(mo)s(del)g(at)g(one)
+g(instan)m(t)g(\(initial)g(or)g(during)g(the)g(sim)m(ulation\).)49
+b(When)34 b(con-)331 3897 y(v)m(erted)j(it)d(is)i(a)e('pseudo'-diac)m
+(hronic)j(\014le,)f(b)s(ecause)g(it)f(con)m(tains)h(only)f(one)g
+(instan)m(t)h(and)f(one)331 4017 y(t)m(yp)s(e)28 b(of)f(diac)m(hronic)h
+(information)f(\()p Fq(car)-7 b(t)p Fu(\).)42 b(The)28
+b(next)g(subsection)h(presen)m(ts)g(the)f(con)m(v)m(ersion)331
+4137 y(to)s(ol)f(\(named)h Ft(conv2dia)p Fu(\))h(to)e(apply)h(to)f
+(sync)m(hronous)i(\014les,)h(necessary)f(step)f(to)f(use)h
+Ft(diaprog)331 4258 y Fu(graphic)33 b(to)s(ol.)88 4545
+y Fs(3.2)135 b Fr(conv2dia)41 b Fs(to)t(ol)88 4729 y
+Fu(The)d(con)m(v)m(ersion)j(to)s(ol)c(w)m(orks)i(on)f(\014les)h(pro)s
+(duced)g(b)m(y)f(the)h(initialisation)f(programs)g(\()p
+Fq(prep)p 3622 4729 34 4 v 39 w(pgd,)88 4850 y(prep)p
+323 4850 V 38 w(ideal)p 621 4850 V 40 w(case,)32 b(prep)p
+1175 4850 V 39 w(real)p 1442 4850 V 39 w(case)p Fu(\),)c(the)h(mo)s
+(del)f(sim)m(ulation,)i(or)d(the)i(p)s(ost-pro)s(cessing)g(pro-)88
+4970 y(gram)37 b(\()p Fq(dia)n(g)p Fu(\).)59 b(It)37
+b(allo)m(ws)i(to)e(con)m(v)m(ert)j(one)e(sync)m(hronous)i(\014le)e(on)m
+(to)f(one)h(diac)m(hronic)h(\014le,)h(as)e(w)m(ell)88
+5091 y(as)f(merge)g(sev)m(eral)i(sync)m(hronous)g(\014les)f(with)g(c)m
+(hronological)f(times)h(\(outputs)f(of)g(one)g(run,)h(or)f(\014les)88
+5211 y(initialised)d(from)e(large-scale)h(mo)s(del\))g(on)m(to)f(one)h
+(diac)m(hronic)h(\014le.)234 5331 y(With)39 b Ft(conv2dia.elim)j
+Fu(to)s(ol,)e(y)m(ou)f(can)g(c)m(ho)s(ose)h(not)e(to)h(con)m(v)m(ert)h
+(all)f(the)g(\014elds)h(of)e(the)h(input)88 5452 y(\014le\(s\).)59
+b(The)38 b(pronostic)g(\014elds)h(at)e Fo(t)26 b Fp(\000)g
+Fo(dt)37 b Fu(instan)m(t,)j(or)d(at)g Fo(t)h Fu(instan)m(t,)h(or)f(an)m
+(y)g(other)f(\014elds)i(can)f(b)s(e)88 5572 y(eliminated.)80
+b(With)45 b Ft(conv2dia.select)j Fu(to)s(ol,)f(y)m(ou)e(ha)m(v)m(e)h
+(to)e(indicate)i(the)f(\014elds)g(to)g(select)h(for)88
+5692 y(con)m(v)m(ersion.)f(This)34 b(is)f(done)g(to)f(reduce)i(the)f
+(size)h(of)e(the)h(output)g(\014le.)1953 5941 y(6)p eop
+end
+%%Page: 7 7
+TeXDict begin 7 6 bop 234 123 a Fu(The)38 b(output)g(\014le)g(con)m
+(tains)g(informations)f(whose)i(t)m(yp)s(e)f(is)g Fq(car)-7
+b(t)37 b Fu(stored)h(in)g(arra)m(ys)g(with)g(size)88
+243 y(of)32 b Ft(\(IIU*IJU*IKU\),)55 b(\(IIU*IJU\),)f(\(IIU*IKU\),)35
+b Fu(or)d(1.)88 532 y Fs(3.3)135 b(Example)88 717 y Fu(Only)27
+b(the)g(binary)g(\()p Fq(LFI)p Fu(\))g(part)g(of)f(the)h(input)h(FM)e
+(\014les)i(is)f(required)i(in)e(the)g(curren)m(t)h(directory)f(\(split)
+88 837 y(the)33 b(FM)f(\014le)h(with)g(the)g Ft(fm2deslfi)i
+Fu(script)f(if)e(not\).)234 957 y(All)e(c)m(haracters)h(t)m(yp)s(ed)g
+(on)e(k)m(eyb)s(oard)i(are)f(sa)m(v)m(ed)i(in)e Ft(dirconv.elim)j
+Fu(or)c Ft(dirconv.select)k Fu(\014le,)88 1078 y(it)f(can)h(b)s(e)g
+(app)s(ended)g(and)g(used)h(as)f(input)g(\(after)f(b)s(eing)h
+(renamed\))g(for)f(the)h(next)h(call)f(of)f(the)h(to)s(ol)88
+1198 y(\(e.g.)43 b Ft(conv2dia.elim)55 b(<)c(dirconv.elim.ex)p
+Fu(\).)234 1319 y(Belo)m(w)33 b(is)h(the)f(example)h(of)e(questions)i
+(when)g Ft(conv2dia.elim)i Fu(is)d(in)m(v)m(ok)m(ed.)284
+1651 y Fn(ENTER)46 b(NUMBER)g(OF)h(INPUT)g(FM)g(FILES)284
+1764 y Fm(2)284 1877 y Fn(ENTER)f(FM)h(FILE)g(NAME)284
+1990 y Fm(CEXP.1.CSEG.001)284 2103 y Fn(ENTER)f(FM)h(FILE)g(NAME)284
+2216 y Fm(CEXP.1.CSEG.002)284 2329 y Fn(ENTER)f(DIACHRONIC)f(FILE)i
+(NAME)284 2442 y Fm(CEXP.1.CSEG.1-2.dia)284 2554 y Fn(DELETION)e(OF)i
+(PARAMETERS)e(AT)j(TIME)e(t-dt)h(?)95 b(\(enter)46 b(1\))284
+2667 y(DELETION)f(OF)i(PARAMETERS)e(AT)j(TIME)e(t)i(?)95
+b(\(enter)46 b(2\))284 2780 y(NO)h(DELETION)e(?)j(\(enter)e(0\))284
+2893 y Fm(2)284 3006 y Fn(Do)h(you)g(want)f(to)i(suppress)d(others)h
+(parameters)f(?)95 b(\(y/n\))284 3119 y Fm(y)284 3232
+y Fn(Enter)46 b(their)g(names)h(in)g(UPPERCASE)e(\(1/1)i(line\))284
+3345 y(End)g(by)g(END)284 3458 y Fm(DTHCONV)284 3571
+y(DR)-9 b(V)n(CONV)284 3684 y(END)1953 5941 y Fu(7)p
+eop end
+%%Page: 8 8
+TeXDict begin 8 7 bop 88 123 a Fw(4)161 b(Con)l(v)l(ersion)50
+b(to)j(NetCDF)g(\014les)88 371 y Fs(4.1)135 b Fr(lfi2cdf)41
+b Fs(to)t(ol)88 556 y Fu(The)j Ft(lfi2cdf)h Fu(to)s(ol)e(con)m(v)m
+(erts)i(the)f(binary)g(part)g(\(or)f(LFI)g(\014le\))h(of)f(a)g(FM)h
+(\014le)g(\(sync)m(hronous)h(or)88 676 y(diac)m(hronic\))g(in)m(to)g(a)
+f(NetCDF)g(\014le.)79 b(All)45 b(the)f(\014elds)i(\(or)e(more)h
+(precisely)h(all)e(the)h(LFI)f(articles\))88 796 y(con)m(tained)c(in)g
+(the)h(input)f(LFI)f(\014le)i(are)e(copied)i(to)e(the)i(NetCDF)e
+(output)h(\014le)h(with)f(their)g(v)-5 b(alues)88 917
+y(unc)m(hanged.)44 b(As)31 b(a)f(LFI)g(article)h(do)s(es)g(not)g(hold)f
+(an)m(y)i(information)e(on)g(the)h(v)-5 b(ariable,)32
+b(the)f(to)s(ol)e(tries)88 1037 y(to)j(describ)s(e)i(the)f(corresp)s
+(onding)g(NetCDF)g(v)-5 b(ariable)33 b(b)m(y)g(using)h(:)233
+1233 y Fp(\017)48 b Fu(3)40 b(LFI)f(articles:)59 b Ft(IMAX,)52
+b(JMAX,)41 b Fu(and)f Ft(KMAX)g Fu(if)g(they)g(are)g(a)m(v)-5
+b(ailable)40 b(in)g(the)g(LFI)f(input)h(\014le.)331 1353
+y(These)g(articles)f(ma)m(y)f(pro)m(vide)h(the)g(NetCDF)e(dimensions)j
+Ft(DIMX,)53 b(DIMY,)39 b Fu(and)f Ft(DIMZ)h Fu(of)e(an)331
+1474 y(arra)m(y)f(v)-5 b(ariable.)54 b(If)35 b(these)i(v)-5
+b(ariables)37 b(are)f(not)f(a)m(v)-5 b(ailable)37 b(in)f(the)g(input)g
+(\014le,)h(the)g(to)s(ol)e(treats)331 1594 y(eac)m(h)f(arra)m(y)f(v)-5
+b(ariable)32 b(as)h(a)g(1D)e(arra)m(y)-8 b(.)233 1789
+y Fp(\017)48 b Fu(a)53 b(small)h(database)f(implemen)m(ted)j(as)d(a)g
+(structure)h(arra)m(y)f(in)g(the)h Ft(lfi2cdf)g Fu(source)g(\014le)331
+1910 y Ft(fieldtype.f90)p Fu(.)46 b(This)28 b(arra)m(y)g(holds)g(the)g
+(t)m(yp)s(e)g(\()p Ft(REAL,)52 b(INTEGER,)i(LOGICAL)p
+Fu(.)16 b(.)g(.)g(\))44 b(of)27 b(ev)m(ery)331 2030 y(common)39
+b(LFI)f(article.)60 b(When)39 b(an)f(article)h(is)f(not)g(presen)m(t)i
+(in)e(this)h(database,)g(its)g(name)g(is)331 2150 y(displa)m(y)m(ed)f
+(on)c Ft(stdout)i Fu(b)m(y)g(the)f(running)g(to)s(ol,)g(and)f(the)i
+(corresp)s(onding)f(v)-5 b(alues)36 b(are)e(alw)m(a)m(ys)331
+2271 y(considered)i(as)f Ft(REAL)g Fu(v)-5 b(alues.)49
+b(A)34 b(new)h(LFI)e(article)i(t)m(yp)s(e)g(description)h(can)e(b)s(e)g
+(easily)h(added)331 2391 y(in)e(the)g Ft(fieldtype.f90)j
+Fu(source)e(\014le)f(and)g(the)g(to)s(ol)e(m)m(ust)j(b)s(e)f(then)g
+(recompiled.)88 2647 y Fv(4.1.1)112 b(Usage)88 2831 y
+Fu(The)38 b(binary)f(part)g(of)g(the)g(FM)g(\014le)h(is)f(required)i
+(in)e(the)h(curren)m(t)g(directory)-8 b(.)58 b(The)38
+b(follo)m(wing)f(com-)88 2952 y(mands)c(con)m(v)m(ert)h(a)e(\014le)i
+Ft(myfile.lfi)h Fu(from)d(LFI)g(to)h(NetCDF:)88 3148
+y Ft(lfi2cdf)53 b(myfile.lfi)88 3343 y Fu(or)88 3522
+y Ft(lfi2cdf)g(myfile)88 3701 y Fu(The)27 b(output)f(NetCDF)g(\014le)h
+(is)g(named:)41 b Ft(myfile.cdf)p Fu(.)j(It)26 b(can)h(easily)g(b)s(e)g
+(manipulated)g(b)m(y)g(NetCDF)88 3822 y(to)s(ols)292
+3785 y Fl(1)363 3822 y Fu(lik)m(e)34 b Ft(ncdump)p Fu(,)g
+Ft(ncview)p Fu(,)h(or)d Ft(NCO)h Fu(op)s(erators.)88
+4062 y(In)44 b(the)h(same)g(w)m(a)m(y)-8 b(,)48 b(y)m(ou)d(will)g(con)m
+(v)m(ert)h(a)e(NetCDF)g(\014le)h Ft(myfile.cdf)h Fu(bac)m(k)g(to)e(LFI)
+f(format)h(b)m(y)88 4183 y(t)m(yping:)88 4378 y Ft(cdf2lfi)53
+b(myfile.cdf)88 4574 y Fu(or)88 4753 y Ft(cdf2lfi)g(myfile)88
+4932 y Fu(The)33 b(output)g(LFI)f(\014le)h(is)g(then)h(named:)44
+b Ft(myfile.lfi)88 5217 y Fs(4.2)135 b Fr(extractdia)40
+b Fs(to)t(ol)88 5401 y Fu(The)28 b Ft(extractdia)j Fu(to)s(ol)c(con)m
+(v)m(erts)i(a)f(diac)m(hronic)h(FM)e(\014le)i(in)m(to)f(a)f(NetCDF)h
+(\014le)g(after)g(an)f(extraction)88 5522 y(of)32 b(a)g(list)h(of)f
+(\014elds)i(and)f(an)f(optional)h(extraction)g(of)f(a)g(sub-domain.)44
+b(See)34 b(the)f(section)h(5.1.)p 88 5601 1512 4 v 200
+5662 a Fk(1)237 5692 y Fj(see)18 b(freely)g(a)n(v)-5
+b(ailable)17 b(NetCDF)j(soft)n(w)n(are)c(at)i(h)n
+(ttp://www.unidata.ucar.edu/pac)n(k)-5 b(ages/netcdf/soft)n(w)n(are.h)n
+(tml)1953 5941 y Fu(8)p eop end
+%%Page: 9 9
+TeXDict begin 9 8 bop 88 123 a Fw(5)161 b(Dealing)52
+b(with)h(diac)l(hronic)e(\014les)88 342 y Fu(The)31 b(Meso-NH)h
+(program)e(of)g(p)s(ost-pro)s(cessing)h(\()p Fq(dia)n(g)p
+Fu(\))g(treats)g(sync)m(hronous)i(\014les)f(from)e(initializa-)88
+462 y(tion)35 b(or)h(sim)m(ulation.)54 b(F)-8 b(or)35
+b(a)g(giv)m(en)i(need,)h(one)e(w)m(an)m(ts)h(to)f(w)m(ork)g(on)g
+(\014elds)h(stored)f(in)g(a)g(diac)m(hronic)88 583 y(\014le)f(b)s
+(efore)h(exploration)g(with)g Ft(diaprog)h Fu(or)e(with)g(another)h
+(graphical)f(to)s(ol)g(to)g(p)s(ossibly)h(compare)88
+703 y(with)d(observ)-5 b(ations.)233 931 y Fp(\017)48
+b Fu(The)41 b Ft(extractdia)g Fu(to)s(ol)e(allo)m(ws)h(to)f(extract)g
+(\014elds)i(from)e(a)g(diac)m(hronic)h(\014le,)i(on)d(the)g(whole)331
+1052 y(domain)e(or)f(on)h(a)f(part)g(of)g(it,)i(to)e(in)m(terp)s(ole)i
+(them)f(\(horizon)m(tal)g(grid)f(and/or)g(v)m(ertical)i(grid\))331
+1172 y(and)30 b(to)f(write)h(them)g(in)g(some)g(other)g(giv)m(en)h
+(formats)e(\(section)h(5.1\).)42 b(This)31 b(program)e(is)h(based)331
+1292 y(on)e(a)g(routine)g(of)f(reading)h(and)g(a)g(routine)g(of)g
+(writing)g(of)f(diac)m(hronic)i(v)-5 b(ariables:)42 b(they)29
+b(are)f(the)331 1413 y(essen)m(tial)34 b(source)e(lines)g(to)f(deal)g
+(with)h(a)f(diac)m(hronic)h(\014le.)44 b(These)33 b(2)e(routines)h(can)
+f(b)s(e)g(used)i(in)331 1533 y(the)g(user)g(o)m(wn)g(program)f(to)g
+(matc)m(h)h(his)h(p)s(ersonal)e(needs.)45 b(An)33 b(example)h(of)e(suc)
+m(h)h(a)f(program)331 1654 y Ft(exrwdia.f90)k Fu(and)d(ho)m(w)g(to)f
+(compile)i(it)e(is)h(giv)m(en)h(in)f(section)h(5.2.)234
+1882 y(Some)g(other)h(to)s(ols)e(based)i(on)f(the)h(2)e(routines)i(of)f
+(reading)g(and)g(writing)h(are)f(also)g(a)m(v)-5 b(ailable)34
+b(to)88 2002 y(allo)m(w)f(easier)g(comparisons)h(with)f(observ)-5
+b(ation)33 b(data)f(\(sections)j(5.3)d(and)g(5.4\):)233
+2206 y Fp(\017)48 b Ft(mesonh2obs)37 b Fu(to)d(get)h(MesoNH)g(\014eld)g
+(v)-5 b(alues)36 b(at)e(giv)m(en)h(observ)-5 b(ation)35
+b(p)s(oin)m(ts)g(\(the)g(format)f(of)331 2326 y(output)f(\014le)g(is)g
+(ASCI)s(I\),)233 2529 y Fp(\017)48 b Ft(obs2mesonh)35
+b Fu(to)c(put)h(observ)-5 b(ation)32 b(v)-5 b(alues)33
+b(on)f(a)f(giv)m(en)i(MesoNH)g(grid)e(\(the)h(output)g(\014le)h(has)331
+2650 y(diac)m(hronic)h(FM)f(format\),)f(observ)-5 b(ations)33
+b(can)g(then)g(b)s(e)g(plotted)g(with)g Ft(diaprog)i
+Fu(to)s(ol.)233 2853 y Fp(\017)48 b Ft(compute)p 694
+2853 31 4 v 39 w(r00)p 886 2853 V 38 w(pc)27 b Fu(to)f(catenate)h(ev)m
+(olution)h(of)e(Lagrangian)g(tracers)h(bac)m(k)h(to)e(the)h(mo)s(del)g
+(start)331 2974 y(\(as)32 b(done)f(in)g Fq(dia)n(g)g
+Fu(program,)g(see)h(do)s(cumen)m(tation)g(\\Lagrangian)e(tra)5
+b(jectory)32 b(and)f(air-mass)331 3094 y(trac)m(king)j(analyses)h(with)
+e(MesoNH)h(b)m(y)g(means)g(of)f(Eulerian)h(passiv)m(e)h(tracers",)e
+(Gheusi)h(and)331 3214 y(Stein,)g(2005\).)234 3418 y(The)f(\014gure)g
+(3)g(resumes)h(the)f(input)g(and)g(output)g(of)f(these)i(to)s(ols.)234
+3659 y(Remark)p 234 3672 335 4 v 1 w(:)40 b(for)26 b(all)g(the)h(follo)
+m(wing)g(to)s(ols,)g(the)g(input)g(diac)m(hronic)h(\014les)f(can)g(b)s
+(e)g(lo)s(cated)f(in)h(another)88 3779 y(directory)g(than)f(the)g(one)g
+(in)h(whic)m(h)g(the)g(to)s(ol)e(is)h(in)m(v)m(ok)m(ed)j(\(as)d(for)f
+Ft(diaprog)p Fu(\).)44 b(In)26 b(this)h(case,)h(initialise)88
+3899 y(the)33 b(follo)m(wing)f(shell)i(v)-5 b(ariable)88
+4103 y Ft(export)52 b(DIRLFI=directory_files_)q(diac)q(hro)234
+4306 y Fu(Shell)33 b(links)g(will)f(b)s(e)g(automatically)h(p)s
+(erformed)f(during)g(the)g(execution)i(and)e(will)g(b)s(e)g(remo)m(v)m
+(ed)88 4426 y(b)m(y)h(the)g(mesonh-shell-to)s(ol)g Ft(rmlink)i
+Fu(at)d(the)h(execution)h(end.)88 4715 y Fs(5.1)135 b(Extracte)38
+b(\014elds,)i(domain,)f(c)l(hange)f(format)g(with)g Fr(extractdia)32
+b Fs(to)t(ol)88 4900 y Fu(The)f(input)g(\014le)f(is)h(a)f(FM)h(diac)m
+(hronic)g(\014le,)g(either)g(a)f(`true')h(diac)m(hronic)h(one)e(\(its)h
+(name)g(is)g(ended)g(b)m(y)88 5020 y Fv(.000)36 b Fu(and)h(it)g(con)m
+(tains)h(time)f(series)i(of)d(informations)h(obtained)g(during)g(the)g
+(run)g(of)f(the)i(mo)s(del\),)88 5141 y(or)e(a)h(`pseudo'-diac)m
+(hronic)i(one)f(\(it)f(is)g(the)h(result)g(of)e(the)i(con)m(v)m(ersion)
+h(of)e(a)g(sync)m(hronous)i(\014le,)g(see)88 5261 y(section)33
+b(3.1\),)f(compressed)j(\(with)f Ft(lfiz)p Fu(\))f(or)f(not.)234
+5382 y(The)h(format)f(of)h(the)g(output)f(\014le)h(is)h(c)m(hosen)g(b)m
+(y)f(the)g(user)h(among)e(one)h(of)f(the)h(follo)m(wing:)233
+5585 y Fp(\017)48 b Fu(a)33 b(FM)f Fq(dia)n(c)p Fu(hronic)h(\014le,)
+1953 5941 y(9)p eop end
+%%Page: 10 10
+TeXDict begin 10 9 bop 300 23 a
+ gsave currentpoint currentpoint translate 270 neg rotate neg exch
+neg exch translate
+ 300 23 a @beginspecial
+11 @llx 7 @lly 602 @urx 838 @ury 2834 @rwi @setspecial
+%%BeginDocument: outils_dia.eps
+%!PS-Adobe-3.0 EPSF-3.0
+%%BoundingBox: 11 7 602 838
+%%Title: outils_dia
+%%CreationDate: Thu Mar 3 16:51:45 2005
+%%Creator: Tgif-4.1.43-QPL written by William Chia-Wei Cheng (bill.cheng@acm.org)
+%%ProducedBy: (unknown)
+%%Pages: 1
+%%DocumentFonts: (atend)
+%%EndComments
+%%BeginProlog
+
+/tgifdict 53 dict def
+tgifdict begin
+
+/tgifarrowtipdict 8 dict def
+tgifarrowtipdict /mtrx matrix put
+
+/TGAT % tgifarrowtip
+ { tgifarrowtipdict begin
+ /dy exch def
+ /dx exch def
+ /h exch def
+ /w exch def
+ /y exch def
+ /x exch def
+ /savematrix mtrx currentmatrix def
+ x y translate
+ dy dx atan rotate
+ 0 0 moveto
+ w neg h lineto
+ w neg h neg lineto
+ savematrix setmatrix
+ end
+ } def
+
+/TGMAX
+ { exch dup 3 1 roll exch dup 3 1 roll gt { pop } { exch pop } ifelse
+ } def
+/TGMIN
+ { exch dup 3 1 roll exch dup 3 1 roll lt { pop } { exch pop } ifelse
+ } def
+/TGSW { stringwidth pop } def
+
+/bd { bind def } bind def
+
+/GS { gsave } bd
+/GR { grestore } bd
+/NP { newpath } bd
+/CP { closepath } bd
+/CHP { charpath } bd
+/CT { curveto } bd
+/L { lineto } bd
+/RL { rlineto } bd
+/M { moveto } bd
+/RM { rmoveto } bd
+/S { stroke } bd
+/F { fill } bd
+/TR { translate } bd
+/RO { rotate } bd
+/SC { scale } bd
+/MU { mul } bd
+/DI { div } bd
+/DU { dup } bd
+/NE { neg } bd
+/AD { add } bd
+/SU { sub } bd
+/PO { pop } bd
+/EX { exch } bd
+/CO { concat } bd
+/CL { clip } bd
+/EC { eoclip } bd
+/EF { eofill } bd
+/IM { image } bd
+/IMM { imagemask } bd
+/ARY { array } bd
+/SG { setgray } bd
+/RG { setrgbcolor } bd
+/SD { setdash } bd
+/W { setlinewidth } bd
+/SM { setmiterlimit } bd
+/SLC { setlinecap } bd
+/SLJ { setlinejoin } bd
+/SH { show } bd
+/FF { findfont } bd
+/MS { makefont setfont } bd
+/AR { arcto 4 {pop} repeat } bd
+/CURP { currentpoint } bd
+/FLAT { flattenpath strokepath clip newpath } bd
+/TGSM { tgiforigctm setmatrix } def
+/TGRM { savematrix setmatrix } def
+
+end
+
+%%EndProlog
+%%Page: 1 1
+
+%%PageBoundingBox: 11 7 602 838
+tgifdict begin
+/tgifsavedpage save def
+
+1 SM
+1 W
+
+0 SG
+
+90 RO
+72 0 MU 72 0 MU TR
+72 128 DI 100.000 MU 100 DI DU NE SC
+
+GS
+
+/tgiforigctm matrix currentmatrix def
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 224 392 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (readvar) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 472 392 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (writevar) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 680 392 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (writecdl) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 880 392 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (writellhv) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1120 392 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (write Fortran) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 224 168 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (diachronic file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 456 168 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (diachronic file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 664 168 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (netcdf file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 864 168 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (ASCII file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1136 168 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (ASCII file) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 16 132 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (ASCII file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 256 184 M
+ 176 0 atan DU cos 12.000 MU 256 exch SU
+ exch sin 12.000 MU 360 exch SU L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 256 360 12.000 5.000 0 176 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 256 360 12.000 5.000 0 176 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 520 184 M
+ 176 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 520 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 520 184 12.000 5.000 0 -176 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 520 184 12.000 5.000 0 -176 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 728 184 M
+ 176 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 728 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 728 184 12.000 5.000 0 -176 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 728 184 12.000 5.000 0 -176 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 928 184 M
+ 176 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 928 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 928 184 12.000 5.000 0 -176 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 928 184 12.000 5.000 0 -176 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 1200 184 M
+ 176 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 1200 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 1200 184 12.000 5.000 0 -176 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 1200 184 12.000 5.000 0 -176 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 256 456 M
+ 96 0 atan DU cos 12.000 MU 256 exch SU
+ exch sin 12.000 MU 552 exch SU L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 256 552 12.000 5.000 0 96 TGAT
+ 1 SG CP F
+ 0.000 0.000 1.000 RG
+ NP
+ 256 552 12.000 5.000 0 96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 520 456 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 520 552 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 520 456 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 0.000 0.000 1.000 RG
+ NP
+ 520 456 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 728 456 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 728 552 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 728 456 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 0.000 0.000 1.000 RG
+ NP
+ 728 456 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 936 456 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 936 552 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 936 456 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 0.000 0.000 1.000 RG
+ NP
+ 936 456 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 1200 456 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 1200 552 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 1200 456 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 0.000 0.000 1.000 RG
+ NP
+ 1200 456 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 256 552 M
+ 1336 552 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 352 584 M
+ GS
+ 0.000 0.000 1.000 RG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (extractdia) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 1.000 0.000 RG
+GS
+ NP
+ 256 632 M
+ 96 0 atan DU cos 12.000 MU 256 exch SU
+ exch sin 12.000 MU 728 exch SU L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 256 728 12.000 5.000 0 96 TGAT
+ 1 SG CP F
+ 0.000 1.000 0.000 RG
+ NP
+ 256 728 12.000 5.000 0 96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 1.000 0.000 RG
+GS
+ NP
+ 944 632 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 944 728 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 944 632 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 0.000 1.000 0.000 RG
+ NP
+ 944 632 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 1.000 0.000 RG
+GS
+ NP
+ 64 728 M
+ 944 728 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 352 760 M
+ GS
+ 0.000 1.000 0.000 RG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (mesonh2obs) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 240 880 M
+ 96 0 atan DU cos 12.000 MU 240 exch SU
+ exch sin 12.000 MU 976 exch SU L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 240 976 12.000 5.000 0 96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 240 976 12.000 5.000 0 96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 528 880 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 528 976 L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 528 880 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 528 880 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 784 880 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 784 976 L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 784 880 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 784 880 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 1040 880 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 1040 976 L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 1040 880 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 1040 880 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 1296 880 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 1296 976 L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 1296 880 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 1296 880 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 240 976 M
+ 1296 976 L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 336 1008 M
+ GS
+ 1.000 0.000 1.000 RG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (exrwdia ) SH
+ GR
+ 0 28 RM
+ GS
+ 1.000 0.000 1.000 RG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (\( compilation via) SH
+ GR
+ 0 26 RM
+ GS
+ 1.000 0.000 1.000 RG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ( make -f $MESONH/MAKE/tools/diachro/Makefile.exrwdia \) ) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 256 880 M
+ 96 0 atan DU cos 12.000 MU 256 exch SU
+ exch sin 12.000 MU 976 exch SU L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 256 976 12.000 5.000 0 96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 256 976 12.000 5.000 0 96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 1.000 RG
+GS
+ [8 8] 0 SD
+ NP
+ 272 880 M
+ 96 0 atan DU cos 12.000 MU 272 exch SU
+ exch sin 12.000 MU 976 exch SU L
+ TGSM
+ 3 W
+ S
+ [] 0 SD
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 272 976 12.000 5.000 0 96 TGAT
+ 1 SG CP F
+ 1.000 0.000 1.000 RG
+ NP
+ 272 976 12.000 5.000 0 96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+0.000 1.000 0.000 RG
+GS
+ NP
+ 64 200 M
+ 528 0 atan DU cos 12.000 MU 64 exch SU
+ exch sin 12.000 MU 728 exch SU L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 64 728 12.000 5.000 0 528 TGAT
+ 1 SG CP F
+ 0.000 1.000 0.000 RG
+ NP
+ 64 728 12.000 5.000 0 528 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+1.000 0.000 1.000 RG
+ GS
+ 1 W
+ 368 56 M
+ GS
+ 0 SG
+ /Helvetica FF [34 0 0 -34 0 0] MS
+ (Input/Output of extractdia, mesonh2obs, obs2mesonh, exrwdia programs) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 32 164 M
+ GS
+ 0 SG
+ /Helvetica FF [18 0 0 -18 0 0] MS
+ (format=lon,lat) SH
+ GR
+ 0 22 RM
+ GS
+ 0 SG
+ /Helvetica FF [18 0 0 -18 0 0] MS
+ ( lat,lon) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 856 184 M
+ GS
+ 0 SG
+ /Helvetica FF [18 0 0 -18 0 0] MS
+ (format=lon,lat,altitude,value) SH
+ GR
+ 0 22 RM
+ GS
+ 0 SG
+ /Helvetica FF [18 0 0 -18 0 0] MS
+ ( lat,lon,altitude,value) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1104 184 M
+ GS
+ 0 SG
+ /Helvetica FF [18 0 0 -18 0 0] MS
+ (format=user choice) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 208 424 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([head ]+ field) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 456 424 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([head ]+ field) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 688 424 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (head+ field) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 848 424 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (3 head lines + x lines data) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1144 424 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (x lines data) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 296 544 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([domain reduced]) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 532 544 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (if DIAC) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 732 544 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (if ZCDL/KCDL/PCDL) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 940 544 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (if LLHV/llhv/LLZV/LLPV) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1204 544 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (if FREE) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 920 768 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ vertical interpolation]) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 920 748 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ( horizontal interpolation) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 20 96 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (export DIROBS=dirname1) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 208 132 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (export DIRLFI=dirname2) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+NP 695 259 M 768 259 L 768 286 L 695 286 L CP 1 SG F
+0 SG
+ GS
+ 1 W
+ 696 280 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (tonetcdf) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 852 1004 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ horizontal interpolation \(hor_interp_4pts\)) SH
+ GR
+ 0 26 RM
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ( vertical interpolation \(zinter, pinter, zmoy\) ]) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 688 576 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ vertical interpolation on Z-levels or P-levels ]) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 688 596 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ horizontal interpolation on regular lat-lon grid if LALO]) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0.000 0.000 1.000 RG
+GS
+ NP
+ 1336 456 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 1336 552 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 1336 456 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 0.000 0.000 1.000 RG
+ NP
+ 1336 456 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1340 544 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (if GRIB) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1288 392 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (writegrib) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1288 168 M
+ GS
+ 0 SG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (GRIB file) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+0 SG
+GS
+ NP
+ 1336 184 M
+ 176 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 1336 360 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 1336 184 12.000 5.000 0 -176 TGAT
+ 1 SG CP F
+ 0 SG
+ NP
+ 1336 184 12.000 5.000 0 -176 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 1272 424 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ (field \(4 sections\)) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 688 616 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ computation of dd,ff]) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 688 636 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ Uzonal,Vmerid if LALO]) SH
+ GR
+ GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 0.000 RG
+GS
+ NP
+ 40 192 M
+ 648 0 atan DU cos 12.000 MU 40 exch SU
+ exch sin 12.000 MU 840 exch SU L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 40 840 12.000 5.000 0 648 TGAT
+ 1 SG CP F
+ 1.000 0.000 0.000 RG
+ NP
+ 40 840 12.000 5.000 0 648 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 0.000 RG
+GS
+ NP
+ 256 744 M
+ 96 0 atan DU cos 12.000 MU 256 exch SU
+ exch sin 12.000 MU 840 exch SU L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 256 840 12.000 5.000 0 96 TGAT
+ 1 SG CP F
+ 1.000 0.000 0.000 RG
+ NP
+ 256 840 12.000 5.000 0 96 TGAT
+ CP F
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 0.000 RG
+GS
+ NP
+ 40 840 M
+ 528 840 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+
+% POLY/OPEN-SPLINE
+1.000 0.000 0.000 RG
+GS
+ NP
+ 528 744 M
+ 96 0 atan DU cos 12.000 MU exch sin 12.000 MU RM
+ 528 840 L
+ TGSM
+ 3 W
+ S
+ 1 W
+GR
+GS
+ TGSM
+ NP
+ 528 744 12.000 5.000 0 -96 TGAT
+ 1 SG CP F
+ 1.000 0.000 0.000 RG
+ NP
+ 528 744 12.000 5.000 0 -96 TGAT
+ CP F
+GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 296 864 M
+ GS
+ 1.000 0.000 0.000 RG
+ /Helvetica FF [25 0 0 -25 0 0] MS
+ (obs2mesonh) SH
+ GR
+ GR
+
+% TEXT
+NP
+0 SG
+ GS
+ 1 W
+ 456 860 M
+ GS
+ 0 SG
+ /Helvetica FF [20 0 0 -20 0 0] MS
+ ([+ Uzonal,Vmerid ->UM,VM]) SH
+ GR
+ GR
+
+GR
+tgifsavedpage restore
+end
+showpage
+
+%%Trailer
+%MatchingCreationDate: Thu Mar 3 16:51:45 2005
+%%DocumentFonts: Helvetica
+%%EOF
+
+%%EndDocument
+ @endspecial 2663 23 a
+ currentpoint grestore moveto
+ 2663 23 a 1764 2545 a Fu(Figure)32
+b(3:)233 2830 y Fp(\017)48 b Fu(an)i(ASCI)s(I)h(\014le)f(with)g
+Fq(l)p Fu(atitude-)p Fq(l)p Fu(ongitude-)p Fq(h)p Fu(eigh)m(t-)p
+Fq(v)p Fu(alue)h(or)e(latitude-longitude-heigh)m(t-)331
+2950 y(v)-5 b(alue,)233 3154 y Fp(\017)48 b Fu(ASCI)s(I)34
+b(\014les)f(with)h Fq(free)e Fu(format)g(de\014ned)i(b)m(y)f(the)g
+(user)h(\(one)e(\014le)i(p)s(er)e(\014eld\),)233 3357
+y Fp(\017)48 b Fu(a)42 b Fq(cdl)g Fu(\014le)h(\(con)m(v)m(erted)h(to)e
+(NetCDF)g(format)f(at)h(the)g(end)h(of)f(the)g(program,)i(with)f
+Ft(ncgen)331 3477 y Fu(utilit)m(y)34 b(of)e(NetCDF)h(pac)m(k)-5
+b(age)33 b(inside)h(the)f(mesonh-shell-to)s(ol)g Ft(tonetcdf)p
+Fu(\),)233 3681 y Fp(\017)48 b Fu(a)33 b Fq(grib)f Fu(\014le)h(\(in)g
+(the)g(future\),)233 3884 y Fp(\017)48 b Fu(a)33 b Fq(Vis5D)f
+Fu(\014le)h(\(in)g(the)g(future\).)88 4088 y(The)40 b(main)g(program)f
+(is)h(an)g(in)m(teractiv)m(e)i(one:)57 b(the)40 b(name)h(of)e(input)h
+(diac)m(hronic)h(\014le,)h(the)e(output)88 4208 y(format,)46
+b(the)f(co)s(ordinates)f(of)g(the)h(part)f(of)f(the)i(domain,)i(the)e
+(name)f(of)g(\014elds)h(to)f(b)s(e)h(read)f(and)88 4328
+y(written)37 b(are)f(required.)56 b(All)36 b(that)g(is)h(t)m(yp)s(ed)g
+(on)f(k)m(eyb)s(oard)h(is)g(sa)m(v)m(ed)h(in)e Ft(dirextr.)p
+Fu(fm)m(t)j(\014le,)f(it)e(can)88 4449 y(b)s(e)c(app)s(ended)i(and)f
+(used)g(as)g(input)g(\(after)g(renaming)g(it\))f(for)g(the)h(next)h
+(call)f(of)f(the)h(to)s(ol)88 4569 y(\(e.g.)43 b Ft(mv)52
+b(dirextr.DIAC)i(dirDIAC1)g(;)d(extractdia)j(<)e(dirDIAC1)p
+Fu(\).)88 4810 y(The)33 b(adv)-5 b(an)m(tages)33 b(for)f(eac)m(h)i
+(output)e(format)h(are)f(the)h(follo)m(wing:)233 5038
+y Fp(\017)48 b Fu(the)33 b(wind)h(direction)f(\(dd\))g(and)g(wind)g(in)
+m(tensit)m(y)i(\(\013)7 b(\))32 b(could)i(b)s(e)e(ask)m(ed.)233
+5242 y Fp(\017)48 b Fu(\014elds)34 b(are)f(ev)m(en)m(tually)i(in)m
+(terp)s(olated)f(according)f(output)g(format,)f(\014rst)h(v)m
+(ertically)i(and)d(then)331 5362 y(horizon)m(tally)-8
+b(.)43 b(F)-8 b(or)28 b(v)m(ertical)h(in)m(terp)s(olation,)h(the)f
+(user)g(sp)s(eci\014es)i(the)d(t)m(yp)s(e)i(of)d(lev)m(els)k(\(Z)d(or)g
+(P\),)331 5482 y(the)34 b(n)m(um)m(b)s(er)h(of)e(lev)m(els)j(and)e
+(their)g(v)-5 b(alues)34 b(\(in)g(m)f(or)h(in)f(hP)m(a\).)47
+b(No)34 b(v)m(ertical)g(in)m(terp)s(olation)g(if)331
+5603 y(the)f(t)m(yp)s(e)h(of)e(lev)m(els)j(is)e(K)f(\(mo)s(del)h(lev)m
+(els\).)1929 5941 y(10)p eop end
+%%Page: 11 11
+TeXDict begin 11 10 bop 331 123 a Fu(F)-8 b(or)33 b(horizon)m(tal)h(in)
+m(terp)s(olation)f(on)h(regular)f(grid)g(in)h(longitude)g(and)f
+(latitude,)i(the)e(program)331 243 y(c)m(ho)s(oses)h(the)f(optim)m(um)h
+(v)-5 b(alues)33 b(computed)h(for)e(the)h(mo)s(del)g(grid.)331
+405 y(If)39 b(in)m(terp)s(olations)h(are)f(required,)j(the)d(wind)h
+(comp)s(onen)m(ts)g(are)f(transformed)h(in)f(zonal)g(and)331
+525 y(meridian)34 b(comp)s(onen)m(ts.)331 687 y(These)f(in)m(terp)s
+(olations)e(do)f(not)g(allo)m(w)h(in)m(terp)s(olation)g(in)g(a)f
+(required)i(cross-section,)g(the)f Fq(fic-)331 808 y(v)-9
+b(al)33 b Fu(\014le)h(obtained)f(during)g(a)f Ft(diaprog)i
+Fu(session)h(giv)m(es)f(this)f(in)m(terp)s(olation.)233
+1011 y Fp(\017)48 b Fu(for)36 b(the)h Fq(dia)n(c)p Fu(hronic)g(format,)
+g(the)g(output)g(\014le)g(will)g(b)s(e)g(reduced)h(in)f(size)h(since)g
+(it)e(con)m(tains)331 1131 y(only)31 b(some)g(\014elds)g(on)f(a)g(part)
+g(of)g(the)g(domain)h(without)f(an)m(y)h(in)m(terp)s(olations)g(.)43
+b(It)30 b(can)g(still)h(b)s(e)331 1252 y(plotted)i(with)h
+Ft(diaprog)p Fu(.)233 1455 y Fp(\017)48 b Fu(for)35 b(the)g
+Fq(ll*v)p Fu(/ll*v)h(format,)f(the)h(\014elds)g(can)f(b)s(e)h(in)m
+(terp)s(olated)f(on)m(to)g(a)g(regular)g(grid)g(in)h(lon-)331
+1576 y(gitude)41 b(and)e(latitude)h(\()p Fq(lalo)h Fu(option\))e(or)g
+(can)h(remained)h(on)e(the)h(conformal)g(mo)s(del)g(grid.)331
+1696 y(\()p Fq(llzv)p Fu(/llzv)46 b(option)f(for)f(in)m(terp)s(olation)
+i(on)e(constan)m(t)i(altitude)f(lev)m(els,)50 b Fq(llpv)p
+Fu(/llp)m(v)c(option)331 1816 y(for)35 b(in)m(terp)s(olation)h(on)f
+(constan)m(t)h(pression)h(lev)m(els)g Fq(llhv)p Fu(/lhzv)g(option)e(to)
+g(sta)m(y)h(on)f(MesoNH)331 1937 y(v)m(ertical)43 b(lev)m(els\).)72
+b(Three)42 b(header)g(lines)h(giv)m(e)f(zo)s(om,)h(unit,)h(v)-5
+b(ariable)42 b(name)g(and)f(temp)s(oral)331 2057 y(informations)33
+b(and)g(are)g(follo)m(w)m(ed)g(b)m(y)h(four)e(v)-5 b(alues)33
+b(on)g(eac)m(h)g(line.)233 2261 y Fp(\017)48 b Fu(for)28
+b(the)h Fq(cdl)g Fu(format,)g(the)g(\014elds)g(can)g(b)s(e)g(horizon)m
+(tally)g(in)m(terp)s(olated)g(on)m(to)g(a)f(regular)g(grid)h(in)331
+2381 y(longitude)k(and)e(latitude)i(\()p Fq(lalo)f Fu(option\),)g(and)f
+(ev)m(en)m(tually)k(v)m(ertically)e(on)f(some)g(prescrib)s(ed)331
+2501 y(lev)m(els)43 b(\()p Fq(zcdl)e Fu(option)f(for)g(in)m(terp)s
+(olation)h(on)g(constan)m(t)g(altitude)g(lev)m(els,)k
+Fq(pcdl)40 b Fu(option)h(for)331 2622 y(in)m(terp)s(olation)35
+b(on)f(constan)m(t)i(pression)g(lev)m(els,)h Fq(k)n(cdl)d
+Fu(option)h(to)f(sta)m(y)h(on)f(MesoNH)i(v)m(ertical)331
+2742 y(lev)m(els\).)51 b(The)35 b(CDL)f(format)f(is)i(transformed)g(to)
+f(binary)g(Netdcf)h(format)f(at)g(the)g(end)h(of)f(the)331
+2862 y(program)f(run)f(b)m(y)i(the)f(mesonh-shell-to)s(ol)g
+Ft(tonetcdf)p Fu(.)233 3066 y Fp(\017)48 b Fu(the)35
+b Fq(free)f Fu(format)g(allo)m(ws)i(to)e(get)g(the)h(in)m(terp)s
+(olated)h(v)-5 b(alues)35 b(\(v)m(ertical)h(or)e(horizon)m(tal)h(in)m
+(ter-)331 3186 y(p)s(olations\))26 b(without)h(an)m(y)g(geographical)f
+(lo)s(cations:)40 b(just)27 b(v)-5 b(alues)27 b(list)f(are)g(a)m(v)-5
+b(ailable)27 b(after)f(one)331 3307 y(header)34 b(line.)88
+3595 y Fs(5.2)135 b(P)l(ersonal)46 b(mo)t(di\014cations:)61
+b Fr(exrwdia)41 b Fs(program)88 3780 y Fu(The)22 b Ft(extractdia)j
+Fu(program)c(uses)i(2)f(routines)g(of)f(reading)h(\()p
+Ft(readvar.f90)p Fu(\))j(and)d(writing)g(\()p Ft(writevar.f90)p
+Fu(\))88 3901 y(of)38 b(MesoNH)j(v)-5 b(ariables)40 b(as)f(they)h(are)g
+(stored)f(in)h(diac)m(hronic)g(\014les)h(\(that)e(is)g(in)h
+(6-dimensional)g(ar-)88 4021 y(ra)m(ys\).)j(These)33
+b(2)d(routines)h(can)g(b)s(e)g(used)g(in)g(y)m(our)g(o)m(wn)h(program:)
+42 b(an)30 b(example)i(of)e(suc)m(h)i(a)e(program)88
+4141 y(is)37 b Ft(exrwdia.f90)p Fu(.)61 b(The)38 b(source)g(co)s(de)g
+(con)m(tains)g(extended)i(commen)m(ts,)g(and)d(there)h(are)g(some)g
+(ex-)88 4262 y(amples)33 b(of)f(computation)h(with)g(the)g(extracted)g
+(\014elds)h(\(mo)s(dule)f(and)f(direction)i(of)e(comp)s(onen)m(ts)i(of)
+88 4382 y(wind,)e(in)m(terp)s(olation)g(on)f(some)h(Z)f(lev)m(els,)j
+(maxim)m(um)f(of)e(a)g(3D)g(\014eld)h(along)f(the)g(v)m(ertical)i
+(direction,)88 4503 y(v)m(ertical)g(a)m(v)m(erage)h(b)s(et)m(w)m(een)h
+(t)m(w)m(o)e(Z)f(lev)m(els\).)234 4623 y(The)h(use)h(of)e(this)h(metho)
+s(d)g(need)g(to)f(b)s(e)h(familiar)f(with)h(the)g(Mesonh)h(sp)s
+(eci\014cities:)46 b(sev)m(en)35 b(grids)88 4743 y(\(Gal-Chen\))g(for)h
+(the)g(storage)g(of)f(the)h(v)-5 b(ariables,)38 b(the)e(U,V)g(wind)h
+(comp)s(onen)m(ts)g(are)f(referenced)i(in)88 4864 y(the)33
+b(Mesonh)g(grid)g(and)g(are)f(di\013eren)m(t)i(from)e(the)h(Uzonal)g
+(and)g(Vmeridian)g(comp)s(onen)m(ts.)88 5123 y Fv(5.2.1)112
+b(Routines)38 b(of)f(reading)i(and)f(writing)88 5308
+y Fu(A)43 b(diac)m(hronic)i(\014le)f(con)m(tain)f(time)h(series)h(of)e
+(informations)h(that)f(are)h(self-do)s(cumen)m(ted)h(\(section)88
+5429 y(3.1\).)53 b(The)36 b(self-do)s(cumen)m(tation)i(is)e(pro)m
+(vided)h(b)m(y)g(the)g(header)f(of)g(the)g(\014le,)h(whic)m(h)h(con)m
+(tains)f(a)e(list)88 5549 y(of)40 b(pre-de\014ned)i(records,)i(and)d
+(eac)m(h)g(\014eld)h(\(or)e(information\))h(is)g(stored)h(b)m(y)f(sev)m
+(eral)i(records,)h(the)1929 5941 y(11)p eop end
+%%Page: 12 12
+TeXDict begin 12 11 bop 88 123 a Fu(n)m(um)m(b)s(er)43
+b(of)f(them)h(v)-5 b(aries)43 b(from)f(8)g(to)f(11,)k(according)d(to)g
+(the)h(t)m(yp)s(e)g(of)e(the)i(information)f(\()p Fq(car)-7
+b(t,)88 243 y(mask,)37 b(spxy,)g(ssol,)g(drst,)h(rspl)31
+b Fu(or)i Fq(rapl)p Fu(\).)234 364 y(The)46 b(subroutine)g
+Ft(readvar.f90)j Fu(reads)c(the)h(required)h(\014eld.)82
+b(A)m(t)45 b(the)h(\014rst)f(call,)k(the)d(\014le)g(is)88
+484 y(op)s(ened,)e(its)e(header)g(is)g(read)f(\(the)h(dimensions)h(of)e
+(the)h(total)f(domain)g(\()p Fq(imax,)50 b(jmax,)g(kmax)p
+Fu(\),)88 604 y(the)33 b(orograph)m(y)-8 b(...\))45 b(and)33
+b(some)h(c)m(haracteristics)h(are)e(computed)i(\(the)e(conformal)g(co)s
+(ordinates,)h(the)88 725 y(map)42 b(factor...\).)71 b(The)43
+b(required)h(\014eld)f(is)f(then)h(read)f(and)g(a)m(v)-5
+b(ailable)43 b(in)f(a)g(6-dimensional)h(arra)m(y:)88
+845 y Fq(xv)-9 b(ar)p Fu(\(i,j,k,t,n,p\))787 809 y Fl(2)828
+845 y Fu(.)234 965 y(The)23 b(subroutine)g Ft(writevar.f90)h
+Fu(writes)f(the)g(\014eld)f(if)g(the)g(w)m(an)m(ted)h(output)f(format)f
+(is)h Fq(dia)p Fu(c)m(hronic)88 1086 y(one.)42 b(If)27
+b(it)h(is)g(the)g(\014rst)g(call)g(the)g(header)g(is)g(written,)i(then)
+e(the)g(\014eld)g(is)g(stored)h(b)m(y)f(the)g(same)h(n)m(um)m(b)s(er)88
+1206 y(of)j(records)h(than)g(when)h(it)e(w)m(as)i(read.)234
+1327 y(The)k(p)s(ersonal)g(co)s(de)f(can)h(b)s(e)f(inserted)i(in)e(the)
+h(main)f(program)g(b)s(et)m(w)m(een)i(the)f(call)f(of)g(the)g(t)m(w)m
+(o)88 1447 y(previous)j(subroutines.)63 b(F)-8 b(or)38
+b(the)h Fq(free)f Fu(format,)i(the)f(writing)g(co)s(de)g(lines)h(are)f
+(to)f(b)s(e)h(written)h(in)88 1567 y(the)33 b(main)f(program.)88
+1827 y Fv(5.2.2)112 b(Compilation)88 2012 y Fu(Y)-8 b(ou)32
+b(ha)m(v)m(e)i(to)233 2215 y Fp(\017)48 b Fu(create)34
+b(a)e(sub-directory)i Ft(src)f Fu(to)f(put)h(y)m(our)h(o)m(wn)f(source)
+g(\014les)233 2419 y Fp(\017)48 b Fu(cop)m(y)23 b Ft
+($MESONH/MAKE/tools/diach)q(ro/s)q(rc/E)q(XTR)q(ACTD)q(IA/e)q(xrwd)q
+(ia.)q(f90)28 b Fu(to)21 b Ft(src/my)p 3707 2419 31 4
+v 39 w(prog.f90)331 2539 y Fu(and)33 b(mo)s(dify)g(it)233
+2742 y Fp(\017)48 b Fu(initialize)34 b(the)e(shell)i(v)-5
+b(ariable)32 b Ft(ARCH)h Fu(whic)m(h)h(refers)f(to)f(y)m(our)h(system)h
+(and)e(the)h(compiler)g(used)331 2863 y(\(see)h(examples)h(as)d(the)h
+(su\016x)h(of)e(\014les)i(in)f Ft($MESONH/MAKE/conf)k
+Fu(directory\).)233 3066 y Fp(\017)48 b Fu(compile)34
+b(with)331 3187 y Ft(gmaketools)54 b(PROG=my)p 1258 3187
+V 39 w(prog)e(OBJS="my)p 1961 3187 V 40 w(routine1.o)h(my)p
+2666 3187 V 38 w(routine2.o")331 3307 y Fu(\(the)33 b($MESONH/MAKE/to)s
+(ols/diac)m(hro/)p Ft(Makefile.exrwdia)38 b Fu(v)m(ersion)c(will)g(b)s
+(e)e(used\).)88 3510 y(T)-8 b(o)32 b(up)s(date)h(the)g(routines)h(dep)s
+(endances)g(directly)g(inside)g(the)f(Mak)m(e\014le:)233
+3714 y Fp(\017)48 b Fu(initialize)34 b(the)f(follo)m(wing)g(shell)h(v)
+-5 b(ariables:)441 3917 y Fv({)49 b Ft(MNH)p 705 3917
+V 38 w(LIBTOOLS)d Fu(whic)m(h)g(is)f(the)f(directory)h(where)h(the)f
+(reference)g(sources)h(for)e(the)g(li-)546 4038 y(braries)33
+b(and)g(to)s(ols)f(are,)441 4199 y Fv({)49 b Ft(ARCH)36
+b Fu(whic)m(h)g(refers)g(to)e(y)m(our)i(system)g(and)f(the)g(compiler)h
+(used)g(\(see)g(examples)h(as)e(the)546 4320 y(su\016x)f(of)e(\014les)i
+(in)f Ft($MNH)p 1435 4320 V 38 w(LIBTOOLS/conf)j Fu(directory\).)233
+4523 y Fp(\017)48 b Fu(cop)m(y)40 b(the)f Ft($MNH)p 949
+4523 V 38 w(LIBTOOLS/tools/diachro/M)q(ake)q(file)q(.exr)q(wdia)45
+b Fu(\014le)40 b(in)f(y)m(our)g(w)m(orking)331 4644 y(directory)-8
+b(,)34 b(rename)f(it)g(to)f Ft(Makefile)p Fu(,)233 4847
+y Fp(\017)48 b Fu(compile)34 b(with)f Ft(gmake)p 88 4937
+1512 4 v 200 4998 a Fk(2)237 5029 y Fj(F)-7 b(or)29 b(a)h(whole)f
+(description)h(of)g(the)g(diac)n(hronic)e(\014le)j(t)n(yp)r(e,)f
+(reader)f(m)n(ust)h(refer)f(to)h(the)g(original)e(do)r(cumen)n(tation)
+88 5128 y(on)f(the)h(Meso-NH)f(w)n(eb)g(site:)37 b(\\)p
+Fi(cr)1207 5121 y(\023)1207 5128 y(ea)-6 b(tion)32 b(et)g(exploit)-6
+b(a)g(tion)32 b(de)f(fichiers)i(dia)n(chr)n(oniques)p
+Fj(,)27 b(J.)h(Duron".)1929 5941 y Fu(12)p eop end
+%%Page: 13 13
+TeXDict begin 13 12 bop 88 123 a Fs(5.3)135 b(Compare)46
+b(to)f(observ)-7 b(ations)46 b(with)f Fr(mesonh2obs)40
+b Fs(to)t(ol)88 307 y Fv(5.3.1)112 b(Input)38 b(and)g(output)88
+492 y Fu(The)31 b Ft(mesonh2obs)j Fu(to)s(ol)c(allo)m(ws)i(to)f(in)m
+(terp)s(olate)g(MesoNH)h(\014elds)h(at)d(giv)m(en)i(p)s(oin)m(ts)g
+(\(suc)m(h)g(as)f(p)s(oin)m(ts)88 613 y(where)i(observ)-5
+b(ation)33 b(data)g(are)f(a)m(v)-5 b(ailable\).)234 733
+y(The)32 b(input)g(\014les)h(are)f(an)f(ASCI)s(I)h(\014le)h(indicated)f
+(the)g(p)s(osition)g(of)f(the)h(p)s(oin)m(ts)g(b)m(y)h(their)f
+(latitude)88 853 y(and)41 b(longitude)g(co)s(ordinates)g(as)g(w)m(ell)i
+(as)e(v)m(ertical)h(dimension)g(if)f(a)g(v)m(ertical)h(pro\014le)f(is)g
+(required,)88 974 y(and)32 b(one)h(or)f(sev)m(eral)j(diac)m(hronic)e
+(FM)g(\014le\(s\))g(with)h(\014elds)f(to)g(in)m(terp)s(olate)g(at)f
+(previous)i(p)s(oin)m(ts.)234 1094 y(Eac)m(h)c(output)f(\014le,)i(one)e
+(for)f(eac)m(h)i(input)g(FM)f(\014le,)i(is)e(an)g(ASCI)s(I)h(one)f
+(with)h(six)g(p)s(ossible)h(options)88 1214 y(for)h(lines)h(format)f
+(\()p Fq(llhv)p Fu(,)h(llh)m(v,)h Fq(llzv)p Fu(,)f(llzv,)h
+Fq(llpv)p Fu(,)e(llp)m(v\).)234 1335 y(In)e(the)g(input)g(ASCI)s(I)h
+(\014le,)g(eac)m(h)f(line)h(indicates)g(the)f(lo)s(cation)f(of)h(one)g
+(p)s(oin)m(t,)g(all)g(lines)h(ha)m(v)m(e)g(the)88 1455
+y(same)i(format,)f(one)h(of)f(the)h(follo)m(wing)g(:)137
+1567 y(lon)g(lat)p 982 1603 4 121 v 620 w(and)f(altitudes)i(will)f(b)s
+(e)g(ask)m(ed)h(b)m(y)g(the)f Ft(mesonh2obs)i Fu(program)137
+1688 y(lat)e(lon)p 982 1724 V 620 w(and)f(altitudes)i(will)f(b)s(e)g
+(ask)m(ed)h(b)m(y)g(the)f Ft(mesonh2obs)i Fu(program)137
+1808 y(lon)e(lat)f(altitude\(m\))p 982 1844 V 137 1928
+a(lat)h(lon)f(altitude\(m\))p 982 1964 V 234 2093 a(The)39
+b(output)f(ASCI)s(I)g(\014le)g(con)m(tains)h(lines)g(with)g(the)f(same)
+g(format,)h(one)f(of)f(the)h(follo)m(wing)g(ac-)88 2214
+y(cording)32 b(to)h(the)g(option:)137 2325 y(lon)g(lat)f(mo)s(del)p
+709 2325 30 4 v 36 w(lev)m(el)p 933 2325 V 37 w(altitude\(m\))p
+1500 2362 4 121 v 100 w(option)g Fq(llhv)137 2446 y Fu(lat)h(lon)f(mo)s
+(del)p 709 2446 30 4 v 36 w(lev)m(el)p 933 2446 V 37
+w(altitude\(m\))p 1500 2482 4 121 v 100 w(option)g(llh)m(v)137
+2566 y(lon)h(lat)f(altitude\(m\))p 1500 2602 V 618 w(option)g
+Fq(llzv)113 b Fu({in)m(terp)s(olation)32 b(routine)h
+Ft(zinter.f90)j Fu(for)c(3D)f(\014elds)137 2687 y(lat)i(lon)f
+(altitude\(m\))p 1500 2723 V 618 w(option)g(llzv)446
+b(")137 2807 y(lon)33 b(lat)f(pression\(hP)m(a\))p 1500
+2843 V 522 w(option)g Fq(llpv)107 b Fu({in)m(terp)s(olation)32
+b(routine)h Ft(pinter.f90)j Fu(for)c(3D)f(\014elds)137
+2927 y(lat)i(lon)f(pression\(hP)m(a\))p 1500 2963 V 522
+w(option)g(llp)m(v)438 b(")33 b(\(pressure)h(v)-5 b(ariable)33
+b(is)g(read)g(in)g(input)g(FM)f(\014le\))88 3232 y Fv(5.3.2)112
+b(Usage)88 3416 y Fu(The)45 b(to)s(ol)f(is)h(an)f(in)m(teractiv)m(e)i
+(one:)68 b(the)45 b(option)f(for)g(the)h(lines)g(format)f(of)g(the)h
+(output)g(\014le,)j(the)88 3537 y(name)35 b(of)f(the)i(ASCI)s(I)f
+(\014le)h(with)f(the)g(lo)s(cation)g(of)f(the)h(observ)-5
+b(ation)36 b(p)s(oin)m(ts)f(are)g(\014rst)g(ask)m(ed.)52
+b(Then)88 3657 y(the)39 b(name)g(of)g(the)g(input)g(diac)m(hronic)h
+(\014les)g(is)f(ask)m(ed)i(in)e(a)f(lo)s(op,)i(and)f(the)g(name)h(of)e
+(the)h(\014elds)h(to)88 3777 y(in)m(terp)s(olate)33 b(in)g(a)f(second)i
+(lo)s(op:)293 3981 y Ft(mesonh2obs)54 b(<<)d(eof)88 4101
+y(format_output_file)56 b(#)51 b(line)h(format)h(of)f(output)h(file)f
+(\(LLHV/llhv/LLZV/llzv/LLP)q(V/l)q(lpv\))88 4222 y(format_input_file)
+107 b(#)51 b(LL)h(\(lon,lat\)ou)i(ll)e(\(lat,lon\))88
+4342 y(altitude_in_input_file)57 b(#)51 b(O)h(\(altitude_in_m)j(on)d
+(the)g(third)g(colon\)/N)88 4462 y(if)f(N,)h(number_vertical_levels)57
+b(#)52 b(number)h(of)e(vertical)j(levels)f(above)1574
+4583 y(#)f(each)g(lat,lon)h(points)395 4703 y(list_of_these_levels)159
+b(#)52 b(exemple:)h(\(in)f(metres)h(or)f(hPa\):)h(500)f(1500)88
+4824 y(obs_file)976 b(#)51 b(name)i(of)e(the)h(Obs)h(file)88
+4944 y(0)1333 b(#)51 b(control)i(prints)g(\(0/1/2/3\))88
+5064 y(diachronic_file1)568 b(#)51 b(file)i(with)f(fields)h(to)f(be)f
+(interpolated)k(\(without)e(.lfi\))88 5185 y
+(field1_of_diachronic_file1)58 b(#)51 b(field)i(to)f(be)f(interpolated)
+88 5305 y(field2_of_diachronic_file1)88 5425 y(END)1231
+b(#)51 b(end)h(of)g(extraction)i(in)e(diachronic_file1)88
+5546 y(diachronic_file2)568 b(#)51 b(file)i(with)f(fields)h(to)f(be)f
+(interpolated)k(\(without)e(.lfi\))88 5666 y
+(fieldi_of_diachronic_file2)58 b(#)51 b(field)i(to)f(be)f(interpolated)
+1929 5941 y Fu(13)p eop end
+%%Page: 14 14
+TeXDict begin 14 13 bop 88 123 a Ft(fieldj_of_diachronic_file2)88
+243 y(END)1231 b(#)51 b(end)h(of)g(extraction)i(in)e(diachronic_file2)
+88 364 y(END)1231 b(#)51 b(end)h(of)g(diachronic)i(files)f(list)88
+484 y(eof)234 678 y Fu(If)41 b Ft(field)p 601 678 31
+4 v 38 w(of)p 741 678 V 38 w(diachronic)p 1289 678 V
+39 w(file)36 b Fu(con)m(tains)f('A)m(C')h(string)e(\(for)g(A)m(Ccum)m
+(ulated)j(precipitation\),)88 798 y(y)m(ou)31 b(can)f(substract)i(v)-5
+b(alues)31 b(of)f(the)g(same)h(\014eld)g(from)f(a)g(previous)i(diac)m
+(hronic)g(\014le.)43 b(Then)31 b(after)f(line)88 919
+y Ft(field\('AC'\))p 655 919 V 39 w(of)p 796 919 V 38
+w(diachronic)p 1344 919 V 39 w(file)p Fu(,)k(answ)m(er)g(the)f
+(question:)88 1113 y Ft("Pluie)52 b(cumulee,)i(voulez-vous)g(faire)f
+(la)e(difference)j(avec)f(un)e(instant)j(anterieur)88
+1233 y(\(o\\/O\\/y\\/Y\\/n\\/N\))i(?")88 1428 y Fu(if)43
+b Ft(Y)p Fo(=)p Ft(O)p Fu(,)38 b(indicate)g(the)f(name)h(of)44
+b Ft(diachronic)p 1853 1428 V 39 w(file)p 2096 1428 V
+38 w(previous)39 b Fu(\(without)f(.l\014\))f(in)h(a)e(second)j(sup-)88
+1548 y(plemen)m(tary)34 b(line.)88 1806 y Fv(5.3.3)112
+b(Metho)s(d)88 1991 y Fu(The)31 b(main)g(program)g(retriev)m(es)i
+(\014rst)e(the)g Fo(X)39 b Fu(and)31 b Fo(Y)52 b Fu(conformal)30
+b(co)s(ordinates)i(of)e(eac)m(h)i(observ)-5 b(ation)88
+2111 y(p)s(oin)m(t,)41 b(then)f(for)f(eac)m(h)h(read)g(\014eld)g(in)m
+(terp)s(olates)h(it)e(v)m(ertically)i(if)f(required)h(\(v)m(ertical)f
+(pro\014le)g(\014eld)88 2232 y(with)29 b(option)g Fq(llzv)p
+Fu(,)h(llzv,)h Fq(llpv)f Fu(or)e(llp)m(v,)j Fq(llhv)p
+Fu(,)f(llh)m(v\),)h(and)e(\014nally)h(in)m(terp)s(olates)g(horizon)m
+(tally)g(the)88 2352 y(\014eld)j(and)g(the)g(arra)m(y)f(of)g(the)h(v)m
+(ertical)h(pro\014le.)88 2639 y Fs(5.4)135 b(Compare)46
+b(to)f(observ)-7 b(ations)46 b(with)f Fr(obs2mesonh)40
+b Fs(to)t(ol)88 2824 y Fv(5.4.1)112 b(Input)38 b(and)g(output)88
+3009 y Fu(The)e Ft(obs2mesonh)i Fu(to)s(ol)c(allo)m(ws)i(to)f(replace)h
+(observ)-5 b(ations)37 b(on)e(a)g(MesoNH)h(grid.)52 b(The)36
+b(output)f(\014le)88 3129 y(has)j(diac)m(hronic)h(FM)f(format:)54
+b(it)38 b(can)g(b)s(e)g(used)h(as)g(input)f(for)f Ft(diaprog)j
+Fu(to)e(plot)g(observ)-5 b(ations)39 b(in)88 3250 y(the)33
+b(same)g(bac)m(kground)h(as)e(MesoNH)i(\014elds.)234
+3370 y(The)k(input)f(\014les)h(are)e(one)h(or)g(sev)m(eral)h(ASCI)s(I)g
+(\014le\(s\),)g(eac)m(h)g(of)e(it)h(con)m(tains)h(the)f(v)-5
+b(alues)38 b(of)e(one)88 3490 y(t)m(yp)s(e)k(of)f(observ)-5
+b(ation)40 b(\(one)g(p)s(er)g(line,)i(all)d(lines)i(ha)m(v)m(e)g(the)f
+(same)g(format:)57 b(lon-lat-alt)p 3408 3490 30 4 v 34
+w(in)p 3523 3490 V 35 w(meters-)88 3611 y(v)-5 b(alue)40
+b(or)g(lat-lon-alt)p 904 3611 V 33 w(in)p 1018 3611 V
+36 w(meters-v)-5 b(alue\),)43 b(and)d(a)g(diac)m(hronic)h(FM)f(\014le)g
+(whose)h(grids)g(\(spatial)f(and)88 3731 y(temp)s(oral\))32
+b(will)h(b)s(e)g(used)h(to)e(replace)i(previous)g(observ)-5
+b(ation)33 b(v)-5 b(alues.)234 3851 y(The)46 b(output)g(\014le)h(is)f
+(a)f(diac)m(hronic)i(\014le)f(with)g(the)h(orograph)m(y)e(and)h(the)g
+(grids)g(of)f(the)h(input)88 3972 y(diac)m(hronic)40
+b(one,)h(eac)m(h)f(\014eld)g(corresp)s(onds)h(to)d(eac)m(h)i(input)g
+(observ)-5 b(ation)40 b(\014le.)64 b(One)39 b(or)g(t)m(w)m(o)h
+(\014elds)88 4092 y(are)33 b(added)g(for)g(eac)m(h)h(observ)-5
+b(ation)34 b(\014eld)f(treated:)45 b(N)p 2092 4092 V
+36 w(\014eld)p 2306 4092 V 36 w(name)33 b(for)g(the)g(n)m(um)m(b)s(er)i
+(of)e(observ)-5 b(ation)88 4213 y(a)m(v)m(eraged)47 b(in)g(eac)m(h)g
+(grid)f(p)s(oin)m(ts)h(and)g(if)f(2D)g(t)m(yp)s(e,)k(AL)-8
+b(T)p 2329 4213 V 36 w(\014eld)p 2543 4213 V 36 w(name)47
+b(for)f(the)g(altitudes)i(of)e(the)88 4333 y(observ)-5
+b(ation.)88 4591 y Fv(5.4.2)112 b(Usage)88 4776 y Fu(The)33
+b(to)s(ol)f(is)h(an)f(in)m(teractiv)m(e)j(one:)293 4970
+y Ft(obs2mesonh)54 b(<<)d(eof)88 5091 y(file_diachronic_with_zs)211
+b(#)51 b(initialize)j(MesoNH)f(spatial)g(and)f(temporal)i(grids)88
+5211 y(0/1/2/3)873 b(#)51 b(verbosity)j(level)88 5331
+y(LL)1128 b(#)51 b(format)i(of)f(obs)g(file)h(\(LL=lon)g(lat)f(alt)g
+(value,)1318 5452 y(#)1077 b(ll=lat)53 b(lon)f(alt)g(value\))88
+5572 y(file1_obs)771 b(#)51 b(name)i(of)f(obs)g(file)g(\(undefined)i
+(value=999.0\))88 5692 y(name_new_field1)465 b(#)51 b(name)i(of)f(the)g
+(obs)g(field)104 b(in)51 b(output)i(file)1929 5941 y
+Fu(14)p eop end
+%%Page: 15 15
+TeXDict begin 15 14 bop 88 123 a Ft(unit_new_field1)465
+b(#)51 b(free)i(characters)h(string)f(for)f(unit)88 243
+y(1D/2D/3D)822 b(#)51 b(profil)i(of)f(the)103 b(obs)53
+b(field)1318 364 y(#)e(for)i(the)f(2D)f(case,)i(only)f(K=1)g(will)h(be)
+f(initialised)88 484 y(LL)1128 b(#)51 b(format)i(of)f(obs)g(file)h
+(\(LL=lon)g(lat)f(alt)g(value,)1318 604 y(#)1077 b(ll=lat)53
+b(lon)f(alt)g(value\))88 725 y(file2_obs)88 845 y(name_new_field2)88
+965 y(unit_new_field2)88 1086 y(1D/2D/3D)88 1206 y(END)1077
+b(#)51 b(closing)j(of)d(output)i(diachronic)h(file)88
+1327 y(eof)88 1586 y Fv(5.4.3)112 b(Metho)s(d)88 1771
+y Fu(F)-8 b(or)31 b(eac)m(h)j(observ)-5 b(ation)33 b(read)g(in)f(an)h
+(input)g(\014le:)88 1891 y(-)f(the)h(MesoNH)g(grid)g(p)s(oin)m(t)g(I,J)
+g(con)m(taining)g(this)g(observ)-5 b(ation)33 b(is)g(searc)m(hing,)88
+2012 y(-)25 b(then)j(for)d(observ)-5 b(ation)27 b(with)h(3D)d
+(pro\014l,)j(the)f(v)m(ertical)h(lev)m(el)g(K)e(is)h(searc)m(hed)h
+(\(the)f(MesoNH)h(v)m(ertical)88 2132 y(grid)37 b(\(Gal-Chen\))g(at)g
+(I,J)h(is)g(tak)m(en)g(in)m(to)g(accoun)m(t\);)i(for)d(observ)-5
+b(ation)38 b(with)g(2D)e(or)h(1D)g(pro\014l,)i(the)88
+2253 y(\014rst)33 b(lev)m(el)h(K=1)e(is)h(attributed,)88
+2373 y(-)f(the)h(v)-5 b(alue)33 b(of)f(the)h(observ)-5
+b(ation)33 b(is)g(stored)g(on)g(grid)f(p)s(oin)m(t)h(\(I,J,K\).)88
+2493 y(If)k(sev)m(eral)j(v)-5 b(alues)39 b(are)e(stored)i(at)e(the)i
+(same)f(grid)g(p)s(oin)m(t,)i(arithmetic)e(a)m(v)m(erage)h(of)e(v)-5
+b(alues)39 b(is)g(done)88 2614 y(\(when)34 b(unit)g(is)g
+Fo(dB)5 b(z)t Fu(,)34 b(the)g(a)m(v)m(erage)g(is)g(computed)g(in)g
+Fo(Z)7 b(e)p Fu(\).)46 b(If)33 b(there)h(is)g(no)f(v)-5
+b(alues)34 b(at)f(a)h(grid)f(p)s(oin)m(t,)88 2734 y(unde\014ned)h(v)-5
+b(alue)34 b(is)f(put.)45 b(The)34 b(observ)-5 b(ations)34
+b(whose)h(altitude)e(is)h(b)s(elo)m(w)g(the)f(altitude)h(of)e(the)i
+(\014rst)88 2855 y(MesoNH)f(lev)m(el)i(are)d(stored)h(at)g(lev)m(el)h
+(K=1,)e(a)g(w)m(arning)h(message)h(is)f(prin)m(ted)h(in)f(this)g(case.)
+234 2975 y(The)k(wind)h(comp)s(onen)m(ts)g(are)e(considered)i(zonal)f
+(and)g(meridian)g(in)g(the)f(observ)-5 b(ation)37 b(and)g(are)88
+3095 y(transformed)c(to)f(wind)h(comp)s(onen)m(ts)i(in)d(the)h(Mesonh)h
+(grid.)88 3384 y Fs(5.5)135 b(Catenation)32 b(of)e(Lagrangian)h(tra)7
+b(jectory)32 b(with)e Fr(compute)p 3243 3384 37 4 v 41
+w(r00)p 3470 3384 V 43 w(pc)f Fs(to)t(ol)88 3569 y Fv(5.5.1)112
+b(Input)38 b(and)g(output)88 3754 y Fu(The)30 b Ft(compute)p
+648 3754 31 4 v 39 w(r00)p 840 3754 V 37 w(pc)g Fu(to)s(ol)e(allo)m(ws)
+i(to)f(compute)i(adv)-5 b(anced)30 b(diagnostics.)43
+b(related)30 b(to)f(Lagrangian)88 3874 y(tracers)38 b(activ)-5
+b(ated)38 b(during)f(the)h(mo)s(del)g(sim)m(ulation)h(\()p
+Ft(LLG=.TRUE.)h Fu(in)d(namelist)i Ft(NAM)p 3360 3874
+V 38 w(CONF)p Fu(\):)f(it)g(is)88 3994 y(based)45 b(on)g(the)g
+(subroutine)h Ft(compute)p 1557 3994 V 39 w(r00)f Fu(used)h(in)f(the)h
+(DIA)m(G)e(program.)80 b(See)45 b(section)h(2.2)f(of)88
+4115 y(do)s(cumen)m(tation)37 b(\\Lagrangian)f(tra)5
+b(jectory)37 b(and)g(air-mass)g(trac)m(king)g(analyses)h(with)f(MesoNH)
+h(b)m(y)88 4235 y(means)33 b(of)f(Eulerian)i(passiv)m(e)g(tracers")g
+(\(Gheusi)f(and)g(Stein,)g(2005\).)234 4355 y(The)g(input)g(\014les)h
+(are)e(one)h(or)f(sev)m(eral)i(diac)m(hronic)f(FM)f(\014le\(s\))i(con)m
+(taining)f(Lagrangian)e(tracers)88 4476 y(\()p Ft(LGXM,LGYM,LGZM)p
+Fu(\))36 b(simply)e(con)m(v)m(erted)h(b)m(y)h Ft(conv2dia)f
+Fu(after)d(sim)m(ulation,)i(or)f(after)g Fq(dia)n(g)g
+Fu(\(in)g(the)88 4596 y(latter)47 b(case,)k(only)d(Lagrangian)e(basic)i
+(diagnostics)g(w)m(ere)g(ask)m(ed:)74 b Ft(LTRAJ=.TRUE.)51
+b Fu(in)c(namelist)88 4717 y Ft(NAM)p 247 4717 V 37 w(DIAG)33
+b Fu(with)g(the)f(namelist)h Ft(NAM)p 1453 4717 V 38
+w(STO)p 1644 4717 V 38 w(FILE)g Fu(empt)m(y)-8 b(,)34
+b(and)e(additional)g(diagnostic)g(\014elds)i(can)e(b)s(e)88
+4837 y(ask)m(ed:)44 b Ft(CISO='EV')33 b Fu(and)f Ft(LMOIST)p
+1384 4837 V 38 w(E=.T.)h Fu(for)d(the)i(example)h(of)d(5.5.2\),)h(and)g
+(an)h(ASCI)s(I)g(\014le)f(named)88 4957 y Ft(compute)p
+451 4957 V 38 w(r00.nam)k Fu(with)e(namelist)h(format.)234
+5078 y(The)28 b(output)g(\014le)g(is)g(a)f(diac)m(hronic)i(\014le)f
+(con)m(taining)g(adv)-5 b(anced)28 b(diagnostics:)42
+b(initial)28 b(co)s(ordinates)88 5198 y(resulting)36
+b(from)g(catenation)g(pro)s(cess,)i(initial)e(v)-5 b(alues)36
+b(of)f(basic)i(diagnostic)f(\014elds)h(\(presen)m(t)h(in)e(the)88
+5319 y(input)d(diac)m(hronic)g(\014les\))h(that)e(the)h(Lagrangian)f
+(parcels)i(had)f(at)f(initial)h(time\(s\).)1929 5941
+y(15)p eop end
+%%Page: 16 16
+TeXDict begin 16 15 bop 88 123 a Fv(5.5.2)112 b(Usage)88
+307 y Fu(The)33 b(ASCI)s(I)g(\014le)h Ft(compute)p 1112
+307 31 4 v 38 w(r00.nam)h Fu(lo)s(oks)e(as)f(the)h(follo)m(wing:)88
+511 y Ft(&NAM_STO_FILE)54 b(CFILES\(1\)='AR40_mc2_1999)q(0921)q(.00)q
+(d.Z')q(,)805 631 y(CFILES\(2\)='AR40_mc2_1999)q(0920)q(.12)q(d.Z')q(,)
+805 752 y(CFILES\(3\)='AR40_mc2_1999)q(0920)q(.00)q(d.Z')q(,)805
+872 y(CFILES\(4\)='AR40_mc2_1999)q(0919)q(.12)q(d.Z')q(,)805
+992 y(CFILES\(5\)='AR40_mc2_1999)q(0919)q(.00)q(d.Z')q(,)805
+1113 y(NSTART_SUPP\(1\)=3)979 b(/)88 1233 y(&NAM_FIELD)105
+b(CFIELD_LAG\(1\)='THETAE',)703 1354 y(CFIELD_LAG\(2\)='POVOM')57
+b(/)88 1557 y Fu(The)27 b(namelist)h Ft(NAM)p 826 1557
+V 38 w(STO)p 1017 1557 V 38 w(FILE)g Fu(is)f(the)g(same)h(as)f(in)g
+(the)h(\014le)f Ft(DIAG1.nam)p Fu(.)44 b(The)28 b(namelist)g
+Ft(NAM)p 3579 1557 V 38 w(FIELD)88 1677 y Fu(indicates)34
+b(the)f(other)f(quan)m(tities)j(for)d(whic)m(h)i(initial)f(v)-5
+b(alues)33 b(ha)m(v)m(e)h(to)e(b)s(e)h(computed.)234
+1918 y(Then)h(to)e(run)h(the)g(to)s(ol,)88 2122 y Ft(#)102
+b(initialise)54 b(the)e(following)i(shell)f(variable)g(\(optional)h(if)
+d(input)i(file)88 2242 y(#)102 b(is)52 b(in)g(the)g(current)h
+(directory\):)88 2362 y(export)f(DIRLFI=directory_files_)q(diac)q(hro)
+88 2483 y(#)102 b(initialise)54 b(the)e(variable)i(ARCH)e(\(LXNAGf95)i
+(for)e(PC,)g(HPf90)g(for)h(HP\))88 2603 y(export)f(ARCH=LXNAGf95)88
+2723 y(#)102 b(execute)88 2844 y($MESONH/MAKE/tools/diachro/)q($AR)q
+(CH/c)q(ompu)q(te_r)q(00_)q(pc)88 3104 y Fv(5.5.3)112
+b(Metho)s(d)88 3288 y Fu(The)30 b(structure)g(of)f(the)g(program)g(and)
+g(the)h(in)m(terp)s(olation)g(subroutine)g(\()p Ft(interpxyz)p
+Fu(\))h(are)f(the)f(same)88 3409 y(as)40 b(in)g(the)g
+Fq(dia)n(g)g Fu(program,)i(the)e(subroutines)i(of)d(reading)h(and)g
+(writing)h(are)f(those)g(for)g(handling)88 3529 y(diac)m(hronic)33
+b(\014les)h(\()p Ft(readvar)g Fu(and)f Ft(writevar)p
+Fu(\).)1929 5941 y(16)p eop end
+%%Page: 17 17
+TeXDict begin 17 16 bop 88 123 a Fw(6)161 b(Con)l(v)l(ersion)50
+b(to)j(GRIB)h(or)g(Vis5D)e(\014les)88 371 y Fs(6.1)135
+b(Presen)l(tation)88 556 y Fu(FM)39 b(sync)m(hronous)j(\014le)e(can)g
+(b)s(e)g(con)m(v)m(ert)h(in)m(to)f(GRIB)p 1887 569 253
+4 v 39 w(or)f(Vis5D)p 2305 569 262 4 v 40 w(format.)64
+b(This)40 b(section)h(aims)f(at)88 676 y(describ)34 b(ho)m(w)f(the)g
+(con)m(v)m(erter)h(w)m(orks)g(and)f(ho)m(w)g(use)h(it.)234
+796 y(The)48 b(GRIB)e(\(GRId)g(in)h(Binary\))g(format)f(is)i(a)e
+(standard)h(meteorological)g(one,)k(de\014ned)d(b)m(y)88
+917 y(the)35 b(WMO.)g(GRIB)g(\014les)h(can)f(b)s(e)g(plotted)h(with)f
+(METVIEW)i(graphic)e(in)m(terface)h(\(dev)m(elopp)s(ed)h(at)88
+1037 y(ECMWF\),)c(or)f(R2)815 1001 y Fl(3)887 1037 y
+Fu(soft)m(w)m(are.)234 1157 y(The)i(Vis5D)f(format)f(is)h(sp)s
+(eci\014ed)i(for)e(using)g(Vis5D)2206 1121 y Fl(4)2279
+1157 y Fu(soft)m(w)m(are)h(\(follo)m(wing)f(the)g(GNU)g(General)88
+1278 y(Public)i(License\):)49 b(3)34 b(spatial)g(dimensions,)j(time)e
+(dimension,)h(5)2508 1242 y Fh(th)2612 1278 y Fu(dimension)g(for)e(en)m
+(umeration)i(of)88 1398 y(v)-5 b(ariables.)44 b(It)32
+b(is)i(rather)e(designed)i(for)e(animation)h(of)f(3D)g(plotting.)234
+1519 y(Choice)37 b(w)m(as)g(made)f(to)g(put)g(together)g(the)g(t)m(w)m
+(o)h(\014le)f(formats)g(in)g(a)g(same)g(con)m(v)m(ersion)i(program)88
+1639 y(b)s(ecause)50 b(in)f(b)s(oth)g(cases)h(sp)s(eci\014cities)h(of)e
+(Meso-NH)g(grids)h(ha)m(v)m(e)g(to)e(b)s(e)h(treated)h(in)f(the)g(same)
+88 1759 y(w)m(a)m(y)34 b(\(horizon)m(tally:)46 b(Arak)-5
+b(a)m(w)m(a)34 b(C-grid,)f(v)m(ertically:)47 b(Gal-Chen)34
+b(co)s(ordinate)39 b(^)-55 b Fo(z)38 b Fu(follo)m(wing)c(terrain\).)88
+1880 y(Ho)m(w)m(ev)m(er,)j(the)e(user)h(has)f(to)f(c)m(ho)s(ose)i(one)f
+(of)f(the)h(t)m(w)m(o)h(formats)e(a)m(v)-5 b(ailable)36
+b(when)f(running)h(the)f(to)s(ol)88 2000 y(\(see)e(section)h(6.2\).)88
+2289 y Fs(6.2)135 b(Usage)88 2474 y Fu(The)25 b(in)m(teractiv)m(e)h(to)
+s(ol)e(is)h(called)g Ft(lfi2grb)h Fu(or)e Ft(lfi2v5d)j
+Fu(according)d(the)h(w)m(an)m(ted)h(output)e(\014le)h(format,)88
+2594 y(but)k(it)f(runs)i(the)f(same)h(program.)41 b(Some)30
+b(questions)g(are)f(to)g(b)s(e)g(answ)m(ered)h(to)f(indicate)g(the)h(n)
+m(um)m(b)s(er)88 2714 y(and)k(t)m(yp)s(e)h(of)f(v)m(ertical)h(lev)m
+(els,)i(the)e(t)m(yp)s(e)g(of)f(horizon)m(tal)g(domain,)h(and)g(the)f
+(name)h(of)f(the)g(v)-5 b(ariables)88 2835 y(to)36 b(write)h(in)m(to)g
+(the)g(output)f(\014le.)56 b(All)37 b(that)f(is)h(t)m(yp)s(ed)h(on)e(k)
+m(eyb)s(oard)i(is)f(sa)m(v)m(ed)h(in)f Ft(dirconv.grb)i
+Fu(or)88 2955 y Ft(dirconv.v5d)d Fu(\014le,)f(it)f(can)g(b)s(e)g(app)s
+(ended)h(and)f(used)h(as)f(input)h(\(after)e(renaming)i(it\))e(for)h
+(the)g(next)88 3076 y(call)e(of)h(the)g(to)s(ol)e(\(e.g.)44
+b Ft(mv)52 b(dirconv.grb)i(dirgrb)f(;)e(lfi2grb)i(<)f(dirgrb)p
+Fu(\).)234 3196 y(F)-8 b(or)32 b(historical)h(reasons,)h(a)f(program)f
+(with)h(the)g(same)h(goal)e(of)g(con)m(v)m(ersion)j(to)e(GRIB)f(or)g
+(Vis5d)88 3316 y(has)43 b(b)s(een)h(\014rst)g(dev)m(elopp)s(ed)h(as)f
+(a)e(main)i(program)f(of)f(MesoNH,)j(as)e(DIA)m(G)g(program)g(is.)76
+b(This)88 3437 y(program)25 b(called)h Fv(CONVLFI)g Fu(runs)g(with)h
+(the)f(MesoNH)h(pro)s(cedure)f Fv(prepmo)s(del)i Fu(and)d(a)h(namelist)
+88 3557 y(\014le)33 b Ft(CONVLFI1.nam)i Fu(\(see)f(6.2.5\).)234
+3678 y(T)-8 b(o)49 b(use)i(the)f(con)m(v)m(erter)h(after)e(a)g
+Fv(DIA)m(G)56 b(prepmo)s(del)51 b Fu(job,)j(the)c(Meso-NH)g(\014le)g(m)
+m(ust)g(re-)88 3798 y(main)31 b(a)g(sync)m(hronous)i(\014le,)f(not)f
+(transformed)g(on)m(to)g(a)g(diac)m(hronic)h(\014le:)43
+b(in)32 b Fv(prepmo)s(delrc)g Fu(sp)s(ecify)88 3918 y
+Ft(OUTFILE)p 451 3918 31 4 v 38 w(TOOLS='fm')k Fu(\(default)c(is)h
+('con)m(v2dia')h(to)e(con)m(v)m(ert)i(with)g Ft(conv2dia)p
+Fu(\).)88 4178 y Fv(6.2.1)112 b Ft(lfi2grb)39 b Fv(to)s(ol)88
+4363 y Fu(When)d Ft(lfi2grb)i Fu(to)s(ol)d(is)i(in)m(v)m(ok)m(ed,)i(y)m
+(ou)e(m)m(ust)g(indicate,)h(after)e(the)g(name)h(of)e(the)h(input)h
+(\014le,)h(\014rst)88 4483 y(the)33 b(horizon)m(tal)h(grid)f(\(t)m(yp)s
+(e,)h(ev)m(en)m(tually)i(t)m(yp)s(e)e(of)f(in)m(terp)s(olation)g(and)g
+(domain\),)h(the)g(v)m(ertical)g(grid)88 4604 y(\(t)m(yp)s(e)i(and)g
+(lev)m(els\),)i(then)e(the)g(list)g(of)f(the)h(3-dimensional)g
+(\014elds)h(to)e(con)m(v)m(ert,)j(and)e(the)g(list)g(of)f(the)88
+4724 y(2-dimensional)e(ones.)234 4844 y(F)-8 b(or)47
+b(the)g(horizon)m(tal)33 b(grid)p 606 4877 626 4 v(,)52
+b(y)m(ou)c(can)g(either)g(k)m(eep)h(the)f(one)g(of)f(MesoNH)h(\014le)h
+(\(cartesien)f(or)88 4965 y(conformal)42 b(pro)5 b(jection\))44
+b(or)f(in)m(terp)s(olate)g(on)m(to)g(a)g(lat-lon)f(regular)h(grid.)75
+b(In)43 b(the)g(\014rst)h(case,)i(y)m(ou)88 5085 y(can)c(replace)g(all)
+g(the)g(\014elds)i(on)d(mass)i(p)s(oin)m(ts)g(\(A-grid\))e(or)g(k)m
+(eep)j(the)e(nativ)m(e)h(grid)f(\(C-grid\).)71 b(In)88
+5205 y(the)41 b(second)g(case,)j(y)m(ou)d(ha)m(v)m(e)h(to)e(indicate)i
+(the)f(b)s(ounds)g(of)f(the)h(domain)g(with)g(north)g(and)g(south)88
+5326 y(latitudes)h(and)f(w)m(est)i(and)e(east)h(longitudes,)j(as)c(w)m
+(ell)i(as)e(the)h(t)m(yp)s(e)g(of)f(horizon)m(tal)h(in)m(terp)s
+(olation:)p 88 5413 1512 4 v 200 5475 a Fk(3)237 5505
+y Fj(used)28 b(in)f(the)h(GMME/MICADO)g(team)f(at)h(CNRM)200
+5574 y Fk(4)237 5604 y Fj(home)f(page)g Fg(http://www.ssec.)o(wis)o(c.)
+o(edu)o(/)1748 5589 y(~)1748 5604 y(b)o(ill)o(h/)o(vi)o(s5d)o(.h)o(tml)
+1929 5941 y Fu(17)p eop end
+%%Page: 18 18
+TeXDict begin 18 17 bop 88 123 a Fu(nearest-neigh)m(b)s(our)48
+b(v)-5 b(alue)47 b(or)g(bilinear)h(in)m(terp)s(olation)f(with)h(the)f
+(4)g(surrounding)h(v)-5 b(alues.)88 b(The)88 243 y(resolution)42
+b(of)f(the)i(lat.-lon.)70 b(grid)42 b(is)g(automatically)g(initialized)
+h(with)g(the)f(equiv)-5 b(alen)m(t)43 b(v)-5 b(alue)43
+b(of)88 364 y(the)33 b(grid-mesh)h(where)g(the)f(map)g(scale)h(is)f
+(minim)m(um.)47 b(The)33 b(program)g(also)g(indicates)h(the)g(n)m(um)m
+(b)s(er)88 484 y(of)g(grid)g(p)s(oin)m(ts)h(of)g(the)g(Meso-NH)g
+(domain)g(inside)h(the)f(prescrib)s(ed)h(lat-lon)e(domain.)50
+b(If)35 b(there)g(are)88 604 y(p)s(oin)m(ts)26 b(of)g(lat-lon)g(domain)
+g(outside)i(Meso-NH)f(one,)g(the)g(v)-5 b(alue)27 b(of)f(the)g(in)m
+(terp)s(olated)h(\014elds)h(at)e(these)88 725 y(p)s(oin)m(ts)33
+b(will)g(b)s(e)g(a)f(missing)i(one.)234 845 y(The)47
+b(v)m(ertical)33 b(grid)p 448 878 515 4 v 46 w(can)46
+b(b)s(e)g(either)h(the)f(nativ)m(e)h(K)e(lev)m(els)j(or)d(pressure)j
+(lev)m(els.)85 b(In)46 b(the)h(\014rst)88 965 y(case)30
+b(\()p Ft(K)p Fu(\),)f(all)g(lev)m(els)i(are)e(k)m(ept)h(and)f(no)g(in)
+m(terp)s(olation)h(is)f(done:)42 b(the)30 b(heigh)m(t)g(sp)s(eci\014ed)
+h(in)e(the)g(GRIB)88 1086 y(header)e(is)g(the)f(one)h(of)f(the)h(grid)f
+(without)h(orograph)m(y)-8 b(.)41 b(In)27 b(the)g(second)h(case)f(\()p
+Ft(P)p Fu(\),)g(the)f(list)h(of)f(pressure)88 1206 y(lev)m(els)32
+b(is)f(either)g(sp)s(eci\014ed)h(man)m(ually)f(or)f(computed)h(using)g
+(a)f(linear)h(function)g(from)f(user-sp)s(eci\014ed)88
+1327 y(minim)m(um,)i(maxim)m(um)g(and)e(incremen)m(t)i(v)-5
+b(alues.)44 b(If)30 b(a)g(prescrib)s(ed)h(lev)m(el)h(is)f(b)s(elo)m(w)g
+(the)f(lo)m(w)m(er)i(Meso-)88 1447 y(NH)37 b(lev)m(el)h(or)f(ab)s(o)m
+(v)m(e)h(the)f(upp)s(er)h(MesoNH)g(lev)m(el,)h(the)f(v)-5
+b(alue)37 b(of)g(the)g(\014eld)h(at)e(this)i(lev)m(el)h(will)e(b)s(e)g
+(a)88 1567 y(missing)c(one.)44 b(Otherwise,)35 b(the)e(v)-5
+b(alue)33 b(is)g(computed)g(from)g(a)f(linear)h(in)m(terp)s(olation)g
+(in)g(log\(P\).)234 1688 y(The)28 b(3-dimensional)33
+b(\014elds)p 429 1701 836 4 v 29 w(to)26 b(con)m(v)m(ert)j(are)e(sp)s
+(eci\014ed)i(as)e(follo)m(ws:)42 b(one)27 b(\014eld)h(p)s(er)f(line)h
+(with)g(\014rst)88 1808 y(the)39 b(name)g(of)f(the)h(record)g(in)g(the)
+g(input)g(\014le)g(follo)m(wing)g(b)m(y)g(its)g(grib)g(co)s(de)g
+(\(tabular)f(c)m(haracter)i(is)88 1928 y(allo)m(w)m(ed\).)59
+b(Note)38 b(that)f(no)g(test)i(is)f(done)g(on)f(the)h(v)-5
+b(alue)38 b(of)f(grib)g(co)s(de)h(\(GRIB)f(header)h Ff(ISEC1\(6\))p
+Fu(\):)88 2049 y(y)m(ou)32 b(c)m(ho)s(ose)h(it)f(to)g(easily)h(iden)m
+(tify)g(the)g(\014eld)f(with)h(the)f(soft)m(w)m(are)h(used)g(after)f
+(the)h(con)m(v)m(ersion.)45 b(The)88 2169 y(end)33 b(of)f(the)h(list)g
+(is)g(indicated)h(b)m(y)f(the)g(k)m(eyw)m(ord)i Ft(END)p
+Fu(.)234 2290 y(The)28 b(2-dimensional)33 b(\014elds)p
+429 2303 V 29 w(to)26 b(con)m(v)m(ert)j(are)e(sp)s(eci\014ed)i(as)e
+(follo)m(ws:)42 b(one)27 b(\014eld)h(p)s(er)f(line)h(with)g(\014rst)88
+2410 y(the)k(name)h(of)e(the)i(record)f(in)h(the)f(input)h(\014le)f
+(\(it)g(can)h(b)s(e)f(a)g(K-lev)m(el)h(of)e(a)h(3-dimensional)h
+(\014eld)g(to)s(o\),)88 2530 y(follo)m(wing)i(b)m(y)h(its)g(grib)f(co)s
+(de)h(and)g(p)s(ossibly)g(lev)m(el)h(indicator)f(and)f(lev)m(el)i(v)-5
+b(alue)36 b(\(tabular)f(c)m(haracter)88 2651 y(is)f(allo)m(w)m(ed\).)48
+b(Note)33 b(that)h(the)g(v)-5 b(alue)34 b(of)f(the)h(lev)m(el)h
+(indicator)f(\()p Ff(ISEC1\(7\))p Fu(\))f(is)h(optional)g(\(the)g
+(default)88 2771 y(v)-5 b(alue)32 b(is)g(105:)43 b Ff('sp)s(eci\014ed)
+33 b(height)f(ab)s(ove)f(ground')p Fu(\).)43 b(So)32
+b(is)g(the)g(lev)m(el)i(v)-5 b(alue)32 b(\()p Ff(ISEC1\(8\))p
+Fu(\),)f(the)i(default)88 2892 y(v)-5 b(alue)28 b(is)h(the)f(altitude)h
+(of)f(the)g(\014rst)h(mass)g(p)s(oin)m(t)f(of)g(the)g(K-lev)m(els.)44
+b(The)29 b(end)f(of)g(the)h(list)f(is)h(indicated)88
+3012 y(b)m(y)k(the)g(k)m(eyw)m(ord)i Ft(END)p Fu(.)88
+3269 y Fv(6.2.2)112 b(Example)39 b(of)e Ft(lfi2grb)i
+Fv(use)233 3454 y Fp(\017)48 b Fu(to)33 b(con)m(v)m(ert)h(on)m(to)e(a)h
+(GRIB)f(\014le)h(with)g(horizon)m(tal)g(and)g(v)m(ertical)h(in)m(terp)s
+(olations)f(in)g(P)g(lev)m(els:)331 3574 y(\(all)22 b(that)g(is)g(t)m
+(yp)s(ed)h(on)e(k)m(eyb)s(oard)i(\(in)f Fe(italic)f Fu(in)h(the)h
+(example)g(b)s(elo)m(w\))f(is)h(sa)m(v)m(ed)g(in)f Ft(dirconv.grb)p
+Fu(\))88 3773 y Fn(-)47 b(ENTER)f(FM)i(synchronous)c(FILE)j(NAME)g
+(\(without)e(.lfi\))h(?)88 3886 y Fm(CEXP.1.CSEG.001d)921
+b Fd(<)p Fc(-)30 b(the)g(input)g(\014le)g(m)m(ust)h(b)s(e)e(splitted)i
+(in)f(.des)g(and)g(.l\014)88 3999 y Fn(-)47 b(Horizontal)e
+(interpolation)f(to)j(lat-lon)f(regular)g(grid?)94 b(\(Y/y/O/o/N/n\))88
+4112 y Fm(y)88 4225 y Fn(-)47 b(Type)g(of)g(interpolation?)91
+b(NEARest-neighbour)44 b(\(default\))h(or)i(BILInear)88
+4337 y Fm(NEAR)88 4450 y Fn(-)g(NSWE)g(target)f(domain)g(bounds)g(\(in)
+h(degrees\)?)88 4563 y Fm(55.)42 b(35.)h(-20.)f(10.)88
+4676 y Fn(-)47 b(Vertical)f(grid:)94 b(type)46 b(K)i(or)f(P)g(?)88
+4789 y Fm(P)88 4902 y Fn(-)g(Type)g(of)g(vertical)e(grid:)94
+b(given)47 b(by)g(linear)f(FUNCTN)g(\(default\))f(or)j(MANUALly)d(?)88
+5015 y Fm(FUNCTN)88 5128 y Fn(-)i(Enter)f(number)g(of)i(P)f(levels)f(?)
+88 5241 y Fm(5)88 5354 y Fn(-)h(Values)f(of)h(the)g(5)h(P)f(levels)f
+(\(hPa,)h(from)f(bottom)g(to)h(top\):)88 5467 y Fm(1000.)c(850.)g(700.)
+g(500.)g(300.)88 5580 y Fn(-)k(Enter)f(3D)i(variables)d(to)i(CONVERT)f
+(\(1/1)g(line,)h(end)g(by)g(END\):)88 5692 y(MesoNH)f(field)g(name,)g
+(grib)h(parameter)e(indicator)1929 5941 y Fu(18)p eop
+end
+%%Page: 19 19
+TeXDict begin 19 18 bop 88 123 a Fm(UM)31 b(33)88 236
+y Fn(-)47 b(next)g(3D)g(field)f(or)h(END)g(?)88 349 y
+Fm(VM)31 b(34)88 461 y Fn(-)47 b(next)g(3D)g(field)f(or)h(END)g(?)88
+574 y Fm(END)88 687 y Fn(-)g(Enter)f(2D)i(variables)d(to)i(CONVERT)f
+(\(1/1)g(line,)h(end)g(by)g(END\):)88 800 y(MesoNH)f(field)g(name,)g
+(grib)h(parameter)e(indicator,)g(eventually)g(level)i(indicator)e(and)i
+(level)88 913 y(value)88 1026 y Fm(T2M)32 b(13)i(105)f(2)88
+1139 y Fn(-)47 b(next)g(2D)g(field)f(or)h(END)g(?)88
+1252 y Fm(THM)p 309 1252 28 4 v 32 w(K)p 411 1252 V 34
+w(2)33 b(13)88 1365 y Fn(-)47 b(next)g(2D)g(field)f(or)h(END)g(?)88
+1478 y Fm(END)88 1591 y Fn(2)g(fields)f(\(3D\),)g(and)h(2)h(fields)e
+(\(2D\))h(written)e(in)j(CEXP.1.CSEG.001d.GRB)88 1963
+y Fv(6.2.3)112 b Ft(lfi2v5d)39 b Fv(to)s(ol)88 2148 y
+Fu(When)d Ft(lfi2v5d)i Fu(to)s(ol)d(is)i(in)m(v)m(ok)m(ed,)i(y)m(ou)e
+(m)m(ust)g(indicate,)h(after)e(the)g(name)h(of)e(the)h(input)h(\014le,)
+h(\014rst)88 2268 y(the)29 b(v)m(ertical)h(grid)e(\(t)m(yp)s(e)i(and)f
+(lev)m(els\),)i(then)e(the)h(list)f(of)f(the)h(3-dimensional)h
+(\014elds)f(to)g(con)m(v)m(ert,)i(and)88 2389 y(the)i(list)g(of)f(the)h
+(2-dimensional)g(ones.)234 2509 y(No)27 b(horizon)m(tal)h(in)m(terp)s
+(olation)g(is)g(a)m(v)-5 b(ailable)28 b(for)g(the)g(Vis5D)f(format)g
+(output:)41 b(all)28 b(the)g(con)m(v)m(erted)88 2630
+y(\014elds)39 b(are)f(replaced)h(on)f(mass)h(p)s(oin)m(ts)f(\(A-grid\))
+f(of)h(the)g(MesoNH)h(grid)f(\(cartesien)i(or)d(conformal)88
+2750 y(pro)5 b(jection\).)234 2870 y(The)38 b(v)m(ertical)c(grid)p
+439 2903 515 4 v 37 w(can)k(b)s(e)f(either)h(the)g(nativ)m(e)g(K)f(lev)
+m(els,)k(altitude)c(lev)m(els)j(or)d(pressure)i(lev)m(els.)88
+2991 y(In)j(the)g(\014rst)h(case)g(\()p Ft(K)p Fu(\),)f(all)g(lev)m
+(els)i(are)e(k)m(ept)h(and)f(the)g(\014elds)h(are)f(in)m(terp)s(olated)
+h(on)f(the)g(lev)m(els)j(of)88 3111 y(the)h(lo)m(w)m(est)h(p)s(oin)m(t)
+e(of)g(the)h(domain.)83 b(In)46 b(the)g(second)h(and)f(third)f(cases)i
+(\()p Ft(Z)f Fu(and)g Ft(P)p Fu(\),)f(the)h(list)h(of)88
+3231 y(lev)m(els)32 b(is)f(either)g(sp)s(eci\014ed)h(man)m(ually)f(or)f
+(computed)h(using)g(a)f(linear)h(function)g(from)f(user-sp)s(eci\014ed)
+88 3352 y(minim)m(um,)44 b(maxim)m(um)e(and)e(incremen)m(t)j(v)-5
+b(alues.)68 b(The)41 b(v)-5 b(alue)41 b(of)f(the)h(\014eld)g(is)g
+(computed)h(from)e(a)88 3472 y(linear)33 b(in)m(terp)s(olation)f(in)h
+(Z)f(or)h(in)f(log\(P\).)234 3593 y(The)j(3-dimensional)f(\014elds)p
+436 3606 836 4 v 35 w(to)g(con)m(v)m(ert)i(are)e(sp)s(eci\014ed)j(with)
+e(one)f(record)h(name)g(p)s(er)g(line.)49 b(The)88 3713
+y(end)33 b(of)f(the)h(list)g(is)g(indicated)h(b)m(y)f(the)g(k)m(eyw)m
+(ord)i Ft(END)p Fu(.)234 3833 y(Then)50 b(the)f(2-dimensional)33
+b(\014elds)p 689 3846 V 1 w(,)53 b(or)48 b(a)h(K-lev)m(el)g(of)f
+(3-dimensional)i(\014elds,)k(to)48 b(con)m(v)m(ert)i(are)88
+3954 y(sp)s(eci\014ed)34 b(in)f(the)g(same)g(w)m(a)m(y)-8
+b(.)88 4214 y Fv(6.2.4)112 b(Example)39 b(of)e Ft(lfi2v5d)i
+Fv(use)233 4398 y Fp(\017)48 b Fu(to)33 b(con)m(v)m(ert)h(on)m(to)e(a)h
+(Vis5D)f(\014le)h(with)g(v)m(ertical)h(in)m(terp)s(olation)f(in)g(Z)f
+(lev)m(els:)331 4519 y(\(all)22 b(that)g(is)g(t)m(yp)s(ed)h(on)e(k)m
+(eyb)s(oard)i(\(in)f Fe(italic)f Fu(in)h(the)h(example)g(b)s(elo)m(w\))
+f(is)h(sa)m(v)m(ed)g(in)f Ft(dirconv.v5d)p Fu(\))88 4739
+y Fn(-)47 b(ENTER)f(FM)i(synchronous)c(FILE)j(NAME)g(\(without)e
+(.lfi\))h(?)88 4852 y Fm(CEXP.1.CSEG.001)920 b Fd(<)p
+Fc(-)30 b(the)h(input)e(\014le)i(m)m(ust)f(b)s(e)g(splitted)h(in)f
+(.des)g(and)g(.l\014)88 4965 y Fn(-)47 b(Verbosity)e(level)i(?)88
+5078 y Fm(5)88 5191 y Fn(-)g(File)g(2D)g(\(xz\):)94 b(L2D=T)46
+b(or)h(F)h(?)88 5304 y Fm(F)88 5417 y Fn(-)f(Vertical)f(grid:)94
+b(type)46 b(K,Z)h(or)g(P)h(?)88 5530 y Fm(Z)88 5643 y
+Fn(-)f(Type)g(of)g(vertical)e(grid:)94 b(given)47 b(by)g(linear)f
+(FUNCTN)g(\(default\))f(or)j(MANUALly)d(?)1929 5941 y
+Fu(19)p eop end
+%%Page: 20 20
+TeXDict begin 20 19 bop 88 123 a Fm(FUNCTN)88 236 y Fn(-)47
+b(Vertical)f(grid:)94 b(min,)46 b(max,)h(int)g(\(m)g(for)g(Z,)g(hPa)g
+(for)g(P\)?)88 349 y Fm(1500)34 b(9000)g(3000)88 461
+y Fn(-)47 b(Enter)f(3D)i(variables)d(to)i(CONVERT)f(\(1/1)g(line,)h
+(end)g(by)g(END\):)88 574 y Fm(THM)88 687 y Fn(-)g(next)g(3D)g(field)f
+(or)h(END)g(?)88 800 y Fm(PO)n(V)n(OM)88 913 y Fn(-)g(next)g(3D)g
+(field)f(or)h(END)g(?)88 1026 y Fm(END)88 1139 y Fn(-)g(Enter)f(2D)i
+(variables)d(to)i(CONVERT)f(\(1/1)g(line,)h(end)g(by)g(END\):)88
+1252 y Fm(ZS)88 1365 y Fn(-)g(next)g(2D)g(field)f(or)h(END)g(?)88
+1478 y Fm(END)88 1591 y Fn(2)g(fields)f(\(3D\),)g(and)h(1)h(fields)e
+(\(2D\))h(written)e(in)j(CEXP.1.CSEG.001d.V5D)88 1951
+y Fv(6.2.5)112 b(CONVLFI)37 b(program)88 2123 y Fc(The)32
+b(MesoNH)j(program)e Fb(CONVLFI)e Fc(allo)m(ws)k(con)m(v)m(ersion)f(on)
+m(to)h(GRIB)f(\(the)f(horizon)m(tal)i(grid)e(is)h(either)88
+2236 y(the)24 b(nativ)m(e)i(MesoNH)g(grid)e(\(Arak)-5
+b(a)m(w)m(a)26 b(C-grid\))f(of)f(the)h(\014eld,)g(the)g(MesoNH)g(mass)g
+(grid)f(\(Arak)-5 b(a)m(w)m(a)26 b(A-grid\),)88 2349
+y(the)32 b(v)m(ertical)i(grid)d(is)h(either)h(the)f(nativ)m(e)h(K)f
+(lev)m(els)h(or)f(pressure)f(lev)m(els\),)j(or)e(con)m(v)m(ersion)h(on)
+m(to)g(Vis5D)g(\(the)88 2461 y(horizon)m(tal)e(grid)f(is)g(the)g
+(MesoNH)i(mass)e(grid)f(\(A-grid\),)j(the)e(v)m(ertical)i(grid)e(is)g
+(either)g(the)g(nativ)m(e)i(K)d(lev)m(els)88 2574 y(without)h(orograph)
+m(y)-8 b(,)31 b(altitude)h(or)e(pressure)f(lev)m(els\).)234
+2687 y(The)23 b(con)m(v)m(ersion)j(is)e(done)f(with)h(the)g(Meso{NH)i
+(pro)s(cedure)d Fb(prepmo)s(del)h Fc(used)f(with)h(the)g
+Fb(CONVLFI)88 2800 y Fc(program)30 b(and)g(the)g Fn(CONVLFI1.nam)d
+Fc(namelist)32 b(\014le.)41 b(Up)30 b(to)h(24)g(FM)g(\014les)g(can)g(b)
+s(e)f(treated)h(iden)m(tically)h(in)f(a)88 2913 y(single)g(prepmo)s
+(del)e(job.)234 3139 y(A\))21 b(In)e(the)i(\014le)g Fb(prepmo)s(delrc)p
+745 3170 574 4 v 1 w Fc(,)h(the)f(input)e(and)h(output)g(host,)j
+(directories)e(and)f(login)i(con)m(trol)f(v)-5 b(ariables)88
+3252 y(refer)30 b(to)h(the)f(input)g(and)g(output)g(\014les)g(as)h
+(usual.)40 b(The)30 b(other)h(con)m(trol)g(v)-5 b(ariables)31
+b(to)h(initialize)g(sp)s(eci\014cally)88 3365 y(in)e(this)g(\014le)g
+(are:)237 3552 y Fa(\017)49 b Fc(MAINPR)m(OG=CONVLFI)237
+3740 y Fa(\017)g Fc(LO)m(AD)p 598 3740 28 4 v 34 w(OPT='lo)s(cation)p
+1241 3740 V 33 w(of)p 1347 3740 V 33 w(v5d)p 1524 3740
+V 33 w(library')237 3928 y Fa(\017)g Fc(OUTHOST=name)p
+1080 3928 V 32 w(w)m(orkstation)31 b(\(for)g(example\))331
+4041 y(this)g(allo)m(ws)g(future)f(use)g(of)g Fn(vis5d)f
+Fc(or)i Fn(metview)d Fc(on)i(y)m(our)h(lo)s(cal)g(host.)234
+4228 y(B\))k(In)e(the)h Fn(CONVLFI1.nam)p 645 4241 573
+4 v 31 w Fc(namelist)h(\014le,)h(the)e(user)f(m)m(ust)h(indicate)i(the)
+e(format)g(t)m(yp)s(e)h(w)m(an)m(ted,)h(the)88 4341 y(n)m(um)m(b)s(er)
+31 b(and)g(t)m(yp)s(e)i(of)f(v)m(ertical)j(lev)m(els,)f(the)f(t)m(yp)s
+(e)f(of)h(horizon)m(tal)h(in)m(terp)s(olation)g(on)e(a)h(lat/lon)h
+(domain)e(as)88 4454 y(w)m(ell)f(as)g(the)f(name)h(of)f(the)h(v)-5
+b(ariables)31 b(to)g(write)f(in)m(to)i(the)e(output)g(\014le:)212
+4642 y(1.)49 b(Namelist)32 b(NAM)p 937 4642 28 4 v 34
+w(OUTFILE)p 331 4655 1050 4 v -1 w(:)1929 5941 y Fu(20)p
+eop end
+%%Page: 21 21
+TeXDict begin 21 20 bop 331 26 3609 4 v 329 139 4 113
+v 381 105 a Fc(F)-8 b(ortran)31 b(name)p 1168 139 V 297
+w(F)-8 b(ortran)31 b(t)m(yp)s(e)p 2355 139 V 682 w(default)g(v)-5
+b(alue)p 3938 139 V 331 143 3609 4 v 331 159 V 329 272
+4 113 v 381 238 a(CMNHFILE)p 1168 272 V 343 w(arra)m(y)30
+b(of)h(c)m(haracter)h(\(len=28\))p 2355 272 V 101 w(none)p
+3938 272 V 329 385 V 381 351 a(COUTFILETYPE)p 1168 385
+V 99 w(c)m(haracter)f(\(len=3\))p 2355 385 V 488 w(none)p
+3938 385 V 329 498 V 381 464 a(NVERB)p 1168 498 V 510
+w(in)m(teger)p 2355 498 V 917 w(5)p 3938 498 V 329 611
+V 381 577 a(LA)m(GRID)p 1168 611 V 477 w(logical)p 2355
+611 V 936 w(.TR)m(UE.)p 3938 611 V 329 724 V 381 690
+a(CLEVTYPE)p 1168 724 V 328 w(c)m(haracter)g(\(len=1\))p
+2355 724 V 488 w('P')g(if)f(COUTFILETYPE='GRB')p 3938
+724 V 329 837 V 1168 837 V 2355 837 V 2406 803 a('K')h(if)f
+(COUTFILETYPE='V5D')p 3938 837 V 329 950 V 381 916 a(CLEVLIST)p
+1168 950 V 379 w(c)m(haracter)h(\(len=6\))p 2355 950
+V 488 w('FUNCTN')p 3938 950 V 329 1063 V 381 1029 a(XVLMIN)p
+1168 1063 V 462 w(real)p 2355 1063 V 1040 w(10000.)43
+b(if)30 b(COUTFILETYPE='GRB')p 3938 1063 V 329 1175 V
+381 1142 a(XVLMAX)p 1168 1175 V 427 w(real)p 2355 1175
+V 1040 w(100000.)43 b(if)31 b(COUTFILETYPE='GRB')p 3938
+1175 V 329 1288 V 381 1255 a(XVLINT)p 1168 1288 V 479
+w(real)p 2355 1288 V 1040 w(10000.)43 b(if)30 b(COUTFILETYPE='GRB')p
+3938 1288 V 329 1401 V 381 1367 a(LLMUL)-8 b(TI)p 1168
+1401 V 426 w(logical)p 2355 1401 V 936 w(.TR)m(UE.)p
+3938 1401 V 331 1405 3609 4 v 452 1585 a Fa(\017)49 b
+Fc(CMNHFILE:)28 b(name)g(of)h(the)f(input)f(FM)h(\014le)g(\(from)g(an)g
+(initialization)j(sequence,)e(or)f(a)g(mo)s(del)546 1698
+y(sim)m(ulation,)k(or)e(after)h(diagnostics)h(computation\).)452
+1852 y Fa(\017)49 b Fc(COUTFILETYPE:)24 b(t)m(yp)s(e)h(of)g(the)g
+(output)g(\014le,)h(app)s(ended)e(to)h(CMNHFILE)h(to)f(generate)i(the)
+546 1965 y(name)j(of)h(the)g(output)f(\014le.)627 2120
+y Fb({)49 b Fc('V5D')627 2253 y Fb({)g Fc('GRB')452 2408
+y Fa(\017)g Fc(NVERB:)31 b(v)m(erb)s(osit)m(y)g(lev)m(el)627
+2562 y Fb({)49 b Fc(0)31 b(for)f(minim)m(um)g(of)g(prin)m(ts)627
+2696 y Fb({)49 b Fc(5)31 b(for)f(in)m(termediate)i(lev)m(el)g(of)f
+(prin)m(ts)627 2829 y Fb({)49 b Fc(10)32 b(for)e(maxim)m(um)g(of)h
+(prin)m(ts.)452 2984 y Fa(\017)49 b Fc(LA)m(GRID:)32
+b(switc)m(h)e(to)i(in)m(terp)s(olate)f(\014elds)f(on)g(an)h(Arak)-5
+b(a)m(w)m(a)32 b(A-grid)e(\(mass)h(grid\),)712 3117 y(forced)g(to)g
+(.TR)m(UE.)g(if)f(Vis5D)h(\014le)g(or)f(horizon)m(tal)i(in)m(terp)s
+(olation.)452 3272 y Fa(\017)49 b Fc(CLEVTYPE:)30 b(t)m(yp)s(e)g(of)h
+(v)m(ertical)h(lev)m(els)g(in)e(output)g(\014le,)627
+3426 y Fb({)49 b Fc('P')31 b(pressure)e(lev)m(els)627
+3560 y Fb({)49 b Fc('Z')31 b(z)g(lev)m(els)g(\(only)g(used)f(for)g
+(COUTFILETYPE='V5D'\))627 3694 y Fb({)49 b Fc('K')895
+3807 y(if)22 b(COUTFILETYPE='GRB':)g(nativ)m(e)i(v)m(ertical)g(grid)f
+(of)f(Meso-NH)i(\(no)f(in)m(terp)s(ola-)728 3919 y(tion,)j(heigh)m(t)d
+(sp)s(eci\014ed)f(in)h(GRIB)g(message)h(is)f(the)g(one)g(of)g(the)g
+(grid)f(without)h(orograph)m(y\),)895 4032 y(if)44 b
+(COUTFILETYPE='V5D':)g(nativ)m(e)i(v)m(ertical)h(grid)d(of)g(Meso-NH)i
+(\(\014elds)f(are)728 4145 y(in)m(terp)s(olated)32 b(on)e(the)h(lev)m
+(els)h(of)e(the)h(lo)m(w)m(est)h(p)s(oin)m(t)e(of)h(the)f(domain\).)452
+4300 y Fa(\017)49 b Fc(CLEVLIST:)29 b(ho)m(w)h(v)m(ertical)j(lev)m(els)
+f(are)f(sp)s(eci\014ed)627 4454 y Fb({)49 b Fc('MANUAL')32
+b(n)m(um)m(b)s(er)d(and)h(list)h(of)g(lev)m(els)g(sp)s(eci\014ed)f(in)g
+(the)h(1)2903 4421 y Fh(st)2996 4454 y Fc(free-format)g(part,)627
+4588 y Fb({)49 b Fc('FUNCTN')31 b(using)f(a)h(linear)g(function,)f
+(with)g(the)h(next)f(3)h(parameters.)452 4742 y Fa(\017)49
+b Fc(XVLMIN:)31 b(minim)m(um)f(v)-5 b(alue)31 b(for)f(the)g(v)m
+(ertical)j(grid)712 4876 y(\(in)e(m)f(for)g(CLEVTYPE)f(=)h('Z',)h(in)f
+(P)m(a)h(for)f(CLEVTYPE)f(=)h('P'\),)452 5030 y Fa(\017)49
+b Fc(XVLMAX:)31 b(maxim)m(um)g(v)-5 b(alue)31 b(for)f(the)g(v)m
+(ertical)j(grid)d(\(`'\),)452 5185 y Fa(\017)49 b Fc(XVLINT:)30
+b(incremen)m(t)h(v)-5 b(alue)31 b(for)f(the)h(v)m(ertical)h(grid)f
+(\(`'\).)452 5339 y Fa(\017)49 b Fc(LLMUL)-8 b(TI:)28
+b(switc)m(h)g(to)h(pro)s(duce)d(a)j(m)m(ultigrib)f(\014le)g(\(.T.\))g
+(or)g(monogrib)g(\014les)g(\(.F.\),)i(only)e(used)546
+5452 y(for)h(COUTFILETYPE='GRB')f(\(eac)m(h)j(monogrib)e(\014le)g(name)
+g(is)g(comp)s(osed)g(with)g(the)g(date,)546 5565 y(the)i(v)-5
+b(ariable)31 b(name)f(and)g(the)h(lev)m(el\).)1929 5941
+y Fu(21)p eop end
+%%Page: 22 22
+TeXDict begin 22 21 bop 212 123 a Fc(2.)49 b(F)-8 b(ree-format)33
+b(part)p 331 154 662 4 v(:)40 b(\(n)m(um)m(b)s(er)30
+b(and)f(list)i(of)g(v)m(ertical)h(lev)m(els\))331 236
+y(This)e(part)g(is)h(only)f(used)g(if)g(CLEVLIST='MANUAL':)381
+424 y(\(a\))50 b(\014rst)30 b(the)g(n)m(um)m(b)s(er)f(of)i(v)m(ertical)
+h(lev)m(els,)376 575 y(\(b\))49 b(then)30 b(the)g(list)g(of)g(lev)m
+(els,)i(b)m(y)e(increasing)g(v)-5 b(alues)30 b(in)g(m)f(if)h(CLEVTYPE)f
+(=)g('Z',)h(or)g(decreasing)546 688 y(v)-5 b(alues)31
+b(in)f(P)m(a)h(if)f(CLEVTYPE)g(=)g('P')212 876 y(3.)49
+b(F)-8 b(ree-format)33 b(part)p 331 907 V(:)49 b(\(v)-5
+b(ariable)35 b(names\))g(This)f(part)g(indicates)i(the)f(record)f(name)
+h(of)g(the)f(v)-5 b(ariables)331 989 y(of)31 b(the)g(input)e(\014le)h
+(to)i(write)e(in)g(the)h(output)f(\014le.)41 b(It)30
+b(is)g(sp)s(eci\014ed)g(in)g(t)m(w)m(o)i(parts:)381 1177
+y(\(a\))50 b(b)s(et)m(w)m(een)27 b(the)f(k)m(eyw)m(ords)g(BEGIN)p
+1738 1177 28 4 v 33 w(3D)h(and)e(END)p 2283 1177 V 33
+w(3D:)i(the)f(name)g(of)g(the)g(3D)h(\014elds,)g(follo)m(wing)546
+1290 y(b)m(y)j(their)h(grib)f(co)s(de)g(if)h(COUTFILETYPE='GRB')f
+(\(separed)g(b)m(y)g(tabular)h(c)m(haracter\).)376 1440
+y(\(b\))49 b(b)s(et)m(w)m(een)34 b(the)g(k)m(eyw)m(ords)g(BEGIN)p
+1761 1440 V 33 w(2D)g(and)f(END)p 2321 1440 V 33 w(2D:)i(the)e(name)h
+(of)g(the)f(2D)i(\014elds,)e(follo)m(w-)546 1553 y(ing)j(b)m(y)g(their)
+g(grib)f(co)s(de,)j(and)d(p)s(ossibly)g(lev)m(el)j(indicator)f(and)e
+(lev)m(el)j(v)-5 b(alue)36 b(if)g(COUTFILE-)546 1666
+y(TYPE='GRB')31 b(\(separed)f(b)m(y)g(tabular)h(c)m(haracter\).)331
+1854 y Fb(N.B.:)41 b Fc(do)30 b(not)h(forget)g(the)g(commen)m(t)g(line)
+g(after)g(the)g(k)m(eyw)m(ord)f(BEGIN)p 2916 1854 V 34
+w(3D)h(and)f(BEGIN)p 3570 1854 V 33 w(2D.)234 2033 y(C\))g(Example)h
+(of)f(namelist)h(\014le)g(CONVLFI1.nam)p 234 2069 1788
+4 v 237 2212 a Fa(\017)49 b Fc(to)32 b(con)m(v)m(ert)g(in)m(to)f(a)g
+(Vis5d)f(\014le:)88 2418 y Fn(&NAM_OUTFILE)92 b
+(CMNHFILE\(1\)='T1E20.2.09)o(B24.)o(002')o(,)756 2531
+y(CMNHFILE\(2\)='T1E20.2.09)o(B24.)o(003')o(,)756 2644
+y(COUTFILETYPE='V5D',)756 2757 y(CLEVTYPE='Z',)44 b(CLEVLIST='MANUAL',)
+756 2870 y(LAGRID=T,)h(NVERB=10)h(/)88 2983 y(15)88 3095
+y(30.)88 3208 y(100.)88 3321 y(250.)88 3434 y(500.)88
+3547 y(1000.)88 3660 y(1500.)88 3773 y(2000.)88 3886
+y(2500.)88 3999 y(3000.)88 4112 y(3500.)88 4225 y(4000.)88
+4337 y(4500.)88 4450 y(5000.)88 4563 y(6000.)88 4676
+y(8000.)88 4902 y(BEGIN_3D)88 5015 y(#variables)f(3D)i(\(MesoNH)f
+(field)g(name\))88 5128 y(UM)88 5241 y(VM)88 5354 y(WM)88
+5467 y(THM)88 5580 y(END_3D)88 5692 y(BEGIN_2D)1929 5941
+y Fu(22)p eop end
+%%Page: 23 23
+TeXDict begin 23 22 bop 88 123 a Fn(#variables)45 b(2D)i(\(MesoNH)f
+(field)g(name\))88 236 y(ZS)88 349 y(END_2D)237 569 y
+Fa(\017)j Fc(to)32 b(con)m(v)m(ert)g(in)m(to)f(a)g(GRIB)f(\014le:)88
+790 y Fn(&NAM_OUTFILE)92 b(CMNHFILE\(1\)='T1E20.2.09)o(B24.)o(002')o(,)
+756 903 y(CMNHFILE\(2\)='T1E20.2.09)o(B24.)o(003')o(,)756
+1016 y(COUTFILETYPE='GRB',)756 1129 y(CLEVTYPE='P',)44
+b(CLEVLIST='FUNCTN',)756 1242 y(XVLMAX=100000.,)f(XVLMIN=10000.,)h
+(XVLINT=10000.,)756 1355 y(LAGRID=T,)h(NVERB=5)h(/)88
+1581 y(BEGIN_3D)88 1694 y(#variables)f(3D)i(\(MesoNH)f(field)g(name,)g
+(grib)h(parameter)e(indicator\))88 1806 y(UM)94 b(33)88
+1919 y(VM)g(34)88 2032 y(WM)g(40)88 2145 y(THM)46 b(13)88
+2258 y(END_3D)88 2371 y(BEGIN_2D)88 2484 y(#variables)f(2D)i(\(MesoNH)f
+(field)g(name,)g(grib)h(parameter)e(indicator\))88 2597
+y(ZS)i(8)88 2710 y(END_2D)88 2823 y(next)f(lines)h(are)f(ignored)88
+2936 y(codes)g(example:)88 3048 y(MSLP)189 b(1)88 3161
+y(ACPRR)141 b(61)88 3274 y(INPRR)g(59)88 3387 y(PABSM)g(1)88
+3500 y(ALT)46 b(6)88 3613 y(TEMP)189 b(11)88 3726 y(REHU)g(52)88
+3839 y(RVM)46 b(53)88 3952 y(RCM)g(153)88 4065 y(RRM)g(170)88
+4178 y(RIM)g(178)88 4290 y(RSM)g(171)88 4403 y(RGM)g(179)88
+4516 y(RHM)g(226)88 4629 y(RARE)189 b(230)88 4742 y(HHRE)g(231)88
+4855 y(VVRE)g(232)88 4968 y(VDOP)g(233)88 5081 y(POVOM)141
+b(234)88 5370 y Fs(6.3)135 b(Short)45 b(description)g(of)g(the)g
+(program)88 5554 y Fu(Tw)m(o)33 b(main)g(tasks)h(are)e(p)s(erformed)h
+(b)m(y)h(the)f(program:)1929 5941 y(23)p eop end
+%%Page: 24 24
+TeXDict begin 24 23 bop 207 123 a Fu(1.)214 b(After)24
+b(the)f(sp)s(eci\014cation)i(of)d(the)i(name)f(of)g(the)h(input)f
+(\014le,)j(a)d(`ligh)m(t')g(initialization)h(subrou-)331
+243 y(tine)34 b Ft(init)p 737 243 31 4 v 38 w(for)p 928
+243 V 38 w(convlfi.f90)87 b Fu(is)34 b(called)g(to)f(initialize)i(the)f
+(I/O)f(in)m(terface,)h(the)g(geometry)-8 b(,)331 364
+y(dimensions,)35 b(grids,)e(metric)h(co)s(e\016cien)m(ts,)h(times,)e
+(and)g(to)f(read)h(pressure)i(\014eld.)497 524 y(According)24
+b(the)f(output)g(grids)h(c)m(ho)s(osen,)i(extra)d(arra)m(ys)g(are)g
+(allo)s(cated)g(for)f(in)m(terp)s(olations.)207 726 y(2.)48
+b(Then)34 b(\014elds)g(are)f(treated)g(one)f(after)h(another:)43
+b(\014rst)33 b(3D)f(\014elds,)i(then)f(2D)f(\014elds.)497
+887 y(In)42 b(the)g(case)g(of)f(GRIB)g(con)m(v)m(ersion,)46
+b(\014elds)c(are)g(in)m(terp)s(olated)g(and)f(written)i(one)e(after)331
+1007 y(another)c(\(subroutine)h Ft(code)p 1428 1007 V
+38 w(and)p 1619 1007 V 38 w(write)p 1912 1007 V 38 w(grib.f90)90
+b Fu(called)38 b(for)e(eac)m(h)i(horizon)m(tal)f(lev)m(el)i(of)331
+1127 y(eac)m(h)34 b(\014eld\).)497 1288 y(F)-8 b(or)22
+b(Vis5D)g(con)m(v)m(ersion,)27 b(\014elds)c(are)g(in)m(terp)s(olated)g
+(and)f(written)h(all)f(together)h(\(subroutine)331 1409
+y Ft(code)p 541 1409 V 38 w(and)p 732 1409 V 38 w(write)p
+1025 1409 V 38 w(vis5d.f90)87 b Fu(called)33 b(at)f(the)h(end\).)88
+1606 y(Using)j(a)f(`ligh)m(t')i(initialization)f(routine)g(and)g
+(reading)g(\014elds)h(name)f(from)g(standard)g(input)g(allo)m(ws)88
+1726 y(the)d(con)m(v)m(ersion)h(program)f(not)f(to)g(b)s(e)h(dep)s
+(endan)m(t)h(of)e(a)g(MesoNH)i(v)m(ersion)g(or)e(program.)88
+2014 y Fs(6.4)135 b(Some)45 b(tips)g(to)h(use)f(Vis5D)88
+2199 y Fu(See)33 b(the)g(complete)h(guide)f(for)f(using)h(Vis5D:)g
+(\014le)g(README.ps)h(in)f(the)g(Vis5D)f(pac)m(k)-5 b(age.)88
+2457 y Fv(6.4.1)112 b(Utilities)88 2642 y Fu(\(section)33
+b(5)g(of)f(README.ps\))233 2839 y Fp(\017)48 b Ft(v5dinfo)54
+b(filename)p Fu(:)45 b(sho)m(ws)35 b(summary)f(of)e(the)h(v5d)g
+(\014le:)44 b(n)m(um)m(b)s(er)34 b(and)f(name)g(of)g(the)g(v)-5
+b(ari-)331 2960 y(ables,)31 b(size)g(of)e(the)h(3-D)e(grid,)i(n)m(um)m
+(b)s(er)h(of)e(time)h(steps,)i(v)m(ertical)e(grid)g(de\014nition)g(and)
+g(pro)5 b(jec-)331 3080 y(tion)33 b(de\014nition.)233
+3281 y Fp(\017)48 b Ft(v5dstats)54 b(filename)p Fu(:)64
+b(sho)m(ws)44 b(statistics)f(of)f(the)g(v5d)h(\014le:)63
+b(minim)m(um)43 b(v)-5 b(alue,)45 b(maxim)m(um)331 3402
+y(v)-5 b(alue,)34 b(mean)f(v)-5 b(alue,)33 b(standard)g(deviation)g(of)
+f(eac)m(h)i(v)-5 b(ariable.)233 3603 y Fp(\017)48 b Ft(v5dedit)54
+b(filename)p Fu(:)40 b(edits)23 b(the)g(header)g(of)f(the)h(v5d)f
+(\014le)h(and)g(allo)m(ws)g(to)f(c)m(hange)h(it:)38 b(v)-5
+b(ariables)331 3723 y(names,)33 b(v)-5 b(ariables)32
+b(units,)h(times)g(and)e(dates,)i(pro)5 b(jection,)32
+b(v)m(ertical)h(co)s(ordinate)f(system,)h(lo)m(w)331
+3844 y(lev)m(els.)331 3964 y Fe(Useful)j(to)f(set)g(the)f(variable's)g
+(units)h(sinc)-5 b(e)34 b(they)h(ar)-5 b(e)35 b(not)g(set)g(by)g(the)g
+(pr)-5 b(o)g(gr)g(am)34 b(CONVLFI.)233 4166 y Fp(\017)48
+b Ft(v5dappend)54 b([-var])f(filename1)h(...)103 b(targetfile)p
+Fu(:)55 b(joins)38 b(v5d)f(\014les)h(together:)53 b Fe(useful)331
+4286 y(sinc)-5 b(e)36 b(the)g Fv(prepmo)s(del)i Fe(job)e(gener)-5
+b(ates)36 b(a)g(sep)-5 b(ar)g(ate)36 b(v5d)f(\014le)h(for)g(e)-5
+b(ach)36 b(timestep)p Fu(,)e Ft(var)h Fu(indi-)331 4406
+y(cates)d(list)e(of)g(v)-5 b(ariables)31 b(to)f(omit)h(in)f(the)h
+(target)f(\014le,)i(the)e(dimensions)j(of)d(3-D)f(grids)h(m)m(ust)i(b)s
+(e)331 4527 y(the)h(same)h(in)f(eac)m(h)g(input)g(\014le.)88
+4785 y Fv(6.4.2)112 b(Options)88 4970 y Fu(\(section)33
+b(6.1)f(of)g(README.ps\))234 5211 y(T)-8 b(o)33 b(call)f(Vis5D:)h
+Ft(vis5d)53 b(file1)f([options])i(file2)e([options])i(...)88
+5331 y Fu(Options)32 b(can)g(b)s(e)g(b)s(e)g(sp)s(eci\014ed)h(here)g
+(when)g(calling,)f(or)f(b)m(y)i(pressing)g(the)f Ff(DISPLA)-8
+b(Y)32 b Fu(button)g(of)g(the)88 5452 y(main)g(con)m(trol)h(panel)g
+(and)g(then)g(the)g('Options')h(men)m(u.)234 5572 y(Options)f(useful)h
+(to)e(set)h(when)h(calling:)88 5692 y Ft([-date])g Fu(use)f('dd)g(mon)m
+(th)h(yy')f(instead)h(of)e(julian)h('yyddd')h(date,)1929
+5941 y(24)p eop end
+%%Page: 25 25
+TeXDict begin 25 24 bop 88 123 a Ft([-box)52 b(x)g(y)f(z])33
+b Fu(sp)s(ecify)h(the)f(asp)s(ect)h(ratio)e(of)g(the)h(3-D)e(b)s(o)m(x)
+i(\(default)g(is)g(2)f(2)g(1\),)88 243 y Ft([-mbs)52
+b(n])43 b Fu(o)m(v)m(erride)g(the)f(assumed)i(system)g(memory)f(size)g
+(of)f(32)f(megab)m(ytes)j(\(Vis5D)e(tells)g(y)m(ou)88
+364 y(v)-5 b(alue)33 b(to)f(sp)s(ecify)i(if)e(not)h(enough\),)88
+484 y Ft([-topo)52 b(file])34 b Fu(use)g(a)e(top)s(ograph)m(y)h(\014le)
+g(other)g(than)f(the)h(default)g(EAR)-8 b(TH.TOPO)88
+744 y Fv(6.4.3)112 b(Con)m(trol)37 b(panel)88 928 y Fu(\(section)c(6.2)
+f(of)g(README.ps\))88 1049 y(The)h(top)g(buttons)g(con)m(trol)g
+(primary)g(functions)g(of)f(Vis5D)h(\(see)h(section)f(6.4.3\).)88
+1169 y(The)g(middle)h(ones)f(con)m(trol)g(the)g(viewing)h(mo)s(des)f
+(\(see)h(section)g(6.4.3\).)88 1290 y(The)43 b(b)s(ottom)e(2-D)g
+(matrix)i(of)f(buttons)h(con)m(tains)g(ph)m(ysical)h(v)-5
+b(ariables)43 b(on)f(the)h(ro)m(ws,)i(and)e(t)m(yp)s(es)88
+1410 y(of)38 b(graphic)i(represen)m(tation)h(on)e(the)h(columns.)65
+b(T)-8 b(o)39 b(con)m(trol)h(an)m(y)g(t)m(yp)s(e)g(of)f(graphic,)i
+(clic)m(k)g(on)f(the)88 1530 y(button)h(with)g(the)g(left)g(mouse)h
+(button.)68 b(A)41 b(p)s(op-up)g(windo)m(w)h(app)s(ears)f(when)h(clic)m
+(king)g(with)g(the)88 1651 y(middle)28 b(mouse)h(button,)g(and)f(one)g
+(windo)m(w)h(to)e(mo)s(dify)h(colors)g(with)g(the)g(righ)m(t)g(button)g
+(\(see)h(section)88 1771 y(6.4.3\).)234 2012 y Fv(Primary)38
+b(functions)p 234 2044 890 4 v 33 w Fu(\(section)c(6.3)e(of)g
+(README.ps\))233 2215 y Fp(\017)48 b Ff(SA)-11 b(VE)39
+b(PIC)f Fu(to)f(sa)m(v)m(e)i(the)g(image)e(in)h(a)g(\014le:)54
+b(\014rst)38 b(toggle)f(the)i Ff(REVERSE)f Fu(button)g(to)f(rev)m(erse)
+331 2336 y(blac)m(k)47 b(and)f(white,)k(then)c(toggle)g(the)g
+Ff(SA)-11 b(VE)47 b(PIC)e Fu(button)h(and)g(c)m(ho)s(ose)h
+Ft(xwd)f Fu(\(X)g(Windo)m(w)331 2456 y(Dump\))g(format.)83
+b(The)46 b(\014le)h(can)f(b)s(e)f(visualised)j(with)f
+Ft(xv)f Fu(utilit)m(y)h(and)e(transformed)i(in)m(to)331
+2576 y Ft(postscript)36 b Fu(format.)233 2780 y Fp(\017)48
+b Ff(GRID#s)34 b Fu(to)e(displa)m(y)j(the)f(grid)f(indices)h(instead)h
+(of)d(latitude,)i(longitude)g(and)f(v)m(ertical)h(units)331
+2900 y(along)f(the)g(edges)g(of)f(the)h(b)s(o)m(x.)233
+3104 y Fp(\017)48 b Ff(CONT#s,)34 b(LEGENDS)f Fu(to)f(toggle)h(on)f(or)
+g(o\013)h(the)g(isoline)g(v)-5 b(alues,)34 b(the)f(colorbar)f(legends.)
+233 3307 y Fp(\017)48 b Ff(BO)m(X,)33 b(CLOCK)g Fu(to)g(toggle)f(on)g
+(or)h(o\013)f(the)h(displa)m(y)h(of)e(the)h(b)s(o)m(x)g(and)g(the)g
+(clo)s(c)m(k.)233 3510 y Fp(\017)48 b Ff(TOP)-8 b(,)33
+b(SOUTH,)g(WEST)f Fu(to)g(set)h(a)g(top)f(\(or)g(b)s(ottom\),)h(a)f
+(south)h(\(or)f(north\),)h(a)f(w)m(est)i(\(or)f(east\))331
+3631 y(view.)45 b Fe(Sele)-5 b(ct)32 b Ff(SOUTH)h Fe(to)i(visualise)f
+(2D)h(\014le.)233 3834 y Fp(\017)48 b Ff(SA)-11 b(VE,)43
+b(RESTORE,)d(SCRIPT)g Fu(to)h(sa)m(v)m(e)h(and)f(restore)h(isolines,)i
+(colors,)g(lab)s(els,)f(view)f(\(write)331 3955 y(and)33
+b(read)g(a)f(Tcl)i(script\).)233 4158 y Fp(\017)48 b
+Ff(UVW)36 b(V)-8 b(ARS)35 b Fu(to)g(sp)s(ecify)h(the)f(names)h(of)f
+(the)g(v)-5 b(ariables)35 b(to)g(use)h(to)e(displa)m(y)j(wind)e(slices)
+i(and)331 4278 y(tra)5 b(jectories,)34 b(sev)m(eral)h(triplets)e(of)f
+(v)-5 b(ariables)33 b(can)g(b)s(e)g(used.)233 4482 y
+Fp(\017)48 b Ff(NEW)38 b(V)-8 b(AR..)59 b Fu(to)37 b(duplicate)i(v)-5
+b(ariables)38 b(or)g(create)g(new)g(ones)h(b)m(y)f(sp)s(ecifying)h
+(mathematical)331 4602 y(expressions)j(\(form)m(ulas)e(use)g(names)g
+(of)f(existing)h(v)-5 b(ariables,)42 b(n)m(um)m(b)s(ers,)h(arithmetic)d
+(op)s(era-)331 4723 y(tions,)k(functions)f(suc)m(h)f(as)g
+Fo(S)6 b(QR)q(T)i(;)17 b(E)6 b(X)i(P)s(;)17 b(LO)s(G;)g(S)6
+b(I)i(N)d(;)17 b(C)7 b(O)s(S;)17 b(T)d(AN)5 b(;)17 b(AB)5
+b(S;)17 b(M)10 b(I)e(N)d(;)17 b(M)10 b(AX)e Fu(,)331
+4843 y(ex:)46 b(horizon)m(tal)33 b(wind)h(sp)s(eed,)h
+Fo(spd)28 b Fu(=)h Fo(S)6 b(QR)q(T)14 b Fu(\()p Fo(U)c(M)34
+b Fp(\003)22 b Fo(U)10 b(M)34 b Fu(+)22 b Fo(V)g(M)33
+b Fp(\003)23 b Fo(V)e(M)10 b Fu(\))34 b(see)g(section)h(6.13)331
+4963 y(of)e(README.ps\).)233 5167 y Fp(\017)48 b Ff(ANIMA)-8
+b(TE)29 b Fu(when)h(sev)m(eral)h(time)e(steps:)43 b(left)29
+b(mouse)h(button:)42 b(forw)m(ard,)30 b(righ)m(t)f(button:)41
+b(bac)m(k-)331 5287 y(w)m(ard,)34 b(S)e(k)m(ey:)45 b(slo)m(w)m(er,)35
+b(F)d(k)m(ey:)45 b(faster.)233 5490 y Fp(\017)j Ff(STEP)35
+b Fu(when)g(sev)m(eral)h(time)g(steps:)48 b(left)35 b(mouse)g(button:)
+48 b(one)35 b(step)g(ahead,)g(middle)h(button:)331 5611
+y(\014rst)e(step,)f(righ)m(t)g(button:)44 b(one)32 b(step)i(bac)m(k.)
+1929 5941 y(25)p eop end
+%%Page: 26 26
+TeXDict begin 26 25 bop 233 123 a Fp(\017)48 b Ff(DISPLA)-8
+b(Y)35 b Fu(to)e(c)m(hange)i(the)f(n)m(um)m(b)s(er)i(of)d(displa)m(ys,)
+j(the)f(displa)m(y)g(options)g(\(see)g(section)g(6.4.2\),)331
+243 y(the)e(displa)m(y)i(parameters)e(\(as)g(with)g(the)g
+Ft(v5dedit)h Fu(utilit)m(y\).)234 447 y Fv(Viewing)k(mo)s(des)p
+234 479 745 4 v 33 w Fu(\(section)c(6.4)e(of)g(README.ps\))88
+567 y(The)42 b(underlined)i(mo)s(des)e(are)g(the)g(most)g(useful)h
+(\(the)f(others)g(are)g(m)m(uc)m(h)h(b)s(etter)f(displa)m(y)m(ed)i
+(with)88 687 y Ft(diaprog)34 b Fu(Meso-NH)f(graphics\).)233
+891 y Fp(\017)48 b Ff(No)m(rmal)p 331 904 295 4 v 33
+w Fu(to)33 b(rotate,)f(zo)s(om)g(and)h(translate)g(the)g(graphics)g(in)
+g(the)g(3D)f(windo)m(w.)233 1094 y Fp(\017)48 b Ff(Slice)p
+331 1107 187 4 v 34 w Fu(to)32 b(rep)s(osition)h(horizon)m(tal)g(and)g
+(v)m(ertical)h(slices.)233 1298 y Fp(\017)48 b Ff(Lab)s(el)p
+331 1311 219 4 v 32 w Fu(to)33 b(create)g(and)g(edit)g(text)g(lab)s
+(els)g(in)g(the)g(3D)f(windo)m(w.)233 1501 y Fp(\017)48
+b Ff(Prob)s(e)33 b Fu(to)f(insp)s(ect)i(individual)g(grid)f(v)-5
+b(alues)33 b(with)g(a)g(cursor)g(mo)m(ving)g(through)g(the)g(3D)e
+(grid.)233 1704 y Fp(\017)48 b Ff(Sounding)33 b Fu(to)f(displa)m(y)i(a)
+e(v)m(ertical)i(sounding)g(at)e(the)h(lo)s(cation)f(of)g(the)h(mo)m(v)m
+(eable)i(cursor.)233 1908 y Fp(\017)48 b Ff(Clipping)28
+b Fu(to)f(rep)s(osition)i(the)f(six)g(b)s(ounding)g(planes)h(of)e(the)h
+(3-D)f(b)s(o)m(x.)42 b(Select)29 b(one)f(plane)g(\(top,)331
+2028 y(b)s(ottom,)36 b(north,)g(south,)h(w)m(est)f(or)f(east\))h(with)g
+(the)f(middle)i(mouse)f(button,)g(and)g(rep)s(osition)331
+2148 y(it)d(with)g(the)g(righ)m(t)g(mouse)h(button.)234
+2352 y Fv(T)m(yp)s(es)k(of)g(graphic)g(represen)m(tations)p
+234 2385 1605 4 v 33 w Fu(\(sections)c(6.5)e(to)h(6.9)f(of)g
+(README.ps\))88 2472 y(The)46 b(underlined)g(t)m(yp)s(es)h(are)e(the)g
+(most)h(useful)g(\(the)f(others)h(are)f(m)m(uc)m(h)i(b)s(etter)e
+(displa)m(y)m(ed)i(with)88 2593 y Ft(diaprog)34 b Fu(Meso-NH)f
+(graphics\).)233 2796 y Fp(\017)48 b Ff(Isosurfaces)p
+331 2809 434 4 v 1 w Fu(:)63 b(A)42 b(3-D)e(con)m(tour)j(surface)g(sho)
+m(wing)g(the)f(v)m(olume)i(b)s(ounding)e(b)m(y)h(a)f(particular)331
+2916 y(v)-5 b(alue)25 b(of)f(the)g(\014eld)h(\(set)g(with)g(the)g(left)
+f(mouse)h(button\).)41 b(The)25 b(isosurface)h(is)e(either)h(mono)s
+(color)331 3037 y(or)33 b(colored)g(according)g(to)f(the)h(v)-5
+b(alues)33 b(of)f(another)h(v)-5 b(ariable)33 b(\(righ)m(t)g(mouse)g
+(button\).)233 3240 y Fp(\017)48 b Ff(Slices)p 331 3253
+225 4 v 2 w Fu(:)f(Planar)34 b(cross)i(section)f(\(horizon)m(tally)g
+(or)f(v)m(ertically\))j(can)d(b)s(e)h(mo)m(v)m(ed)h(in)f(this)g(mo)s
+(de.)331 3361 y(T)-8 b(o)30 b(replace)h(geographic)f(co)s(ordinates)g
+(b)m(y)g(grid)g(co)s(ordinates,)h(press)g(the)f Ff("GRID)f(#s")h
+Fu(button)331 3481 y(on)j(the)g(con)m(trol)g(panel.)497
+3643 y(con)m(tour)f(line:)43 b(in)m(terv)-5 b(al)31 b(can)g(b)s(e)g(c)m
+(hanged)h(and)f(min/max)g(v)-5 b(alues)32 b(sp)s(eci\014ed)h(in)e(the)g
+(p)s(op-)331 3763 y(up)i(windo)m(w.)44 b Ft(-10)52 b(\(-30,20\))34
+b Fu(will)f(plot)e(v)-5 b(alues)33 b(b)s(et)m(w)m(een)h(-30)d(and)g(20)
+h(at)f(in)m(terv)-5 b(als)33 b(10)e(with)331 3884 y(negativ)m(e)j(v)-5
+b(alues)34 b(dashed.)44 b(Color)33 b(can)g(b)s(e)g(c)m(hanged)g(with)g
+(the)g(righ)m(t)g(mouse)h(button.)497 4046 y(colored)45
+b(slice:)69 b(colors)45 b(can)f(b)s(e)h(c)m(hanged)h(in)e(the)h(p)s
+(op-up)f(windo)m(w)i(\(with)f(the)g(mouse)331 4166 y(buttons)30
+b(or)f(arro)m(w)h(k)m(eys\).)44 b(Color)30 b(table)f(is)h(displa)m(y)m
+(ed)i(in)d(the)h(3-D)e(windo)m(w)j(if)e(the)h Ff("LEGEND)331
+4286 y(#s")36 b Fu(button)e(is)i(selected.)52 b(T)-8
+b(o)34 b(c)m(hange)i(limits)g(of)e(plotted)h(v)-5 b(alues,)36
+b(use)g(the)f(k)m(eyb)s(oard)h(arra)m(y)331 4407 y(buttons)31
+b(when)f(in)g(the)g(v)-5 b(ariable)30 b(con)m(trol)g(panel)g(\(left)g
+(and)f(righ)m(t)h(for)f(limits)i(in)e(the)h(extend)i(of)331
+4527 y(the)h(v)-5 b(ariable)33 b(v)-5 b(alues,)34 b(up)f(and)f(do)m(wn)
+i(for)e(colors)h(inside)h(it\).)497 4689 y(wind)50 b(v)m(ector)g
+(slice:)76 b(\(buttons)50 b Ff(Hwind1,)j(Vwind1,)g(Hwind2,)g(Vwind2)p
+Fu(\))c(the)g(scale)h(pa-)331 4809 y(rameter)40 b(m)m(ultiplies)i(the)d
+(length)h(of)f(v)m(ectors)i(dra)m(wn)f(\(double:)58 b(2,)41
+b(half:)57 b(0.5\),)40 b(the)g(densit)m(y)331 4930 y(parameter)32
+b(con)m(trols)f(the)g(n)m(um)m(b)s(er)i(of)d(v)m(ectors)i(\(b)s(et)m(w)
+m(een)h(zero)e(and)g(one,)g(0.5)g(for)f(one)h(v)m(ector)331
+5050 y(of)i(t)m(w)m(o,)g(0.25)f(for)g(one)h(of)f(four\).)497
+5212 y(wind)k(stream)f(slice:)48 b(\(buttons)35 b Ff(HStream,)h
+(VStream)p Fu(\))f(the)g(densit)m(y)h(parameter)f(con)m(trols)331
+5332 y(the)e(n)m(um)m(b)s(er)h(of)f(streamlines)h(\(b)s(et)m(w)m(een)h
+(zero)e(and)f(t)m(w)m(o\).)233 5536 y Fp(\017)48 b Ff(V)m(olume)34
+b(rendering)p 331 5568 712 4 v 1 w Fu(:)43 b Fe(for)35
+b(p)-5 b(owerful)34 b(workstations..)1929 5941 y Fu(26)p
+eop end
+%%Page: 27 27
+TeXDict begin 27 26 bop 88 123 a Fv(6.4.4)112 b(Adv)-6
+b(anced)38 b(use)233 307 y Fp(\017)48 b Fu(generate)38
+b(y)m(our)h(o)m(wn)f(top)s(ograph)m(y)f(\014le,)i(with)f(the)g
+Ft(maketopo.c)i Fu(program)d(in)h(the)g Ft(util)g Fu(di-)331
+428 y(rectory)c(\(see)f(5)g(of)f(README.ps\).)233 631
+y Fp(\017)48 b Fu(Tcl)40 b(language,)g(to)f(write)g(script)h(\(button)e
+Ff(SCRIPT)p Fu(\))g(or)h(in)m(teractiv)m(ely)i(\(button)e
+Ff(INTERP)-8 b(..)p Fu(\))331 752 y(\(see)34 b(6.16)e(of)g
+(README.ps\).)233 955 y Fp(\017)48 b Fu(external)30 b(analysis)g
+(functions)g(written)f(in)g(F)-8 b(ortran,)29 b(in)f
+Ft(userfuncs)j Fu(directory)f(\(see)g(6.13.3)e(of)331
+1075 y(README.ps\).)88 1364 y Fs(6.5)135 b(State)46 b(of)f(art)88
+1549 y Fu(The)33 b(con)m(v)m(erter)h(only)f(runs)g(on)f(Lin)m(ux)h(and)
+g(VPP)-8 b(.)33 b(In)g(HP)-8 b(,)32 b(righ)m(t)h(compilation)g(options)
+f(ha)m(v)m(e)i(to)e(b)s(e)88 1669 y(found)g(to)g(use)i(the)f(external)h
+(library)-8 b(...)1929 5941 y(27)p eop end
+%%Trailer
+
+userdict /end-hook known{end-hook}if
+%%EOF
diff --git a/LIBTOOLS/readme/why.conv2dia b/LIBTOOLS/readme/why.conv2dia
new file mode 100644
index 0000000000000000000000000000000000000000..393391bbb2a60830dbccd632db0528f829539bb0
--- /dev/null
+++ b/LIBTOOLS/readme/why.conv2dia
@@ -0,0 +1,52 @@
+Duplication des points de garde dans le cas d'un fichier 1D
+ (indispensable dans le cas 'CART') 20040202
+
+Possibilite de degrader les resolutions horizontales 20040519
+
+Merge de conv2dia.elim et conv2dia.select 20040524
+
+Mise a jour pour le cycle MASDEV4_6 (XLATORI,XLONORI,L1D,L2D,PACK,CSURF, fichier
+type 'SU') 20050117
+
+ex de directives pour tout convertir:
+1
+file1
+file1all
+n # reponse a - DO YOU WANT COARSER RESOLUTION along X ? (y/n)
+n # reponse a - DO YOU WANT COARSER RESOLUTION along Y ? (y/n)
+0 # reponse a - NO DELETION ? (enter 0)
+
+ex de directives pour eliminer l instant M et qq autres champs:
+1
+file1
+file1t
+n
+n
+1 # reponse a - DELETION OF PARAMETERS AT TIME t-dt ? (enter 1)
+e # reponse a - Do you want to ELIM or to SELECT parameters ? (E/S)
+y # reponse a - Do you want to SUPPRESS others parameters ? (y/n)
+LSUM
+LSVM
+LSWM
+LSTHM
+END
+
+ex de directives pour selectionner dans 2 fichiers qq champs avec la moitie de resolution:
+2
+file1
+file2
+files
+y # reponse a - DO YOU WANT COARSER RESOLUTION along X ? (y/n)
+2 # reponse a Enter the ratio IX (1 point on IX points kept)
+y # reponse a - DO YOU WANT COARSER RESOLUTION along Y ? (y/n)
+2 # reponse a Enter the ratio IY (1 point on IY points kept)
+2 # reponse a - DELETION OF PARAMETERS AT TIME t ? (enter 2)
+s # reponse a - Do you want to ELIM or to SELECT parameters ? (E/S)
+y # reponse a - Do you want to KEEP others parameters ? (y/n)
+UM
+VM
+RVM
+END
+
+ les directives sont stockees dans le fichier dirconv
+(et non plus dirconv.elim ou dirconv.select)
diff --git a/LIBTOOLS/readme/why.diaprog b/LIBTOOLS/readme/why.diaprog
new file mode 100644
index 0000000000000000000000000000000000000000..f1a4ea4ef5117277e66211702bc176e4cde4e054
--- /dev/null
+++ b/LIBTOOLS/readme/why.diaprog
@@ -0,0 +1,145 @@
+Nouveautes:
+----------
+
+* les fichiers d'entree de diaprog peuvent etre dans des repertoires autre que
+le repertoire courant. Les noms de ces repertoires sont indiques par des
+variables d'environnement (initialisées et exportées). Ainsi
+ les fichiers .lfi sont (tous) placés dans le repertoire indique par la
+variable DIRLFI
+ les fichiers 'fond de carte' dans celui indique par DIRFDC
+ les fichiers 'table de couleurs' dans celui indique par DIRCOL
+Le programme crée un lien symbolique au moment de l'ouverture du fichier, et le
+detruit a la fin (directive QUIT).
+Si une des 3 variables d'environnement n'est pas initialisée, les fichiers
+correspondants sont cherchés dans le repertoire courant, comme precedemment.
+
+ rq: le nom du fichier de sortie (defaut gmeta) peut etre indique avant l'appel au programme par la variable d'environnement NCARG_GKS_OUTPUT
+
+* NIMNMX=3 permet de definir les isolignes avec
+ XISOREF (ou XISOREF_proc) pour une isoligne
+ XDIAINT (ou XDIAINT_proc) pour l intervalle
+ (les isolignes sont calculees en partant de XISOREF+- XDIAINT jusqu'aux extrema du champ)
+
+* LTRACECV=T permet de representer la trace de la coupe verticale dans les
+coupes horizontales suivantes (il faut demander un tracé dans la coupe verticale
+_CV_ et pas seulement definir la coupe)
+
+* ajout de segments de droite sur un plan horizontal definis en points de grille
+de maniere similaire a XSEGMS, ex.:
+ LSEGM=T
+ ISEGMS=I1,J1,I2,J2,0,0,I3,J3,I4,J4,I5,J5,I6,J6,9999.
+ (les segments sont tracés dans la grille du champ)
+
+* tracé de fichier fond de carte avec NIFDC=2 ou 3
+le fichier ascii contient une serie de lignes lat lon n
+ trait pointillé si n=2(plume levee) et n=3(plume baissee)
+ rappel: trait plein si n=0(plume levee) et n=1(plume baissee)
+
+* DDUMVM (ou DDUTVT ou DDUMVM10 ou avec autres composantes) calcule la
+direction du vent, le trace se fait comme pour n'importe quel autre champ
+scalaire (rappel: trace en etoiles colorees avec DIRUMVM)
+en coupe horizontale 20040202
+en coupe et profil verticaux 20040427
+
+* LMARKER=T (avec LCOLAREA=T et LSPOT=F) permet de tracer les valeurs du champ
+en etoiles colorees (precedemment seulement actif avec _MSKTOP_ )
+(mieux vaut enlever les isolignes avec LISO=F)
+
+* LSPOT=T (avec LCOLAREA=T et LMARKER=F) permet de tracer les valeurs du champ
+en paves de couleur (mieux vaut enlever les isolignes avec LISO=F)
+eventuellement entoures de noir et redimensionnes (question posee)
+exemple de directives:
+NIMNMX=1 pour fixer la palette de couleur
+T2M_file1_ON_
+LSPOT=T
+n
+T2M11H_file2_
+
+* LRADAR (voir message 08092003)
+
+* pour le trace de trajectoires (LXYZ00=T), possibilité de définir la boite
+suivant la verticale a partir de champs lagrangiens autres que les Z00i
+(ex: CGROUPSV3='TH001') les surfaces inferieure et superieure sont toujours
+indiquées par XZL et XZH (tramask3d.f90)
+
+* Avec LFT3C=T ou LFT4C=T , possibilite de representer 3 ou 4 courbes
+ (au lieu de 2 en standard) sur les petits diagrammes obtenus avec les
+ fonctions _FT_ et _PVKT_ ; a condition de representer le meme
+ parametre ou des parametres avec des bornes semblables.
+ (varfct.f90) 20040419
+
+* pour les traces avec _FT_ et _PVKT_ , _FT1_ et _PVKT1_
+ les bornes sont calculees avec le min et le max effectifs avec LFTBAUTO=T ou LFT1BAUTO=T ,
+ ajout d'une constante de temps pour la nieme courbe avec XFT_ADTIMn et XFT1_ADTIMn (n=1 a 8)
+ (varfct.f90 traxy.f90) 20040419
+
+* Possibilite de gerer les valeurs des labels de l'axe des temps
+dans les series temporelles (PXT PYT PVT PVKT FT FT1 ?)
+comme pour les autres graphiques
+avec LFACTAXEX,LFACTAXEY ou LAXEXUSER,LAXEYUSER.
+ (myheurx.f90 varfct.f90) 20040419
+
+* impression de la moyenne du champ (en plus des min et max) avec print gpe MINMAX
+
+* operation LOG sur les parametres lus avec GPE(log) (20050217)
+
+Correction de bugs:
+------------------
+
+* ecriture valeur champ du dernier point de la retro-trajectoire (tratraj3d.f90)
+
+* relecture de l entete du fichier seulement s il est different
+du dernier fichier courant
+
+* la 2e directive est ignoree dans les 2 exemples suivants:
+_file1_'toto'
+_file2_'toto'
+(le fichier toto reste associe a file1)
+et
+_file1_'toto'
+_file1_'tata'
+(file1 fait toujours reference a toto)
+
+* tracé des streamlines réactivé (manquait un fichier source f77)
+
+* en cas de superposition de 2 champs (1: vecteurs et 2: isocontours) avec
+LCOLINE=T, les isolignes sont tracées en couleurs (et non en mono-couleur).
+
+* le fichier pseudo-diachronique issu d'un fichier 1D etant cree avec la
+duplication des points de garde (conv2dia):
+ - tracé de RS possible
+ - pour le PV, defaut pour NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,PROFILE
+ (respectivement a 2,2,2,0,1)
+
+* l interpolation pour les coupes verticales prend en compte les valeurs a
+XSPVAL (coupe_fordiachro.f90) (cas de fichiers issus de obs2mesonh) 20040402
+
+* Introduction des titres et du fond de carte standards pour les traces de
+retro-trajectoires (tratraj3d.f90), lachers (tramask3d.f90), et lignes de
+courant (traflux3d.f90) 20040419
+
+* Correction d un pb de relecture des min et max definis avec XISOMIN_PROC ou
+XISOLEV_PROC quand 2 PROC avaient un prefixe commun (par ex MUMVM et MUMVM10).
+(readmnmxint_iso.f90 et readxisolevp.f90) 20040419
+
+* les min max et loc donnes par PRINT NomGPE MINMAX et LMNMXLOC=T ne prennent
+plus en compte les valeurs XSPVAL (prints.f90) 20040506
+
+* Pour les retro-trajectoires (tratraj3d.f90) et lignes de courant
+(traflux3d.f90): (20050217)
+ - si LCOLINE=F traces en noir,
+ sinon boucle sur les 16 premieres couleurs de la table par defaut.
+ - dans le plan XY, couleurs des etoiles en fonction de l altitude de la part.
+ - impression des positions calculees dans FICVAL si LPRINT=T
+
+* Impression du type d isosurface lu dans CGROUPSV3 (cas LXYZ00) sur 5 car. au
+lieu de 4 (traceh_fordiachro.f90) (20050217)
+
+Autres:
+------
+
+* ecriture des directives dans le fichier dir:jjmmaa:hh sans blancs en fin de ligne
+
+* un seul listing est cree (OUT_DIA) au lieu de d'un OUT_DIAnn par fichier ouvert
+
+
diff --git a/LIBTOOLS/tools/Makefile b/LIBTOOLS/tools/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..49322aa23c338a3895cf93050d6e4eb73b694b4e
--- /dev/null
+++ b/LIBTOOLS/tools/Makefile
@@ -0,0 +1,26 @@
+SUBDIRS = lfiz lfi2cdf diachro fmmore vergrid
+.PHONY: subdirs $(SUBDIRS)
+
+ifndef ARCH
+
+VALID_ARCH=$(subst ../conf/config.,,$(wildcard ../conf/config.*))
+dummy %:
+ @echo "ERROR : ARCH variable is not set !";echo
+ @echo "Please, choose one of these statements then try again :";echo " "
+ @for i in $(VALID_ARCH); do echo export ARCH=$$i; done
+else
+
+subdirs: $(SUBDIRS)
+
+$(SUBDIRS):
+ $(MAKE) -C $@
+
+clean distclean:
+ @for dir in $(SUBDIRS); do \
+ $(MAKE) -C $$dir $@; \
+ done
+
+endif
+
+
+
diff --git a/LIBTOOLS/tools/diachro/Makefile b/LIBTOOLS/tools/diachro/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..979444a469bdeab35f3c3f90fbd670593a5128c3
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Makefile
@@ -0,0 +1,50 @@
+DIR_OBJ= ./$(ARCH)
+
+ifndef ARCH
+VALID_ARCH=$(subst Rules.,,$(wildcard Rules.*))
+dummy %:
+ @echo "Error : ARCH variable is not set ! Valid values are :"
+ @echo $(VALID_ARCH)
+
+else
+PROGALL = conv2dia diaprog extractdia compute_r00_pc obs2mesonh mesonh2obs concat_time_diafile
+include Rules.$(ARCH)
+
+all : $(PROGALL)
+
+#
+# l ordre est a respecter
+#
+conv2dia:
+ $(MAKE) -f Makefile.conv2dia B=64
+ $(MAKE) -f Makefile.conv2dia B=32
+
+diaprog:
+ $(MAKE) -f Makefile.diaprog B=32
+
+extractdia:
+ $(MAKE) -f Makefile.extractdia B=32
+
+
+#exrwdia:
+# $(MAKE) -f Makefile.exrwdia
+compute_r00_pc:
+ $(MAKE) -f Makefile.exrwdia PROG=$@
+obs2mesonh:
+ $(MAKE) -f Makefile.exrwdia PROG=$@
+mesonh2obs:
+ $(MAKE) -f Makefile.exrwdia PROG=$@
+concat_time_diafile:
+ $(MAKE) -f Makefile.exrwdia PROG=$@
+
+
+clean :
+ @for dir in $(DIR_OBJ)_* ; do\
+ (if [ -d $$dir ] ; then cd $$dir; rm -f cpp_*.f90 cpp_*.f *.o *.mod ; fi) \
+ done
+
+distclean :
+ rm -rf $(DIR_OBJ)_*
+
+
+endif
diff --git a/LIBTOOLS/tools/diachro/Makefile.conv2dia b/LIBTOOLS/tools/diachro/Makefile.conv2dia
new file mode 100644
index 0000000000000000000000000000000000000000..cdc27e68e801fe413932b56d73ed5178226a42e2
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Makefile.conv2dia
@@ -0,0 +1,277 @@
+B ?= 64
+DIR_OBJ=./$(ARCH)_$(B)
+
+ifeq ($(strip $(VERSION)),)
+VPATH=src/BUG:src/MOD:src/mesonh_MOD:src/FM2DIA:src/TOOL:src/mesonh:src/FM:$(DIR_OBJ)
+else # string VERSION not empty
+VPATH=src/$(VERSION):src/BUG:src/MOD:src/mesonh_MOD:src/FM2DIA:src/TOOL:src/mesonh:src/FM:$(DIR_OBJ)
+endif
+
+ifeq ($(origin MNH_LIBTOOLS), undefined)
+include ../where.Libs
+else
+include $(MNH_LIBTOOLS)/tools/where.Libs
+endif
+
+
+INC = -I src/FM2DIA -I $(DIR_OBJ)
+
+ifeq ($(VERSION),M45)
+PROG=
+PROG1 = conv2dia.elim
+PROG2 = conv2dia.select
+else
+PROG = conv2dia
+PROG1 =
+PROG2 =
+endif
+
+OBJS = fmattr.o fmclos.o fmfree.o fmlook.o fmopen.o \
+ ini_cst.o jdlfilaf_fuji.o menu_diachro.o modd_conf.o modd_diachro.o \
+ modd_dimgrid_fordiachro.o modd_out_dia.o modd_rea_lfi.o modd_time.o \
+ modd_type_date.o read_dimgridref_fm2dia.o write_othersfields.o \
+ alloc_fordiachro.o elim.o fminit.o fmread.o \
+ fmwrit.o modd_alloc_fordiachro.o modd_cst.o modd_dim1.o \
+ modd_fmdeclar.o modd_fmmulti.o \
+ modd_grid1.o modd_grid.o modd_parameters.o \
+ modd_resolvcar.o modd_time1.o modd_type_and_lh.o read_diachro.o \
+ resolv_units.o set_dim.o set_light_grid.o temporal_dist.o \
+ write_diachro.o write_dimgridref.o fm_read.o fm_writ.o \
+ modd_nesting.o mode_gridcart.o modd_lunit1.o modd_param1.o \
+ mode_gridproj.o write_lfifm1_fordiachro_cv.o vert_coord.o writedir.o \
+
+OBJDIA = fmattr.o fmclos.o fmfree.o fmlook.o fmopen.o \
+ ini_cst.o menu_diachro.o modd_conf.o modd_diachro.o \
+ modd_dimgrid_fordiachro.o modd_out_dia.o modd_rea_lfi.o modd_time.o \
+ modd_type_date.o read_dimgridref_fm2dia.o \
+ alloc_fordiachro.o elim.o fminit.o fmread.o \
+ fmwrit.o modd_alloc_fordiachro.o modd_cst.o modd_dim1.o \
+ modd_fmdeclar.o modd_fmmulti.o \
+ modd_grid1.o modd_grid.o modd_parameters.o \
+ modd_resolvcar.o modd_time1.o modd_type_and_lh.o read_diachro.o \
+ resolv_units.o set_dim.o set_light_grid.o temporal_dist.o \
+ write_diachro.o write_dimgridref.o fm_read.o fm_writ.o \
+ modd_nesting.o mode_gridcart.o modd_lunit1.o modd_param1.o\
+ mode_gridproj.o write_lfifm1_fordiachro_cv.o vert_coord.o writedir.o \
+
+include $(DIR_CONF)/config.$(ARCH)
+include $(MNH_LIBTOOLS)/tools/diachro/Rules.$(ARCH)
+
+
+%.o:%.f90 $(DIR_OBJ)/.dummy
+ $(CPP) $(INC) $(CPPFLAGS) $< > $(DIR_OBJ)/cpp_$(*F).f90
+ $(F90) $(INC) -c $(F90FLAGS) $(DIR_OBJ)/cpp_$(*F).f90 -o $(DIR_OBJ)/$(*F).o
+ -@mv *.mod $(DIR_OBJ)/. 2> /dev/null || echo pas de module dans $*.f90
+
+%.o:%.f $(DIR_OBJ)/.dummy
+ $(CPP) $(INC) $(CPPFLAGS) -Df77 $< > $(DIR_OBJ)/cpp_$(*F).f
+ $(F77) $(INC) -c $(F77FLAGS) $(DIR_OBJ)/cpp_$(*F).f -o $(DIR_OBJ)/$(*F).o
+
+ifeq ($(B),64)
+all: $(PROG1) $(PROG2) $(PROG) $(LIBDIA)
+else
+all: $(LIBDIA)
+endif
+
+$(PROG): $(PROG).o $(OBJS) $(LIBLFI) $(LIBCOMP)
+ cd $(DIR_OBJ);$(F90) $(LDFLAGS) -o $@ $(patsubst $(DIR_OBJ)/%,%,$^) $(LIBS)
+ @echo $@ available under $(DIR_OBJ)
+
+$(PROG1): $(PROG1).o $(OBJS) $(LIBLFI) $(LIBCOMP)
+ cd $(DIR_OBJ);$(F90) $(LDFLAGS) -o $@ $(patsubst $(DIR_OBJ)/%,%,$^) $(LIBS)
+ @echo $@ available under $(DIR_OBJ)
+
+$(PROG2): $(PROG2).o $(OBJS) $(LIBLFI) $(LIBCOMP)
+ cd $(DIR_OBJ);$(F90) $(LDFLAGS) -o $@ $(patsubst $(DIR_OBJ)/%,%,$^) $(LIBS)
+ @echo $@ available under $(DIR_OBJ)
+
+$(DIR_OBJ)/.dummy :
+ mkdir $(DIR_OBJ)
+ @touch $(DIR_OBJ)/.dummy
+
+$(LIBLFI):
+ $(MAKE) -C $(DIR_LFI)
+ #$(MAKE) -C $(DIR_LFI) DIR_CONF=$(DIR_CONF)
+
+$(LIBCOMP):
+ $(MAKE) -C $(DIR_COMP)
+
+
+ifeq ($(strip $(VERSION)),)
+$(LIBDIA): $(OBJDIA)
+ cd $(DIR_OBJ) ; $(AR) rv $@ $(OBJDIA)
+ ls -l $(DIR_OBJ)/$@
+else # string VERSION not empty
+$(LIBDIA): $(OBJDIA)
+ @echo '***' if libxxx_$(VERSION).a does not exist, cp libxxx.a libxxx_$(VERSION).a
+ #ls -l $(DIR_OBJ)/$@
+ cd $(DIR_OBJ) ; $(AR) rv $@ $(OBJDIA)
+ ls -l $(DIR_OBJ)/$@
+endif
+
+
+clean:
+ (if [ -d $(DIR_OBJ) ] ; then cd $(DIR_OBJ); rm -f cpp_*.f90 cpp_*.f *.o *.mod ; fi)
+
+distclean: clean
+ (if [ -d $(DIR_OBJ) ] ; then rm -rf $(DIR_OBJ); fi)
+
+
+# nombre de passe = 1
+conv2dia.o: conv2dia.f90 ini_cst.o \
+ menu_diachro.o modd_conf.o modd_diachro.o modd_dim1.o modd_grid.o \
+ modd_grid1.o modd_dimgrid_fordiachro.o modd_out_dia.o modd_rea_lfi.o \
+ modd_time1.o read_dimgridref_fm2dia.o \
+ write_dimgridref.o write_othersfields.o writedir.o
+
+conv2dia.elim.o: conv2dia.elim.f90 ini_cst.o \
+ menu_diachro.o modd_conf.o modd_diachro.o modd_dim1.o modd_grid.o \
+ modd_grid1.o modd_dimgrid_fordiachro.o modd_out_dia.o modd_rea_lfi.o \
+ modd_time1.o read_dimgridref_fm2dia.o \
+ write_dimgridref.o write_othersfields.o
+
+conv2dia.select.o: conv2dia.select.f90 ini_cst.o \
+ menu_diachro.o modd_conf.o modd_diachro.o modd_dim1.o modd_grid.o \
+ modd_grid1.o modd_dimgrid_fordiachro.o modd_out_dia.o modd_rea_lfi.o \
+ modd_time1.o read_dimgridref_fm2dia.o \
+ write_dimgridref.o write_othersfields.o
+
+# nombre de passe = 2
+fmattr.o: fmattr.f90 modd_fmdeclar.o \
+ modd_fmmulti.o
+
+fmclos.o: fmclos.f90 modd_fmdeclar.o \
+ modd_fmmulti.o
+
+fmfree.o: fmfree.f90 modd_fmdeclar.o \
+ modd_fmmulti.o
+
+fmlook.o: fmlook.f90 modd_fmdeclar.o
+
+fmopen.o: fmopen.f90 modd_fmdeclar.o \
+ modd_fmmulti.o
+
+ini_cst.o: ini_cst.f90 modd_cst.o
+
+jdlfilaf_fuji.o: jdlfilaf_fuji.f
+
+menu_diachro.o: menu_diachro.f90 fmread.o \
+ fmwrit.o modd_out_dia.o
+
+modd_conf.o: modd_conf.f90
+
+modd_diachro.o: modd_diachro.f90
+
+modd_dimgrid_fordiachro.o: modd_dimgrid_fordiachro.f90
+
+modd_out_dia.o: modd_out_dia.f90
+
+modd_rea_lfi.o: modd_rea_lfi.f90
+
+modd_time.o: modd_time.f90 modd_parameters.o \
+ modd_type_date.o
+
+modd_type_date.o: modd_type_date.f90
+
+read_dimgridref_fm2dia.o: read_dimgridref_fm2dia.f90 fmread.o \
+ modd_conf.o modd_diachro.o modd_dim1.o modd_param1.o \
+ modd_grid1.o modd_grid.o modd_out_dia.o \
+ modd_parameters.o modd_rea_lfi.o \
+ modd_time1.o modd_time.o modd_type_date.o set_dim.o \
+ set_light_grid.o
+
+write_othersfields.o: write_othersfields.f90 alloc_fordiachro.o \
+ fmread.o fmwrit.o modd_alloc_fordiachro.o \
+ modd_conf.o modd_diachro.o modd_dim1.o \
+ modd_dimgrid_fordiachro.o modd_grid1.o modd_grid.o \
+ modd_out_dia.o modd_parameters.o \
+ modd_resolvcar.o modd_time1.o \
+ modd_time.o modd_type_and_lh.o modd_type_date.o \
+ read_diachro.o resolv_units.o temporal_dist.o \
+ write_diachro.o
+
+# nombre de passe = 3
+alloc_fordiachro.o: alloc_fordiachro.f90 modd_alloc_fordiachro.o \
+ modd_type_and_lh.o
+
+elim.o: elim.f90 modd_dimgrid_fordiachro.o
+
+fminit.o: fminit.f90 modd_fmdeclar.o
+
+fmread.o: fmread.f90 modd_conf.o modd_fmdeclar.o \
+ modd_type_date.o
+
+fmwrit.o: fmwrit.f90 modd_conf.o \
+ modd_type_date.o
+
+modd_alloc_fordiachro.o: modd_alloc_fordiachro.f90
+
+modd_cst.o: modd_cst.f90
+
+modd_dim1.o: modd_dim1.f90
+
+modd_fmdeclar.o: modd_fmdeclar.f90
+
+modd_fmmulti.o: modd_fmmulti.f90
+
+modd_grid1.o: modd_grid1.f90
+
+modd_grid.o: modd_grid.f90
+
+modd_parameters.o: modd_parameters.f90
+
+modd_resolvcar.o: modd_resolvcar.f90
+
+modd_time1.o: modd_time1.f90 modd_type_date.o
+
+modd_type_and_lh.o: modd_type_and_lh.f90
+
+read_diachro.o: read_diachro.f90 alloc_fordiachro.o \
+ fmread.o modd_alloc_fordiachro.o modd_type_and_lh.o
+
+resolv_units.o: resolv_units.f90 modd_conf.o \
+ modd_resolvcar.o
+
+set_dim.o: set_dim.f90 fmread.o \
+ modd_conf.o modd_parameters.o
+
+set_light_grid.o: set_light_grid.f90 fmread.o \
+ modd_conf.o modd_grid.o modd_time.o \
+ mode_gridcart.o mode_gridproj.o
+
+temporal_dist.o: temporal_dist.f90
+
+write_diachro.o: write_diachro.f90 fmwrit.o \
+ menu_diachro.o
+
+write_dimgridref.o: write_dimgridref.f90 modd_diachro.o \
+ write_lfifm1_fordiachro_cv.o
+
+# nombre de passe = 4
+fm_read.o: fm_read.f90 modd_fmdeclar.o
+
+fm_writ.o: fm_writ.f90 modd_fmdeclar.o
+
+modd_nesting.o: modd_nesting.f90 modd_parameters.o
+
+mode_gridcart.o: mode_gridcart.f90 modd_conf.o \
+ modd_parameters.o vert_coord.o
+
+mode_gridproj.o: mode_gridproj.f90 modd_conf.o \
+ modd_cst.o modd_grid.o modd_lunit1.o \
+ modd_parameters.o vert_coord.o
+
+vert_coord.o: vert_coord.f90
+
+write_lfifm1_fordiachro_cv.o: write_lfifm1_fordiachro_cv.f90 fmread.o \
+ fmwrit.o modd_conf.o \
+ modd_diachro.o modd_dim1.o modd_dimgrid_fordiachro.o \
+ modd_grid1.o modd_grid.o modd_lunit1.o modd_param1.o \
+ modd_nesting.o modd_out_dia.o \
+ modd_parameters.o modd_time1.o \
+ modd_time.o modd_type_date.o
+
+# nombre de passe = 5
+modd_lunit1.o: modd_lunit1.f90 modd_parameters.o
+modd_param1.o: modd_param1.f90
+writedir.o: writedir.f90
diff --git a/LIBTOOLS/tools/diachro/Makefile.diaprog b/LIBTOOLS/tools/diachro/Makefile.diaprog
new file mode 100644
index 0000000000000000000000000000000000000000..4c5f03d5de649b5b10aaefa543bbcf81c79c67c0
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Makefile.diaprog
@@ -0,0 +1,793 @@
+B ?= 32
+DIR_OBJ=./$(ARCH)_$(B)
+
+ifeq ($(strip $(VERSION)),)
+VPATH=src/BUG:src/DIAPRO:src/POS:src/TOOL:src/mesonh:src/FM2DIA:src/FM:src/MOD:src/mesonh_MOD:$(DIR_OBJ):$(DIR_OBJ)
+else # string VERSION not empty
+VPATH=.:src/$(VERSION):src/BUG:src/DIAPRO:src/POS:src/TOOL:src/mesonh:src/FM2DIA:src/FM:src/MOD:src/mesonh_MOD:$(DIR_OBJ):$(DIR_OBJ)
+endif
+
+ifeq ($(origin MNH_LIBTOOLS), undefined)
+include ../where.Libs
+else
+include $(MNH_LIBTOOLS)/tools/where.Libs
+endif
+
+INC = -I src/POS -I $(DIR_OBJ)
+
+LIBS = $(LIBNCAR) $(LIBX)
+
+include $(DIR_CONF)/config.$(ARCH)
+include $(MNH_LIBTOOLS)/tools/diachro/Rules.$(ARCH)
+
+
+PROG = diaprog
+
+OBJS = fmattr.o modd_cst.o modd_coord.o \
+ modd_grid1.o modd_grid.o modd_out.o modd_radar.o \
+ modd_alloc_fordiachro.o modd_type_and_lh.o alloc_fordiachro.o alloc2_fordiachro.o \
+ caresolv.o carmemory.o convallij2ll.o convij2xy.o \
+ convlo2up.o convxy2ij.o diff_oper.o extract_and_open_files.o \
+ inidef.o kztnp.o load_expr.o load_fmtaxes.o \
+ load_segments.o load_tit.o oper_process.o prints.o \
+ read_diachro.o read_dimgridref.o vert_coord.o read_th_pr.o read_type.o \
+ read_uvw.o realloc_and_load.o resolv_tit.o \
+ tsound_fordiachro.o varfct.o verif_group.o frame41.o gridal.o ficstr.o \
+ modd_alloc2_fordiachro.o modd_expr.o modd_files_diachro.o modd_mask3d.o \
+ modd_memcv.o modd_nmgrid.o modd_pt_for_ch_fordiachro.o modd_pvt.o \
+ modd_resolvcar.o modd_several_records.o modd_tit.o modd_traj3d.o \
+ modn_ncar.o modn_para.o fmfree.o fminit.o \
+ fmlook.o fmopen.o fmread.o modd_conf.o \
+ modd_dim1.o modd_fmdeclar.o \
+ modd_fmmulti.o modd_parameters.o modd_rea_lfi.o \
+ modd_time1.o modd_time.o modd_diachro.o \
+ ini_cst.o set_dim.o set_light_grid.o \
+ inidef.o bcgrd_fordiachro.o caluv_fordiachro.o careal.o carint.o \
+ closf.o colvect.o compcoord_fordiachro.o \
+ image_fordiachro.o imagev_fordiachro.o imcou_fordiachro.o interp_fordiachro.o \
+ interp_grids.o latlongrid.o loadmnmx_ft_pvkt.o loadmnmxint_iso.o \
+ loadunitit.o loadxisolevp.o load_xprdat.o memcv.o \
+ myheurx.o precou_fordiachro.o pvfct.o readcol_ft_pvkt.o \
+ read_filehead.o readmnmx_ft_pvkt.o read_sufwind.o realloc_and_load_records.o \
+ resolv_nijinf_nijsup.o resolv_times.o resolv_tity.o resolvtot.o \
+ rota.o subspxy.o tabcol_fordiachro.o traceh_fordiachro.o \
+ tracev_fordiachro.o tracircle.o traflux3d.o trahtraxy.o tramask.o \
+ trapro_fordiachro.o tratraj3d.o tramask3d.o tit_tra3d.o \
+ traxy.o veriflen_fordiachro.o \
+ modd_allvar.o modd_convij2xy.o modd_ctl_axes_and_styl.o modd_cvert.o \
+ modd_defcv.o modd_experim.o modd_hach.o modd_memgriuv.o \
+ modd_rsisocol.o modd_super.o modd_title.o mode_gridproj.o \
+ dewp.o echelle.o fleche.o os.o \
+ tsa.o valmnmx.o wtstr.o fm_read.o \
+ modd_lunit1.o modd_nesting.o modd_type_date.o mode_gridcart.o \
+ axelogpres.o color_fordiachro.o complat.o conv2xy.o \
+ computedir.o coupe_fordiachro.o coupeuw_fordiachro.o echelleph.o \
+ datfile_fordiachro.o defenetre.o factimp.o formatxy.o \
+ genformat_fordiachro.o imcoupv_fordiachro.o imcouv_fordiachro.o interpxyz.o \
+ latlongrid.o loadunitit.o load_xprdat.o memcv.o myheurx.o \
+ precou_fordiachro.o pro1d_fordiachro.o pvfct.o \
+ readmnmxint_iso.o readxisolevp.o rotauw.o readcol_ft_pvkt.o \
+ resolv_times.o resolv_tity.o resolvtot.o \
+ tracexz.o modd_type_allvar.o ccolr.o tracexy.o \
+ wsous.o interpolw.o modd_field1_cv2d.o esat.o \
+ readrefint_iso.o creatlink.o writedir.o
+OBJBIG = frame41.o ficstr.o computedir.o image_fordiachro.o imagev_fordiachro.o\
+ imcou_fordiachro.o imcoupv_fordiachro.o imcouv_fordiachro.o \
+ interpolw.o oper_process.o precou_fordiachro.o \
+ pvfct.o subspxy.o traceh_fordiachro.o
+
+OBJDIA = fmattr.o modd_cst.o modd_coord.o \
+ modd_grid1.o modd_grid.o modd_out.o \
+ modd_alloc_fordiachro.o modd_type_and_lh.o alloc_fordiachro.o \
+ read_diachro.o read_dimgridref.o vert_coord.o \
+ verif_group.o \
+ modd_alloc2_fordiachro.o modd_expr.o modd_files_diachro.o \
+ modd_memcv.o \
+ modd_resolvcar.o modd_several_records.o \
+ modn_ncar.o modn_para.o fmfree.o fminit.o \
+ fmlook.o fmopen.o fmread.o modd_conf.o \
+ modd_dim1.o modd_fmdeclar.o \
+ modd_fmmulti.o modd_parameters.o modd_rea_lfi.o \
+ modd_time1.o modd_time.o modd_diachro.o \
+ ini_cst.o set_dim.o set_light_grid.o \
+ compcoord_fordiachro.o \
+ read_filehead.o read_sufwind.o realloc_and_load_records.o \
+ modd_allvar.o modd_convij2xy.o modd_ctl_axes_and_styl.o modd_cvert.o \
+ modd_defcv.o modd_experim.o modd_hach.o modd_memgriuv.o \
+ modd_rsisocol.o modd_super.o modd_title.o mode_gridproj.o \
+ dewp.o echelle.o fleche.o os.o \
+ tsa.o valmnmx.o fm_read.o \
+ modd_lunit1.o modd_nesting.o modd_type_date.o mode_gridcart.o \
+ computedir.o interpxyz.o \
+ modd_type_allvar.o \
+ creatlink.o writedir.o
+
+%.o:%.f90 $(DIR_OBJ)/.dummy
+ $(CPP) $(INC) $(CPPFLAGS) $< > $(DIR_OBJ)/cpp_$(*F).f90
+ $(F90) $(INC) -c $(F90FLAGS) $(DIR_OBJ)/cpp_$(*F).f90 -o $(DIR_OBJ)/$(*F).o
+ -@mv *.mod $(DIR_OBJ)/. 2> /dev/null || echo pas de module dans $*.f90
+
+%.o:%.f $(DIR_OBJ)/.dummy
+ $(CPP) $(INC) $(CPPFLAGS) -Df77 $< > $(DIR_OBJ)/cpp_$(*F).f
+ $(F77) $(INC) -c $(F77FLAGS) $(DIR_OBJ)/cpp_$(*F).f -o $(DIR_OBJ)/$(*F).o
+
+
+all: $(LIBDIA) $(PROG)
+
+$(PROG): $(PROG).o $(OBJS) $(LIBCOMP) $(LIBLFI)
+ cd $(DIR_OBJ);$(F90) $(LDFLAGS) -o $@ $(patsubst $(DIR_OBJ)/%,%,$^) $(LIBS)
+
+$(DIR_OBJ)/.dummy:
+ mkdir $(DIR_OBJ)
+ @touch $(DIR_OBJ)/.dummy
+
+$(LIBLFI):
+ $(MAKE) -C $(DIR_LFI)
+
+$(LIBCOMP):
+ $(MAKE) -C $(DIR_COMP)
+
+
+ifeq ($(strip $(VERSION)),)
+$(LIBDIA): $(OBJDIA)
+ cd $(DIR_OBJ) ; $(AR) rv $@ $(OBJDIA)
+ ls -l $(DIR_OBJ)/$@
+else # string VERSION not empty
+$(LIBDIA): $(OBJDIA)
+ @echo '***' if libxxx_$(VERSION).a does not exist, cp libxxx.a libxxx_$(VERSION).a
+ ls -l $(DIR_OBJ)/$@
+ cd $(DIR_OBJ) ; $(AR) rv $@ $(OBJDIA)
+ ls -l $(DIR_OBJ)/$@
+endif
+
+
+clean:
+ (if [ -d $(DIR_OBJ) ] ; then cd $(DIR_OBJ); rm -f cpp_*.f90 cpp_*.f *.o *.mod ; fi)
+
+distclean: clean
+ (if [ -d $(DIR_OBJ) ] ; then rm -rf $(DIR_OBJ); fi)
+
+BIG:
+ cd $(OBJDIR) ; rm -f $(OBJBIG)
+ $(MAKE) $(PROGS) CPPFLAGS=-D$(MAKECMDGOALS)
+
+cp: $(SRC)
+ cp $< src/$(SRC)
+ chmod u+w src/$(SRC)
+
+user: $(DIR_OBJ)/.dummy
+ ln -s $(DIR_DIA)/$(DIR_OBJ)/*.o $(DIR_OBJ)/.
+ cp $(DIR_DIA)/$(DIR_OBJ)/*.mod $(DIR_OBJ)/.
+ @ls -dl $(DIR_OBJ)
+
+
+# nombre de passe = 1
+diaprog.o: diaprog.f90 modd_cst.o modd_conf.o modd_coord.o \
+ modd_grid1.o modd_grid.o modd_out.o \
+ modd_alloc_fordiachro.o modd_type_and_lh.o \
+ alloc2_fordiachro.o caresolv.o carmemory.o \
+ convij2xy.o convlo2up.o diff_oper.o \
+ extract_and_open_files.o load_fmtaxes.o load_segments.o \
+ load_tit.o oper_process.o prints.o \
+ read_diachro.o read_dimgridref.o read_type.o \
+ read_uvw.o realloc_and_load.o resolv_tit.o \
+ verif_group.o modd_alloc2_fordiachro.o modd_expr.o \
+ modd_files_diachro.o modd_mask3d.o modd_memcv.o \
+ modd_nmgrid.o modd_pt_for_ch_fordiachro.o modd_pvt.o \
+ modd_resolvcar.o modd_several_records.o modd_tit.o \
+ modd_traj3d.o modn_ncar.o modn_para.o \
+ writedir.o
+
+# nombre de passe = 2
+fmattr.o: fmattr.f90 modd_fmdeclar.o \
+ modd_fmmulti.o
+
+modd_conf.o: modd_conf.f90
+
+modd_coord.o: modd_coord.f90
+
+modd_cst.o: modd_cst.f90
+
+modd_grid1.o: modd_grid1.f90
+
+modd_grid.o: modd_grid.f90
+
+modd_out.o: modd_out.f90
+
+modd_alloc_fordiachro.o: modd_alloc_fordiachro.f90
+
+modd_type_and_lh.o: modd_type_and_lh.f90
+
+alloc_fordiachro.o: alloc_fordiachro.f90 modd_alloc_fordiachro.o \
+ modd_type_and_lh.o
+
+alloc2_fordiachro.o: alloc2_fordiachro.f90 modd_alloc_fordiachro.o \
+ modd_alloc2_fordiachro.o modd_files_diachro.o modd_pt_for_ch_fordiachro.o \
+ modd_resolvcar.o
+
+caresolv.o: caresolv.f90 modd_dim1.o modd_coord.o \
+ modd_grid1.o modd_parameters.o modd_alloc_fordiachro.o \
+ careal.o carint.o carmemory.o \
+ loadmnmx_ft_pvkt.o loadmnmxint_iso.o loadxisolevp.o \
+ resolvtot.o modd_ctl_axes_and_styl.o modd_defcv.o \
+ modd_expr.o modd_files_diachro.o modd_hach.o \
+ modd_mask3d.o modd_memcv.o modd_pvt.o modd_radar.o \
+ modd_resolvcar.o modd_rsisocol.o modd_super.o \
+ modd_tit.o modd_traj3d.o modn_ncar.o \
+ modn_para.o mode_gridproj.o \
+ writedir.o
+
+carmemory.o: carmemory.f90 modd_resolvcar.o
+
+convallij2ll.o: convallij2ll.f90 modd_conf.o \
+ modd_coord.o modd_dim1.o modd_grid1.o modd_grid.o \
+ modd_parameters.o modd_alloc_fordiachro.o resolvtot.o \
+ modd_convij2xy.o modd_files_diachro.o modd_resolvcar.o \
+ mode_gridproj.o
+
+convij2xy.o: convij2xy.f90 modd_conf.o \
+ modd_coord.o modd_dim1.o modd_grid1.o modd_grid.o \
+ modd_parameters.o modd_alloc_fordiachro.o resolvtot.o \
+ modd_convij2xy.o modd_files_diachro.o modd_resolvcar.o \
+ mode_gridproj.o
+
+convlo2up.o: convlo2up.f90 modd_alloc_fordiachro.o \
+ modd_files_diachro.o
+
+convxy2ij.o: convxy2ij.f90 modd_conf.o \
+ modd_dim1.o modd_grid1.o modd_grid.o \
+ modd_parameters.o modd_alloc_fordiachro.o resolvtot.o \
+ modd_convij2xy.o modd_files_diachro.o modd_resolvcar.o \
+ mode_gridproj.o
+
+diff_oper.o: diff_oper.f90 modd_alloc_fordiachro.o \
+ modd_type_and_lh.o modd_alloc2_fordiachro.o modd_files_diachro.o \
+ modd_memcv.o modd_pt_for_ch_fordiachro.o modd_resolvcar.o \
+ modd_tit.o modn_ncar.o
+
+extract_and_open_files.o: extract_and_open_files.f90 modd_alloc_fordiachro.o \
+ modd_files_diachro.o modd_resolvcar.o \
+ creatlink.o
+
+inidef.o: inidef.f90 modd_cst.o \
+ modd_allvar.o modn_ncar.o modn_para.o
+
+kztnp.o: kztnp.f90 modd_alloc_fordiachro.o \
+ modd_type_and_lh.o modd_mask3d.o modd_resolvcar.o \
+ modn_ncar.o modn_para.o
+
+load_expr.o: load_expr.f90 modd_alloc_fordiachro.o \
+ modd_expr.o modd_files_diachro.o modd_several_records.o \
+ modn_ncar.o
+
+load_fmtaxes.o: load_fmtaxes.f90 modd_resolvcar.o
+
+load_segments.o: load_segments.f90 modd_grid1.o \
+ resolvtot.o modd_resolvcar.o mode_gridproj.o
+
+load_tit.o: load_tit.f90 resolv_tit.o \
+ modd_tit.o
+
+oper_process.o: oper_process.f90 modd_conf.o \
+ modd_coord.o modd_cst.o modd_dim1.o modd_grid1.o \
+ modd_parameters.o modd_alloc_fordiachro.o \
+ modd_type_and_lh.o closf.o conv2xy.o \
+ loadunitit.o precou_fordiachro.o pvfct.o \
+ traceh_fordiachro.o tracev_fordiachro.o tramask.o \
+ trapro_fordiachro.o varfct.o modd_cvert.o \
+ modd_defcv.o modd_experim.o modd_files_diachro.o \
+ modd_mask3d.o modd_nmgrid.o modd_pt_for_ch_fordiachro.o \
+ modd_pvt.o modd_resolvcar.o modd_super.o \
+ modd_title.o modn_ncar.o modn_para.o \
+ mode_gridproj.o
+
+prints.o: prints.f90 fmread.o \
+ modd_dim1.o modd_parameters.o modd_alloc_fordiachro.o \
+ modd_type_and_lh.o realloc_and_load.o verif_group.o \
+ modd_ctl_axes_and_styl.o modd_defcv.o modd_files_diachro.o \
+ modd_memcv.o modd_resolvcar.o modd_several_records.o \
+ modd_title.o modn_ncar.o modn_para.o
+
+read_diachro.o: read_diachro.f90 fmread.o \
+ modd_dim1.o modd_alloc_fordiachro.o modd_type_and_lh.o \
+ alloc_fordiachro.o modd_resolvcar.o
+
+read_dimgridref.o: read_dimgridref.f90 fmread.o \
+ modd_conf.o modd_dim1.o modd_grid1.o modd_grid.o \
+ modd_parameters.o modd_rea_lfi.o \
+ modd_time1.o modd_time.o \
+ set_dim.o set_light_grid.o \
+ modd_resolvcar.o
+
+read_th_pr.o: read_th_pr.f90 \
+ modd_alloc_fordiachro.o modd_files_diachro.o \
+ modd_mask3d.o modd_pt_for_ch_fordiachro.o modd_resolvcar.o \
+ modd_several_records.o
+
+read_type.o: read_type.f90 fmread.o \
+ modd_alloc_fordiachro.o modd_diachro.o modd_type_and_lh.o \
+ modd_resolvcar.o modd_several_records.o
+
+read_uvw.o: read_uvw.f90 modd_alloc_fordiachro.o \
+ modd_type_and_lh.o modd_files_diachro.o modd_memgriuv.o \
+ modd_pt_for_ch_fordiachro.o modd_resolvcar.o modd_several_records.o
+
+realloc_and_load.o: realloc_and_load.f90 modd_alloc_fordiachro.o \
+ modd_type_and_lh.o verif_group.o modd_files_diachro.o \
+ modd_resolvcar.o modd_several_records.o
+
+resolv_tit.o: resolv_tit.f90 modd_alloc_fordiachro.o \
+ modd_resolvcar.o modd_tit.o
+
+tramask3d.o: tramask3d.f90 modd_conf.o \
+ modd_coord.o modd_dim1.o modd_grid1.o modd_parameters.o \
+ modd_alloc_fordiachro.o realloc_and_load.o modd_ctl_axes_and_styl.o \
+ modd_files_diachro.o modd_mask3d.o modd_nmgrid.o \
+ modd_resolvcar.o modd_several_records.o modd_traj3d.o \
+ modn_ncar.o modn_para.o modd_title.o tit_tra3d.o
+
+tsound_fordiachro.o: tsound_fordiachro.f90 fmread.o \
+ modd_dim1.o modd_parameters.o modd_type_and_lh.o \
+ modd_pt_for_ch_fordiachro.o modd_resolvcar.o modd_rsisocol.o \
+ modd_tit.o modd_title.o modn_ncar.o
+
+varfct.o: varfct.f90 modd_alloc_fordiachro.o \
+ modd_type_and_lh.o loadmnmx_ft_pvkt.o readcol_ft_pvkt.o \
+ readmnmx_ft_pvkt.o modd_ctl_axes_and_styl.o modd_defcv.o \
+ modd_resolvcar.o modd_tit.o modd_title.o \
+ modn_ncar.o modn_para.o writedir.o
+
+verif_group.o: verif_group.f90 fmread.o \
+ modd_alloc_fordiachro.o modd_diachro.o modd_type_and_lh.o \
+ realloc_and_load_records.o modd_resolvcar.o modd_several_records.o \
+ modn_ncar.o
+
+frame41.o: frame41.f modd_type_and_lh.o \
+ modd_pvt.o modd_resolvcar.o modn_ncar.o \
+ modn_para.o
+
+gridal.o: gridal.f
+
+modd_alloc2_fordiachro.o: modd_alloc2_fordiachro.f90
+
+modd_expr.o: modd_expr.f90
+
+modd_files_diachro.o: modd_files_diachro.f90
+
+modd_mask3d.o: modd_mask3d.f90
+
+modd_memcv.o: modd_memcv.f90
+
+modd_nmgrid.o: modd_nmgrid.f90
+
+modd_pt_for_ch_fordiachro.o: modd_pt_for_ch_fordiachro.f90
+
+modd_pvt.o: modd_pvt.f90
+
+modd_resolvcar.o: modd_resolvcar.f90
+
+modd_several_records.o: modd_several_records.f90
+
+modd_tit.o: modd_tit.f90
+
+modd_traj3d.o: modd_traj3d.f90
+
+modn_ncar.o: modn_ncar.f90
+
+modn_para.o: modn_para.f90 modd_dim1.o
+
+# nombre de passe = 3
+fmfree.o: fmfree.f90 modd_fmdeclar.o \
+ modd_fmmulti.o
+
+fminit.o: fminit.f90 modd_fmdeclar.o
+
+fmlook.o: fmlook.f90 modd_fmdeclar.o
+
+fmopen.o: fmopen.f90 modd_fmdeclar.o \
+ modd_fmmulti.o
+
+fmread.o: fmread.f90 modd_conf.o \
+ modd_fmdeclar.o modd_type_date.o
+
+modd_conf.o: modd_conf.f90
+
+modd_dim1.o: modd_dim1.f90
+
+modd_fmdeclar.o: modd_fmdeclar.f90
+
+modd_fmmulti.o: modd_fmmulti.f90
+
+modd_parameters.o: modd_parameters.f90
+
+modd_radar.o: modd_radar.f90
+
+modd_rea_lfi.o: modd_rea_lfi.f90
+
+modd_time1.o: modd_time1.f90 modd_type_date.o
+
+modd_time.o: modd_time.f90 modd_parameters.o \
+ modd_type_date.o
+
+modd_diachro.o: modd_diachro.f90
+
+ini_cst.o: ini_cst.f90 modd_cst.o
+
+set_dim.o: set_dim.f90 fmread.o \
+ modd_conf.o modd_parameters.o
+
+set_light_grid.o: set_light_grid.f90 fmread.o \
+ modd_conf.o modd_grid.o modd_time.o \
+ mode_gridcart.o mode_gridproj.o
+
+bcgrd_fordiachro.o: bcgrd_fordiachro.f90 modd_grid1.o \
+ modd_grid.o modd_ctl_axes_and_styl.o modd_mask3d.o \
+ modd_nmgrid.o modd_resolvcar.o modd_traj3d.o modd_radar.o \
+ modn_ncar.o modn_para.o mode_gridproj.o \
+ writedir.o creatlink.o
+
+caluv_fordiachro.o: caluv_fordiachro.f90 modd_dim1.o \
+ modd_parameters.o modd_alloc_fordiachro.o modd_type_and_lh.o \
+ realloc_and_load.o verif_group.o modd_files_diachro.o \
+ modd_pt_for_ch_fordiachro.o modd_resolvcar.o modd_several_records.o
+
+careal.o: careal.f90 modd_resolvcar.o
+
+carint.o: carint.f90 modd_resolvcar.o
+
+closf.o: closf.f90 modd_conf.o \
+ modd_time1.o modd_time.o modd_alloc_fordiachro.o \
+ modd_ctl_axes_and_styl.o modd_defcv.o modd_memcv.o \
+ modd_nmgrid.o modd_resolvcar.o modn_ncar.o \
+ modn_para.o modd_grid1.o modd_parameters.o mode_gridproj.o
+
+colvect.o: colvect.f90 modd_pvt.o \
+ modd_resolvcar.o modn_ncar.o
+
+conv2xy.o: conv2xy.f90 modd_conf.o \
+ modd_dim1.o modd_grid1.o modd_alloc_fordiachro.o \
+ modd_files_diachro.o modd_resolvcar.o mode_gridproj.o
+
+datfile_fordiachro.o: datfile_fordiachro.f90 modd_out.o \
+ modd_alloc_fordiachro.o modd_type_and_lh.o modd_files_diachro.o \
+ modd_resolvcar.o
+
+defenetre.o: defenetre.f90 modd_dim1.o \
+ modd_ctl_axes_and_styl.o modd_nmgrid.o modd_resolvcar.o \
+ modn_ncar.o
+
+factimp.o: factimp.f90 modd_type_and_lh.o \
+ modd_memcv.o modd_resolvcar.o
+
+formatxy.o: formatxy.f90 modd_resolvcar.o
+
+image_fordiachro.o: image_fordiachro.f90 modd_conf.o \
+ modd_lunit1.o modd_out.o modd_time1.o \
+ modd_time.o modd_alloc_fordiachro.o readmnmxint_iso.o \
+ readxisolevp.o modd_ctl_axes_and_styl.o modd_hach.o \
+ modd_mask3d.o modd_nmgrid.o modd_pt_for_ch_fordiachro.o \
+ modd_resolvcar.o modd_rsisocol.o modd_super.o \
+ modd_tit.o modd_title.o modn_ncar.o \
+ modn_para.o \
+ readrefint_iso.o writedir.o creatlink.o
+
+imagev_fordiachro.o: imagev_fordiachro.f90 modd_conf.o \
+ modd_grid1.o modd_grid.o modd_out.o \
+ modd_time1.o modd_time.o modd_alloc_fordiachro.o \
+ resolv_tit.o resolv_tity.o modd_ctl_axes_and_styl.o \
+ modd_memcv.o modd_pt_for_ch_fordiachro.o modd_pvt.o \
+ modd_resolvcar.o modd_super.o modd_tit.o \
+ modd_title.o modn_ncar.o modn_para.o \
+ mode_gridproj.o computedir.o
+
+imcou_fordiachro.o: imcou_fordiachro.f90 modd_conf.o \
+ modd_dim1.o modd_grid1.o modd_grid.o \
+ modd_lunit1.o modd_out.o modd_parameters.o \
+ modd_alloc_fordiachro.o modd_type_and_lh.o readmnmxint_iso.o \
+ readxisolevp.o resolv_tit.o resolv_tity.o \
+ modd_allvar.o modd_ctl_axes_and_styl.o modd_cvert.o \
+ modd_defcv.o modd_hach.o modd_nmgrid.o \
+ modd_pt_for_ch_fordiachro.o modd_pvt.o modd_resolvcar.o \
+ modd_rsisocol.o modd_super.o modd_tit.o \
+ modd_title.o modn_ncar.o modn_para.o modd_mask3d.o \
+ mode_gridproj.o \
+ readrefint_iso.o writedir.o creatlink.o
+
+interp_fordiachro.o: interp_fordiachro.f90 modd_grid1.o \
+ modd_parameters.o modd_type_and_lh.o modd_mask3d.o \
+ modd_nmgrid.o modd_pt_for_ch_fordiachro.o modd_resolvcar.o \
+ modn_ncar.o modn_para.o
+
+interp_grids.o: interp_grids.f90 modd_alloc_fordiachro.o \
+ modd_nmgrid.o modd_pt_for_ch_fordiachro.o modd_pvt.o \
+ modd_resolvcar.o
+
+latlongrid.o: latlongrid.f90 modd_alloc_fordiachro.o \
+ modd_nmgrid.o modd_resolvcar.o
+
+loadmnmx_ft_pvkt.o: loadmnmx_ft_pvkt.f90 modd_resolvcar.o
+
+loadmnmxint_iso.o: loadmnmxint_iso.f90 modd_resolvcar.o
+
+loadunitit.o: loadunitit.f90 modd_alloc_fordiachro.o \
+ modd_nmgrid.o modd_resolvcar.o
+
+loadxisolevp.o: loadxisolevp.f90 modd_resolvcar.o
+
+load_xprdat.o: load_xprdat.f90 modd_alloc_fordiachro.o \
+ modd_resolvcar.o
+
+memcv.o: memcv.f90 modd_memcv.o \
+ modd_nmgrid.o modn_para.o modd_resolvcar.o
+
+myheurx.o: myheurx.f90 modd_dim1.o \
+ modd_ctl_axes_and_styl.o modd_resolvcar.o modn_ncar.o
+
+precou_fordiachro.o: precou_fordiachro.f90 \
+ modd_conf.o modd_dim1.o modd_grid1.o \
+ modd_alloc_fordiachro.o modd_type_and_lh.o \
+ modd_cvert.o modd_memgriuv.o modd_nmgrid.o \
+ modd_pt_for_ch_fordiachro.o modd_pvt.o modd_resolvcar.o \
+ modn_ncar.o modn_para.o computedir.o
+
+pvfct.o: pvfct.f90 modd_dim1.o \
+ modd_grid1.o modd_grid.o modd_parameters.o \
+ modd_alloc_fordiachro.o modd_type_and_lh.o varfct.o \
+ modd_cvert.o modd_experim.o modd_nmgrid.o \
+ modd_pvt.o modd_resolvcar.o modd_super.o \
+ modd_tit.o modd_title.o modn_ncar.o \
+ modn_para.o mode_gridproj.o
+
+readcol_ft_pvkt.o: readcol_ft_pvkt.f90 modd_resolvcar.o
+
+read_filehead.o: read_filehead.f90 fmread.o \
+ modd_dim1.o modd_parameters.o modd_diachro.o \
+ modd_type_and_lh.o modd_resolvcar.o modn_ncar.o \
+ modn_para.o
+
+readmnmx_ft_pvkt.o: readmnmx_ft_pvkt.f90 modd_resolvcar.o
+
+read_sufwind.o: read_sufwind.f90 modd_resolvcar.o
+
+realloc_and_load_records.o: realloc_and_load_records.f90 modd_alloc_fordiachro.o \
+ modd_type_and_lh.o modd_files_diachro.o modd_resolvcar.o \
+ modd_several_records.o
+
+resolv_nijinf_nijsup.o: resolv_nijinf_nijsup.f90 modd_dim1.o \
+ modd_parameters.o modd_type_and_lh.o modd_resolvcar.o \
+ modn_para.o
+
+resolv_times.o: resolv_times.f90 modd_conf.o \
+ modd_grid.o modd_time1.o modd_time.o \
+ modd_alloc_fordiachro.o modd_type_and_lh.o modd_title.o
+
+resolv_tity.o: resolv_tity.f90 modd_resolvcar.o \
+ modd_tit.o
+
+resolvtot.o: resolvtot.f90 modd_resolvcar.o \
+ modn_ncar.o modn_para.o
+
+rota.o: rota.f90 modd_defcv.o \
+ modd_memgriuv.o modd_resolvcar.o modn_para.o
+
+subspxy.o: subspxy.f90 modd_conf.o \
+ modd_cst.o modd_dim1.o modd_grid1.o \
+ modd_parameters.o modd_alloc_fordiachro.o \
+ modd_type_and_lh.o loadunitit.o precou_fordiachro.o \
+ traceh_fordiachro.o tracev_fordiachro.o modd_cvert.o \
+ modd_defcv.o modd_experim.o modd_files_diachro.o \
+ modd_mask3d.o modd_nmgrid.o modd_pt_for_ch_fordiachro.o \
+ modd_pvt.o modd_resolvcar.o modd_super.o \
+ modd_tit.o modd_title.o modn_ncar.o \
+ modn_para.o mode_gridproj.o
+
+tabcol_fordiachro.o: tabcol_fordiachro.f90 modd_resolvcar.o
+
+traceh_fordiachro.o: traceh_fordiachro.f90 modd_dim1.o \
+ modd_out.o modd_parameters.o modd_alloc_fordiachro.o \
+ modd_type_and_lh.o interp_fordiachro.o resolv_tit.o \
+ resolv_tity.o modd_allvar.o modd_defcv.o \
+ modd_mask3d.o modd_nmgrid.o modd_pt_for_ch_fordiachro.o \
+ modd_resolvcar.o modd_super.o modd_tit.o \
+ modd_title.o modn_ncar.o modn_para.o computedir.o \
+ writedir.o
+
+tracev_fordiachro.o: tracev_fordiachro.f90 modd_dim1.o \
+ modd_out.o modd_alloc_fordiachro.o modd_nmgrid.o \
+ modd_pt_for_ch_fordiachro.o modd_resolvcar.o modd_super.o \
+ modd_title.o modn_ncar.o modn_para.o
+
+traflux3d.o: traflux3d.f90 modd_conf.o \
+ modd_dim1.o modd_grid1.o modd_parameters.o \
+ modd_alloc_fordiachro.o interpxyz.o realloc_and_load.o \
+ modd_ctl_axes_and_styl.o modd_files_diachro.o modd_mask3d.o \
+ modd_nmgrid.o modd_resolvcar.o modd_several_records.o \
+ modd_traj3d.o modn_ncar.o modn_para.o tit_tra3d.o
+
+trahtraxy.o: trahtraxy.f90 modd_alloc_fordiachro.o \
+ modd_type_and_lh.o resolv_tit.o resolv_tity.o \
+ modd_defcv.o modd_nmgrid.o modd_pt_for_ch_fordiachro.o \
+ modd_resolvcar.o modd_tit.o modn_ncar.o \
+ modn_para.o
+
+tramask.o: tramask.f90 modd_grid1.o \
+ modd_ctl_axes_and_styl.o modd_nmgrid.o modd_resolvcar.o \
+ modd_super.o modd_tit.o modd_title.o \
+ modn_ncar.o modn_para.o
+
+trapro_fordiachro.o: trapro_fordiachro.f90 modd_conf.o \
+ modd_grid1.o modd_grid.o modd_out.o \
+ modd_parameters.o modd_type_and_lh.o readmnmx_ft_pvkt.o \
+ modd_ctl_axes_and_styl.o modd_defcv.o modd_nmgrid.o \
+ modd_resolvcar.o modd_super.o modd_tit.o \
+ modd_title.o modn_ncar.o modn_para.o \
+ mode_gridproj.o writedir.o
+
+tratraj3d.o: tratraj3d.f90 modd_conf.o \
+ modd_dim1.o modd_grid1.o modd_parameters.o \
+ modd_alloc_fordiachro.o interpxyz.o realloc_and_load.o \
+ modd_ctl_axes_and_styl.o modd_files_diachro.o modd_mask3d.o \
+ modd_nmgrid.o modd_resolvcar.o modd_several_records.o \
+ modd_traj3d.o modn_ncar.o modn_para.o modd_title.o tit_tra3d.o
+
+traxy.o: traxy.f90 modd_conf.o \
+ modd_dim1.o modd_grid1.o modd_parameters.o \
+ modd_alloc_fordiachro.o modd_type_and_lh.o set_dim.o \
+ modd_ctl_axes_and_styl.o modd_files_diachro.o modd_nmgrid.o \
+ modd_resolvcar.o modd_super.o modd_tit.o \
+ modd_title.o modn_ncar.o modn_para.o
+
+veriflen_fordiachro.o: veriflen_fordiachro.f90 modd_conf.o \
+ modd_dim1.o modd_grid1.o modd_parameters.o \
+ modd_alloc_fordiachro.o modd_type_and_lh.o modd_defcv.o \
+ modd_nmgrid.o modd_resolvcar.o modn_para.o \
+ mode_gridproj.o
+
+modd_allvar.o: modd_allvar.f90 modd_type_allvar.o
+
+modd_convij2xy.o: modd_convij2xy.f90
+
+modd_ctl_axes_and_styl.o: modd_ctl_axes_and_styl.f90
+
+modd_cvert.o: modd_cvert.f90
+
+modd_defcv.o: modd_defcv.f90
+
+modd_experim.o: modd_experim.f90
+
+modd_hach.o: modd_hach.f90
+
+modd_memgriuv.o: modd_memgriuv.f90
+
+modd_rsisocol.o: modd_rsisocol.f90
+
+modd_super.o: modd_super.f90
+
+modd_title.o: modd_title.f90
+
+mode_gridproj.o: mode_gridproj.f90 modd_conf.o \
+ modd_cst.o modd_grid.o modd_lunit1.o \
+ modd_parameters.o vert_coord.o
+
+mode_gridcart.o: mode_gridcart.f90 modd_conf.o \
+ modd_parameters.o vert_coord.o
+
+compcoord_fordiachro.o: compcoord_fordiachro.f90 modd_conf.o \
+ modd_dim1.o modd_grid1.o modd_parameters.o \
+ modd_memcv.o modd_resolvcar.o vert_coord.o
+
+vert_coord.o: vert_coord.f90
+
+dewp.o: dewp.f90
+
+echelle.o: echelle.f90 modd_resolvcar.o
+
+fleche.o: fleche.f90
+
+os.o: os.f90
+
+tsa.o: tsa.f90
+
+valmnmx.o: valmnmx.f90
+
+wtstr.o: wtstr.f
+
+# nombre de passe = 4
+fm_read.o: fm_read.f90 modd_fmdeclar.o
+
+modd_conf1.o: modd_conf1.f90
+
+modd_lunit1.o: modd_lunit1.f90 modd_parameters.o
+
+modd_nesting.o: modd_nesting.f90 modd_parameters.o
+
+modd_type_date.o: modd_type_date.f90
+
+axelogpres.o: axelogpres.f90 modd_pvt.o
+
+color_fordiachro.o: color_fordiachro.f90 modd_resolvcar.o
+
+complat.o: complat.f90 modd_grid1.o \
+ modd_nmgrid.o mode_gridproj.o
+
+computedir.o: computedir.f90 modd_grid1.o \
+ modd_grid.o modd_alloc_fordiachro.o modd_resolvcar.o \
+ modd_super.o modn_ncar.o modn_para.o \
+ mode_gridproj.o
+
+coupe_fordiachro.o: coupe_fordiachro.f90 modd_grid1.o \
+ modd_parameters.o modd_type_and_lh.o modd_cvert.o \
+ modd_memcv.o modd_nmgrid.o modd_resolvcar.o \
+ modn_ncar.o modn_para.o
+
+coupeuw_fordiachro.o: coupeuw_fordiachro.f90 modd_grid1.o \
+ modd_parameters.o modd_type_and_lh.o modd_cvert.o \
+ modd_memcv.o modd_memgriuv.o modd_nmgrid.o \
+ modd_resolvcar.o modn_ncar.o modn_para.o
+
+echelleph.o: echelleph.f90 modd_memcv.o \
+ modd_resolvcar.o
+
+genformat_fordiachro.o: genformat_fordiachro.f90
+
+imcoupv_fordiachro.o: imcoupv_fordiachro.f90 modd_grid1.o \
+ modd_grid.o modd_lunit1.o modd_out.o \
+ modd_parameters.o modd_alloc_fordiachro.o modd_type_and_lh.o \
+ resolv_tit.o resolv_tity.o modd_ctl_axes_and_styl.o \
+ modd_cvert.o modd_defcv.o modd_field1_cv2d.o \
+ modd_nmgrid.o modd_pt_for_ch_fordiachro.o modd_pvt.o \
+ modd_resolvcar.o modd_super.o modd_tit.o \
+ modd_title.o modn_ncar.o modn_para.o \
+ mode_gridproj.o
+
+imcouv_fordiachro.o: imcouv_fordiachro.f90 modd_conf.o \
+ modd_grid1.o modd_grid.o modd_lunit1.o \
+ modd_out.o modd_parameters.o modd_alloc_fordiachro.o \
+ resolv_tit.o resolv_tity.o modd_ctl_axes_and_styl.o \
+ modd_cvert.o modd_defcv.o modd_field1_cv2d.o \
+ modd_memcv.o modd_nmgrid.o modd_pt_for_ch_fordiachro.o \
+ modd_pvt.o modd_resolvcar.o modd_super.o \
+ modd_tit.o modd_title.o modn_ncar.o \
+ modn_para.o mode_gridproj.o
+
+interpxyz.o: interpxyz.f90
+
+pro1d_fordiachro.o: pro1d_fordiachro.f90 modd_conf.o \
+ modd_grid1.o modd_out.o modd_parameters.o \
+ modd_alloc_fordiachro.o modd_type_and_lh.o modd_allvar.o \
+ modd_ctl_axes_and_styl.o modd_defcv.o modd_experim.o \
+ modd_resolvcar.o modd_super.o modd_tit.o \
+ modd_title.o modn_ncar.o modn_para.o
+
+readmnmxint_iso.o: readmnmxint_iso.f90 modd_resolvcar.o
+
+readrefint_iso.o: readrefint_iso.f90 modd_resolvcar.o
+
+readxisolevp.o: readxisolevp.f90 modd_resolvcar.o
+
+rotauw.o: rotauw.f90 modd_defcv.o \
+ modn_para.o
+
+tracexz.o: tracexz.f90 modd_grid1.o \
+ modd_parameters.o modd_nmgrid.o modn_para.o
+
+modd_type_allvar.o: modd_type_allvar.f90
+
+ccolr.o: ccolr.f
+
+tracexy.o: tracexy.f90 modd_dim1.o \
+ modd_out.o modd_nmgrid.o
+
+wsous.o: wsous.f90
+
+# nombre de passe = 5
+interpolw.o: interpolw.f90 modd_dim1.o \
+ modd_grid1.o modd_resolvcar.o modn_ncar.o
+
+modd_field1_cv2d.o: modd_field1_cv2d.f90
+
+esat.o: esat.f90
+
+tracircle.o: tracircle.f90 modd_radar.o
+
+tit_tra3d.o: tit_tra3d.f90 modd_tit.o modd_title.o modd_resolvcar.o
diff --git a/LIBTOOLS/tools/diachro/Makefile.exrwdia b/LIBTOOLS/tools/diachro/Makefile.exrwdia
new file mode 100644
index 0000000000000000000000000000000000000000..3cec20ccd9f746bc868c421f62acb9687d9bcd94
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Makefile.exrwdia
@@ -0,0 +1,57 @@
+B ?= 32
+
+ifeq ($(origin MNH_LIBTOOLS), undefined)
+dummy :
+ @echo "ERROR : MNH_LIBTOOLS variable is not set !";echo
+else
+include $(MNH_LIBTOOLS)/tools/where.Libs
+
+DIR_OBJ=./$(ARCH)_$(B)
+ifeq ($(strip $(VERSION)),)
+VPATH=src:$(DIR_DIA)/src/BUG:$(DIR_DIA)/src/EXTRACTDIA:$(DIR_OBJ)
+else # string VERSION not empty
+VPATH=src:$(DIR_DIA)/src/$(VERSION):$(DIR_DIA)/src/BUG:$(DIR_DIA)/src/EXTRACTDIA:$(DIR_OBJ)
+endif
+
+# par defaut exrwdia.f90 est traite, sinon make PROG=votre_prog
+PROG ?= exrwdia
+# a completer eventuellement par vos routines
+OBJS =
+
+INC = -I $(DIR_OBJ) -I $(DIR_DIA)/$(DIR_OBJ)
+LIBS = $(DIR_DIA)/$(DIR_OBJ)/$(LIBEXTRACT) $(DIR_DIA)/$(DIR_OBJ)/$(LIBDIA)\
+ $(LIBCOMP) $(LIBLFI)
+
+include $(DIR_CONF)/config.$(ARCH)
+include $(DIR_DIA)/Rules.$(ARCH)
+
+
+%.o:%.f90 $(DIR_OBJ)/.dummy
+ $(CPP) $(INC) $(CPPFLAGS) $< > $(DIR_OBJ)/cpp_$(*F).f90
+ $(F90) $(INC) -c $(F90FLAGS) $(DIR_OBJ)/cpp_$(*F).f90 -o $(DIR_OBJ)/$(*F).o
+ -@mv *.mod $(DIR_OBJ)/. 2>/dev/null || echo pas de module dans $*.f90
+
+all: $(PROG)
+
+$(PROG): $(addsuffix .o,$(PROG)) $(OBJS) $(LIBS)
+ cd $(DIR_OBJ);$(F90) $(LDFLAGS) $(patsubst $(DIR_OBJ)/%,%,$^) -o $@
+ @echo executable $@ disponible sous $(DIR_OBJ)
+
+$(DIR_OBJ)/.dummy:
+ mkdir $(DIR_OBJ)
+ @touch $(DIR_OBJ)/.dummy
+
+clean:
+ (if [ -d $(DIR_OBJ) ] ; then cd $(DIR_OBJ); rm $(PROG) cpp_* *.mod *.o; fi)
+
+$(PROG).o: $(PROG).f90 $(OBJS)
+#
+# dependances
+# entre unites de programme et les use MODI_myroutine
+# si myroutine est une routine utilisateur
+#
+
+
+
+#
+endif
diff --git a/LIBTOOLS/tools/diachro/Makefile.extractdia b/LIBTOOLS/tools/diachro/Makefile.extractdia
new file mode 100644
index 0000000000000000000000000000000000000000..c71a18208c87c1ce1a5bd46339da51f92d8c3817
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Makefile.extractdia
@@ -0,0 +1,100 @@
+B ?= 32
+DIR_OBJ=./$(ARCH)_$(B)
+
+ifeq ($(strip $(VERSION)),)
+VPATH=src/BUG:src/EXTRACTDIA:src/TOOL:src/mesonh:$(DIR_OBJ)
+else # string VERSION not empty
+VPATH=src/$(VERSION):src/BUG:src/EXTRACTDIA:src/TOOL:src/mesonh:src/MOD:src/mesonh_MOD:$(DIR_OBJ)
+endif
+
+ifeq ($(origin MNH_LIBTOOLS), undefined)
+include ../where.Libs
+else
+include $(MNH_LIBTOOLS)/tools/where.Libs
+endif
+
+INC = -I $(DIR_OBJ)
+LIBS = $(DIR_DIA)/$(DIR_OBJ)/$(LIBDIA) $(LIBCOMP) $(LIBLFI)
+
+include $(DIR_CONF)/config.$(ARCH)
+include Rules.$(ARCH)
+
+
+PROG = extractdia
+OBJS = shuman.o hor_interp_4pts.o modd_readlh.o \
+ uv_to_zonal_and_merid.o temporal_dist_for_ext.o \
+ low2up.o up2low.o \
+ change_a_grid.o \
+ zinter.o zmoy.o pinter.o \
+ readvar.o writevar.o writecdl.o writellhv.o writegrib.o\
+ dd.o ff.o computedir.o verif_group.o \
+ ini2lalo.o int2lalo.o \
+ to_computing_units.o from_computing_units.o modn_outfile.o
+
+
+all: $(LIBEXTRACT) $(PROG)
+
+# generation de l executable
+$(PROG): $(addsuffix .o,$(PROG)) $(OBJS) $(LIBS)
+ #cd $(DIR_OBJ);$(F90) $(LDFLAGS) $(patsubst $(DIR_OBJ)/%,%,$^) -o $@ $(LIBV5D) $(LIBGRB)
+ cd $(DIR_OBJ);$(F90) $(LDFLAGS) $(patsubst $(DIR_OBJ)/%,%,$^) -o $@ $(LIBGRB)
+ @echo executable $@ disponible sous $(DIR_OBJ)
+
+# gestion des versions
+ifeq ($(strip $(VERSION)),)
+$(LIBEXTRACT): $(OBJS)
+ cd $(DIR_OBJ) ; $(AR) rv $@ $(OBJS)
+ ls -l $(DIR_OBJ)/$@
+else # string VERSION not empty
+$(LIBEXTRACT): $(OBJS)
+ @echo '***' if libxxx_$(VERSION).a does not exist, cp libxxx.a libxxx_$(VERSION).a
+ ls -l $(DIR_OBJ)/$@
+ cd $(DIR_OBJ) ; $(AR) rv $@ $(OBJS)
+ ls -l $(DIR_OBJ)/$@
+endif
+
+# creation du repertoire contenant les objets
+$(DIR_OBJ)/.dummy:
+ mkdir $(DIR_OBJ)
+ @touch $(DIR_OBJ)/.dummy
+
+# cleaning
+clean:
+ (if [ -d $(DIR_OBJ) ] ; then cd $(DIR_OBJ); rm $(PROG)* $(OBJS) $(addprefix cpp_,$(OBJS:.o=.f90)); fi)
+
+distclean:
+ (if [ -d $(DIR_OBJ) ] ; then cd $(DIR_OBJ); rm * ; fi)
+
+# regle de compilation
+%.o:%.f90 $(DIR_OBJ)/.dummy
+ $(CPP) $(INC) $(CPPFLAGS) $< > $(DIR_OBJ)/cpp_$(*F).f90
+ $(F90) $(INC) -c $(F90FLAGS) $(DIR_OBJ)/cpp_$(*F).f90 -o $(DIR_OBJ)/$(*F).o
+ -@mv *.mod $(DIR_OBJ)/. 2>/dev/null || echo pas de module dans $*.f90
+
+
+# dependances du programme principal
+$(PROG).o: $(PROG).f90 change_a_grid.o hor_interp_4pts.o \
+ uv_to_zonal_and_merid.o zinter.o zmoy.o \
+ ini2lalo.o int2lalo.o writedir.o \
+ writevar.o writecdl.o writellhv.o writegrib.o writedir.o \
+ dd.o ff.o low2up.o modn_outfile.o
+
+# dependances des routines
+uv_to_zonal_and_merid.o: uv_to_zonal_and_merid.f90 shuman.o
+writecdl.o: writecdl.f90 temporal_dist_for_ext.o from_computing_units.o
+writevar.o: writevar.f90 modn_ncar.o modd_files_diachro.o from_computing_units.o
+writellhv.o: writellhv.f90 from_computing_units.o
+writegrib.o: writegrib.f90 from_computing_units.o modn_outfile.o
+writedir.o: writedir.f90
+change_a_grid.o: change_a_grid.f90 shuman.o
+zmoy.o: zmoy.f90 zinter.o
+temporal_dist_for_ext.o: temporal_dist_for_ext.f90
+dd.o: dd.f90 computedir.o
+computedir.o: computedir.f90
+readvar.o: readvar.f90 verif_group.o to_computing_units.o modd_readlh.o
+verif_group.o: verif_group.f90
+modn_outfile.o: modn_outfile.f90 modd_conf.o
+ini2lalo.o: ini2lalo.f90 modd_cst.o modd_parameters.o modd_grid.o modd_grid1.o
+int2lalo.o: int2lalo.f90 modd_cst.o modd_parameters.o modd_dim1.o modd_grid1.o \
+ mode_gridproj.o
+
diff --git a/LIBTOOLS/tools/diachro/Rules.AIX32 b/LIBTOOLS/tools/diachro/Rules.AIX32
new file mode 100644
index 0000000000000000000000000000000000000000..60964ade0a1893f2335e8ae086447bc2bc7f5ac5
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.AIX32
@@ -0,0 +1,18 @@
+LIBX = -lX11
+
+#LIBV5D = -L/usr/local/lib -lv5d
+
+LIBGRB = $(EMOSLIB)
+
+#############################################################################
+
+CPPFLAGS += -DHPPA
+F77FLAGS +=
+ifeq ($(B),64)
+F90FLAGS += -qautodbl=dbl4
+endif
+LDFLAGS +=
+#
+OBJS2 = caresolv.o
+$(OBJS2) : F90FLAGS = -qfree=f90 -qsuffix=f=f90 -O2 -qmaxmem=-1
+
diff --git a/LIBTOOLS/tools/diachro/Rules.AIX64 b/LIBTOOLS/tools/diachro/Rules.AIX64
new file mode 100644
index 0000000000000000000000000000000000000000..8798fcc625e241d444b4a6bf928ea4870db5969a
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.AIX64
@@ -0,0 +1,9 @@
+#
+# Pas de diaprog sur IBM
+#
+PROGALL = conv2dia
+#
+#############################################################################
+F77FLAGS = -q64 -qfixed -O3 -qstrict
+F90FLAGS = -q64 -qfree=f90 -qsuffix=f=f90 -O3 -qstrict
+
diff --git a/LIBTOOLS/tools/diachro/Rules.HPNAGf95 b/LIBTOOLS/tools/diachro/Rules.HPNAGf95
new file mode 100644
index 0000000000000000000000000000000000000000..2bfc82d43b5a4709c5157c0daf0781108a532fe0
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.HPNAGf95
@@ -0,0 +1,12 @@
+LIBEXT = -lX11 -lm -lcl
+
+#############################################################################
+
+CPPFLAGS += -DLINUX -DNAGf95
+F77FLAGS += -g -O0
+F90FLAGS += -g -O0
+ifeq ($(B),64)
+F90FLAGS += -r8
+endif
+OBJS2=
+
diff --git a/LIBTOOLS/tools/diachro/Rules.HPf90 b/LIBTOOLS/tools/diachro/Rules.HPf90
new file mode 100644
index 0000000000000000000000000000000000000000..eecad3360869ad3f52f147a714cef1ddab98e6b2
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.HPf90
@@ -0,0 +1,23 @@
+LIBX = -lX11 -lm
+LIBV5D =
+# avec cette lib, fabs floor exp log sont Unsatisfied symbols...:
+#LIBV5D = -L/users/mesonh/utilitaires/vis5d/vis5d-5.0/src -l v5d
+# avec cette lib, v5dcreate v5dwrite v5dclose sont Unsatisfied symbols...:
+#LIBV5D = -L $(MNH_LIBTOOLS)/lib/vis5d/$(ARCH) -lv5d
+LIBGRB =
+
+#############################################################################
+
+CPPFLAGS += -DHPPA -DHP
+F77FLAGS += -O2 +Oinfo +Olimit
+ifeq ($(PROG),diaprog)
+F90FLAGS += -O2 +Oinfo +Olimit
+else
+F90FLAGS += -O2 +Oinfo +Olimit +check=all
+endif
+ifeq ($(B),64)
+F90FLAGS += +r8
+endif
+LDFLAGS +=
+OBJS2 = shuman.o
+$(OBJS2) : F90FLAGS += -O2 +Oinfo +Olimit
diff --git a/LIBTOOLS/tools/diachro/Rules.LXNAGf95 b/LIBTOOLS/tools/diachro/Rules.LXNAGf95
new file mode 100644
index 0000000000000000000000000000000000000000..75c1c175f02d558cf8b3f551773537619395d8a7
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.LXNAGf95
@@ -0,0 +1,26 @@
+#LIBX = -L/usr/X11R6/lib -lX11 -lg2c
+LIBX = -L/usr/X11R6/lib -lX11 /usr/lib64/libgfortran.so.1
+
+LIBV5D = -L$(DIR_V5D)/$(ARCH) -lv5d
+#LIBV5D = /usr/local/lib/libv5d.a
+#LIBV5D = -L/mesonh/MAKE/lib/vis5d/LXNAGf95 -lv5d
+
+LIBGRB = -L$(DIR_GRB) -lemosR64
+
+#############################################################################
+
+CPPFLAGS += -DLINUX -DNAGf95 -Dkey_swapio
+F77FLAGS +=
+#F90FLAGS = -kind=byte -w -gline -O2 -mismatch_all -target=pentium
+#F90FLAGS = -kind=byte -w -gline -O2 -C -target=pentium
+F90FLAGS = -kind=byte -w -gline -O2 -C -mismatch_all
+ifeq ($(B),64)
+#F90FLAGS += -r8
+#F90FLAGS = -r8 -kind=byte -w -gline -O2 -mismatch_all -target=pentium
+F90FLAGS = -r8 -kind=byte -w -gline -O2 -mismatch_all
+endif
+LDFLAGS += -Wl,-Xlinker,-noinhibit-exec -Wl,-Xlinker,-warn-once
+#
+#OBJS2 = image_fordiachro.o
+#$(OBJS2) : F90FLAGS = -kind=byte -w -gline -O2
+
diff --git a/LIBTOOLS/tools/diachro/Rules.LXg95 b/LIBTOOLS/tools/diachro/Rules.LXg95
new file mode 100644
index 0000000000000000000000000000000000000000..0eec77e90787894a9c2bd7c9d22914983929a31d
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.LXg95
@@ -0,0 +1,22 @@
+#LIBX = -L/usr/X11R6/lib64 -lX11 -lg2c
+LIBX = -L/usr/X11R6/lib -lX11 /usr/lib64/libgfortran.so.1
+
+#LIBV5D = /usr/local/lib/libv5d.a
+#LIBV5D = -L/mesonh/MAKE/lib/vis5d/LXNAGf95 -lv5d
+
+LIBGRB = -L$(DIR_GRIB) -lemosR64
+
+#############################################################################
+
+CPPFLAGS += -DLINUX -DG95 -Dkey_swapio
+F77FLAGS +=
+#F90FLAGS = -w -O2
+F90FLAGS += -w -O2
+ifeq ($(B),64)
+F90FLAGS += -r8
+endif
+LDFLAGS += -Wl,-noinhibit-exec -Wl,-warn-once
+#
+#OBJS2 = image_fordiachro.o
+#$(OBJS2) : F90FLAGS = -w -O2
+
diff --git a/LIBTOOLS/tools/diachro/Rules.LXgfortran b/LIBTOOLS/tools/diachro/Rules.LXgfortran
new file mode 100644
index 0000000000000000000000000000000000000000..45d7d6bcac960b7c1c0adeabe3e763a72b5248df
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.LXgfortran
@@ -0,0 +1,23 @@
+#LIBX = -L/usr/X11R6/lib64 -lX11 -lg2c
+LIBX = -L/usr/X11R6/lib -lX11 -lpng -lz
+LIBX = -L/usr/X11R6/lib64 -lX11 -lpng -lz -lcairo -lfreetype
+
+#LIBV5D = /usr/local/lib/libv5d.a
+#LIBV5D = -L/mesonh/MAKE/lib/vis5d/LXgfortran -lv5d
+
+LIBGRB = -L$(DIR_GRIB) -lgribex
+
+#############################################################################
+
+CPPFLAGS += -DLINUX -DNCL511 -Dkey_swapio
+F77FLAGS +=
+#F90FLAGS = -w -O2
+F90FLAGS += -O2
+ifeq ($(B),64)
+F90FLAGS += -fdefault-real-8
+endif
+LDFLAGS += -Wl,-noinhibit-exec -Wl,-warn-once -static-libgfortran
+#
+#OBJS2 = image_fordiachro.o
+#$(OBJS2) : F90FLAGS = -w -O2
+
diff --git a/LIBTOOLS/tools/diachro/Rules.LXpgf90 b/LIBTOOLS/tools/diachro/Rules.LXpgf90
new file mode 100644
index 0000000000000000000000000000000000000000..faa9047b213f6ca8b055918dfca375f97b70601c
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.LXpgf90
@@ -0,0 +1,17 @@
+LIBX = -L/usr/X11R6/lib -lX11 -lg2c
+
+LIBV5D = -L/usr/local/lib -lv5d
+LIBGRB = -L$(HOME)/make/gribex -lMvEmos_pgf
+#LIBGRB = -L$(HOME)/make/gribex/gribex13035 -lemos
+
+#############################################################################
+
+CPPFLAGS += -DLINUX -Dkey_swapio
+F77FLAGS +=
+F90FLAGS +=
+ifeq ($(B),64)
+F77FLAGS += -r8
+F90FLAGS += -r8
+endif
+LDFLAGS +=
+OBJS2=
diff --git a/LIBTOOLS/tools/diachro/Rules.SGI32 b/LIBTOOLS/tools/diachro/Rules.SGI32
new file mode 100644
index 0000000000000000000000000000000000000000..0a1f27e2d800382e5888ddba559104a6f0205619
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.SGI32
@@ -0,0 +1,18 @@
+LIBX = -lX11
+LIBV5D = -L$(DIR_LIB)/vis5d/$(ARCH) -lv5d
+#LIBV5D = /scratch/us/usl/vis5d-5.2/src/v5d.o \
+# /scratch/us/usl/vis5d-5.2/src/binio.o
+LIBGRB = -lemos
+
+#############################################################################
+CPPFLAGS += -DO2000
+ifeq ($(shell hostname),rhodes)
+CPPFLAGS += -DRHODES
+endif
+F77FLAGS += -O1
+F90FLAGS += -O1
+ifeq ($(B),64)
+F90FLAGS += -r8
+endif
+LDFLAGS +=
+OBJS2 =
diff --git a/LIBTOOLS/tools/diachro/Rules.SGI64 b/LIBTOOLS/tools/diachro/Rules.SGI64
new file mode 100644
index 0000000000000000000000000000000000000000..48cc03fa7f001c4100fec64e4f012960fa29a1f8
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.SGI64
@@ -0,0 +1,13 @@
+LIBEXT = -lX11
+#############################################################################
+CPPFLAGS += -DO2000
+ifeq ($(shell hostname),rhodes)
+CPPFLAGS += -DRHODES
+endif
+F77FLAGS += -O1
+F90FLAGS += -O1
+ifeq ($(B),64)
+F90FLAGS += -r8
+endif
+
+OBJS2=
diff --git a/LIBTOOLS/tools/diachro/Rules.SX5 b/LIBTOOLS/tools/diachro/Rules.SX5
new file mode 100644
index 0000000000000000000000000000000000000000..48d6ce72211bb92898979c4a7acac42aa4548a18
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.SX5
@@ -0,0 +1,13 @@
+#
+# Pas de diaprog sur SX5
+#
+PROGALL = conv2dia
+#
+#############################################################################
+CPPFLAGS += -DVPP
+F77FLAGS +=
+F90FLAGS +=
+LDFLAGS +=
+
+OBJS2=
+
diff --git a/LIBTOOLS/tools/diachro/Rules.SX8 b/LIBTOOLS/tools/diachro/Rules.SX8
new file mode 100644
index 0000000000000000000000000000000000000000..d9d52bb4fdfa9073e01ec9760207b97e15dc544f
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.SX8
@@ -0,0 +1,15 @@
+#
+# Pas de diaprog sur SX5
+#
+PROGALL = conv2dia
+#
+#############################################################################
+CPPFLAGS += -DVPP
+F77FLAGS +=
+ifeq ($(B),64)
+F90FLAGS += -dw -Wf, ' -A dbl4 '
+endif
+LDFLAGS +=
+
+OBJS2=
+
diff --git a/LIBTOOLS/tools/diachro/Rules.VPP b/LIBTOOLS/tools/diachro/Rules.VPP
new file mode 100644
index 0000000000000000000000000000000000000000..d593e4333ef14c84efeb64f19d78c02f3401cca4
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/Rules.VPP
@@ -0,0 +1,15 @@
+LIBGRB = -L/usr/local/lib -lemos_000200
+LIBV5D = -L$(MESONH)/binaries -lv5d_v51
+#LIBV5D = -L$(MESONH)/binaries -lv5d_v51 -L/usr/local/lib -lemosR64_1303g
+#############################################################################
+PROGALL = conv2dia lfi2grb
+
+CPPFLAGS += -DVPP
+ifeq ($(B),64)
+F77FLAGS += -Ad
+F90FLAGS += -Ad
+endif
+LDFLAGS += -Wl,-zdummy_verbose
+
+OBJS2=
+
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/alloc2_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/alloc2_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..eb5a4ae7af916daf947272cebcdd8053e091e512
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/alloc2_fordiachro.f90
@@ -0,0 +1,170 @@
+! ######spl
+ MODULE MODI_ALLOC2_FORDIACHRO
+! ##############################
+!
+INTERFACE
+!
+SUBROUTINE ALLOC2_FORDIACHRO(KOP)
+INTEGER :: KOP
+END SUBROUTINE ALLOC2_FORDIACHRO
+!
+END INTERFACE
+!
+END MODULE MODI_ALLOC2_FORDIACHRO
+! ######spl
+ SUBROUTINE ALLOC2_FORDIACHRO(KOP)
+! #################################
+!
+!!**** *ALLOC2_FORDIACHRO* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/01/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_ALLOC2_FORDIACHRO
+USE MODD_RESOLVCAR
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODD_FILES_DIACHRO
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+INTEGER :: KOP
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+!------------------------------------------------------------------------------
+!
+IF (KOP == 1)THEN
+
+ ALLOCATE(XDATIME2(SIZE(XDATIME,1),SIZE(XDATIME,2)))
+ XDATIME2(:,:)=XDATIME(:,:)
+ ALLOCATE(XVAR2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3), &
+ SIZE(XVAR,4),SIZE(XVAR,5),SIZE(XVAR,6)))
+ XVAR2(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+! print *,' XVAR2 ',XVAR2
+ IF(ALLOCATED(XU))THEN
+ ALLOCATE(XUMEM(SIZE(XU,1),SIZE(XU,2),SIZE(XU,3), &
+ SIZE(XU,4),SIZE(XU,5),SIZE(XU,6)))
+ XUMEM(:,:,:,:,:,:)=XU(:,:,:,:,:,:)
+ if(nverbia > 0)THEN
+ print *,' ** ALLOC2 XUMEM alloue'
+ endif
+ ENDIF
+ IF(ALLOCATED(XV))THEN
+ ALLOCATE(XVMEM(SIZE(XV,1),SIZE(XV,2),SIZE(XV,3), &
+ SIZE(XV,4),SIZE(XV,5),SIZE(XV,6)))
+ XVMEM(:,:,:,:,:,:)=XV(:,:,:,:,:,:)
+ ENDIF
+ ALLOCATE(XTRAJT2(SIZE(XTRAJT,1),SIZE(XTRAJT,2)))
+ XTRAJT2(:,:)=XTRAJT(:,:)
+ ALLOCATE(NGRIDIA2(SIZE(NGRIDIA)))
+ NGRIDIA2(:)=NGRIDIA(:)
+ ALLOCATE(CTITRE2(SIZE(CTITRE)))
+ CTITRE2(:)(1:LEN(CTITRE2))=' '
+ CTITRE2(:)=CTITRE(:)
+ ALLOCATE(CUNITE2(SIZE(CUNITE)))
+ CUNITE2(:)(1:LEN(CUNITE2))=' '
+ CUNITE2(:)=CUNITE(:)
+ ALLOCATE(CCOMMENT2(SIZE(CCOMMENT)))
+ CCOMMENT2(:)(1:LEN(CCOMMENT2))=' '
+ CCOMMENT2(:)=CCOMMENT(:)
+
+ IF(ALLOCATED(XTRAJX))THEN
+ ALLOCATE(XTRAJX2(SIZE(XTRAJX,1),SIZE(XTRAJX,2),SIZE(XTRAJX,3)))
+ XTRAJX2(:,:,:)=XTRAJX(:,:,:)
+ ENDIF
+ IF(ALLOCATED(XTRAJY))THEN
+ ALLOCATE(XTRAJY2(SIZE(XTRAJY,1),SIZE(XTRAJY,2),SIZE(XTRAJY,3)))
+ XTRAJY2(:,:,:)=XTRAJY(:,:,:)
+ ENDIF
+ IF(ALLOCATED(XTRAJZ))THEN
+ ALLOCATE(XTRAJZ2(SIZE(XTRAJZ,1),SIZE(XTRAJZ,2),SIZE(XTRAJZ,3)))
+ XTRAJZ2(:,:,:)=XTRAJZ(:,:,:)
+ ENDIF
+
+ IF (ALLOCATED(XMASK))THEN
+ ALLOCATE(XMASK2(SIZE(XMASK,1),SIZE(XMASK,2),SIZE(XMASK,3), &
+ SIZE(XMASK,4),SIZE(XMASK,5),SIZE(XMASK,6)))
+ XMASK2(:,:,:,:,:,:)=XMASK(:,:,:,:,:,:)
+ ENDIF
+ NUMFILECUR2=NUMFILECUR
+
+ELSE
+
+ IF (ALLOCATED(XMASK2))THEN
+ DEALLOCATE(XMASK2)
+ ENDIF
+ IF (ALLOCATED(XTRAJZ2))THEN
+ DEALLOCATE(XTRAJZ2)
+ ENDIF
+ IF (ALLOCATED(XTRAJY2))THEN
+ DEALLOCATE(XTRAJY2)
+ ENDIF
+ IF (ALLOCATED(XTRAJX2))THEN
+ DEALLOCATE(XTRAJX2)
+ ENDIF
+ DEALLOCATE(CCOMMENT2,CUNITE2,CTITRE2)
+ IF(ALLOCATED(NGRIDIA2))THEN
+ DEALLOCATE(NGRIDIA2)
+ ENDIF
+ DEALLOCATE(XTRAJT2)
+! DEALLOCATE(XVAR2,XTRAJT2,CTITRE2,CUNITE2,CCOMMENT2)
+ IF(ALLOCATED(XVMEM))THEN
+ DEALLOCATE(XVMEM)
+ ENDIF
+ IF(ALLOCATED(XUMEM))THEN
+ DEALLOCATE(XUMEM)
+ if(nverbia > 0)THEN
+ print *,' ** ALLOC2 XUMEM desalloue'
+ endif
+ ENDIF
+ DEALLOCATE(XVAR2)
+ DEALLOCATE(XDATIME2)
+
+ENDIF
+
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE ALLOC2_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/axelogpres.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/axelogpres.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f173d1c34ef9c77cded99ab4b3a970e914a6d6b0
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/axelogpres.f90
@@ -0,0 +1,104 @@
+! ######spl
+ SUBROUTINE AXELOGPRES(PHMIN,PHMAX)
+! ##################################
+!
+!!**** *AXELOGPRES* -
+!!****
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 20/10/2000
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!USE MODD_RESOLVCAR
+USE MODD_PVT
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments and results
+!
+REAL :: PHMIN,PHMAX
+!
+!* 0.2 Local variables
+!
+INTEGER :: J, JA, ID
+!
+REAL :: ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+CHARACTER(LEN=5) :: YCAR
+!
+!-------------------------------------------------------------------------------
+!
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+IF(LPRESY)THEN
+IF(XPMAX /= 0. .AND. XPMIN /= 0. .AND. XPINT /= 0.)THEN
+ IF(XPMIN < 1300.)THEN
+ XPMAX=XPMAX*100.
+ XPMIN=XPMIN*100.
+ XPINT=XPINT*100.
+ ENDIF
+DO J=INT(XPMIN),INT(XPMAX),-INT((ABS(XPINT)))
+ IF(FLOAT(J) >= ANINT(ZWT) .AND. FLOAT(J) <= ANINT(ZWB))THEN
+ YCAR=' '
+ IF(XPINT > 1000.)THEN
+ WRITE(YCAR,'(F5.0)')FLOAT(J)/100.
+ ELSE
+ WRITE(YCAR,'(F5.0)')FLOAT(J)
+ ENDIF
+ YCAR=ADJUSTR(YCAR)
+ CALL PLCHHQ(ZWL-ZWL/110.,FLOAT(J),YCAR,13.,0.,1.)
+ CALL FRSTPT(ZWL,FLOAT(J))
+ CALL VECTOR(ZWL+(ZWR-ZWL)/(ZVR-ZVL)*.015,FLOAT(J))
+ ENDIF
+ENDDO
+ELSE
+ IF(PHMIN < 1300)THEN
+ PHMIN=PHMIN*100
+ PHMAX=PHMAX*100
+ ENDIF
+DO J=INT(PHMIN),INT(PHMAX),-10000
+ IF(FLOAT(J) >= ANINT(ZWT) .AND. FLOAT(J) <= ANINT(ZWB))THEN
+ YCAR=' '
+ IF(PHMAX > 1300.)THEN
+ WRITE(YCAR,'(F5.0)')FLOAT(J)/100.
+ ELSE
+ WRITE(YCAR,'(F5.0)')FLOAT(J)
+ ENDIF
+ YCAR=ADJUSTR(YCAR)
+ print *,' **axelogpres PHMIN,PHMAX ',PHMIN,PHMAX
+ print *,' **axelogpres ZWL-ZWL/20.,FLOAT(J),YCAR ',ZWL-ZWL/20.,FLOAT(J),YCAR
+ CALL PLCHHQ(ZWL-ZWL/100.,FLOAT(J),YCAR,13.,0.,1.)
+ CALL FRSTPT(ZWL,FLOAT(J))
+ CALL VECTOR(ZWL+(ZWR-ZWL)/(ZVR-ZVL)*.015,FLOAT(J))
+ ENDIF
+ENDDO
+ENDIF
+ELSE
+ENDIF
+!* 2. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE AXELOGPRES
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/bcgrd_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/bcgrd_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8b776a4bbe10dbd7cb48238ed20c8147ca87cf3a
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/bcgrd_fordiachro.f90
@@ -0,0 +1,868 @@
+! ######spl
+ SUBROUTINE BCGRD_FORDIACHRO(K)
+! ##############################
+!
+!!**** *BCGRD* - Displays a cartographic background in horizontal mode
+!!
+!! PURPOSE
+!! -------
+! Displays a cartographic background for horizontal cross-section
+! contour or arrow maps when the cartographic projection option is
+! active.
+! The geographical display window is defined, a grid of latitude-
+! longitude lines, a set of continental/state outlines and, optionaly,
+! a series of landmarks, are plotted on this background.
+!
+!!** METHOD
+!! ------
+!!
+!! The conformal projection routines of MODE_GRIDPROJ are used to
+!! compute the latitude-longitude coordinates of the display box.
+!! Next, the NCAR Ezmap projection parameters are set up to
+!! correspond to the Meso-NH projection, and a grid of latitude-
+! longitude lines, a set of continental/state outlines and, optionaly,
+! a series of landmarks, are plotted as an overlay on the current map.
+!!
+!! EXTERNAL
+!! --------
+!!
+!! MAPSTI ! set an NCAR parameter to a valuei, type INTEGER !
+!! MAPSTC ! (cartographic projection package) CHARACTER !
+!! MAPROJ selects a type cartographic projection !
+!! MAPDRW draws a map as specified by the user parameter !
+!! choice !
+!! MAPIT draws a polyline on a map, using map coordinates ! NCAR
+!! MAPIQ terminates a line drawn by MAPIT !
+!! MAPSET defines the plot window using map coordinates !
+!! MAPTRN projects a point onto a geographic map using !
+!! latitude-longitude to locate the point !
+!! !
+!! PWRITX prints a text !
+!! LABMOD defines the axes label formats (paired with PERIM) !Routines
+!! GRIDAL draws grid lines and labels !
+!! PERIM draws an unlabeled plot perimeter !
+!! SET defines the plot window and viewport using user !
+!! and normalized NCAR coordinates !
+!! GETSET retrieves the NCAR and user coordinate definitions !
+!! PLCHHQ high quality printing facility !
+!! GSCLIP clips the plot using the window limits !
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_NMGRID : declares global variable NMGRID
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!! Module MODE_GRIDPROJ: packages a set of cartographic
+!! module-procedures
+!! SM_LATLON : to compute geographic from conformal (cartographic)
+!! cartesian coordinates;
+!! SM_XYHAT : to compute conformal (cartographic) cartesian from
+!! geographic coordinates;
+!! LATREF2 : to compute the second reference latitude
+!! in the case of Lambert conformal projection
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX,XXY : coordinate values FOR ALL the MESO-NH grids
+!!
+!! Module MODD_GRID1 : declares grid variables (Model module)
+!! XXHAT, XYHAT : x, y cartographic coordinates of the model grid
+!! XLONOR,XLATOR : longitude and latitude of the (1,1,1) point of
+!! the model mass grid
+!!
+!! Module MODD_GRID : declaration of grid variables for all models
+!! XLON0,XLAT0 : reference longitude and latitude for the conformal
+!! projection
+!! XBETA,XRPK : rotation angle and projection parameter for the
+!! conformal projection
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!! NIFDC : Coastline data style (0 none, 1 NCAR, 2 IGN)
+!! NLPCAR : Number of land-mark points to be plotted
+!! XLONCAR : Longitude of land-mark points
+!! XLATCAR : Latitude of land-mark points
+!!
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist (former PARA common)
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NIINF, NISUP : lower and upper bounds of arrays
+!! to be plotted in x direction
+!! NJINF, NJSUP : lower and upper bounds of arrays
+!! to be plotted in y direction
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 12/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_NMGRID
+USE MODD_RADAR
+USE MODE_GRIDPROJ
+USE MODD_COORD
+USE MODD_MASK3D
+USE MODD_TRAJ3D
+USE MODD_RESOLVCAR
+USE MODD_GRID1
+USE MODD_GRID
+USE MODD_CTL_AXES_AND_STYL
+USE MODN_NCAR
+USE MODN_PARA
+USE MODI_CREATLINK
+USE MODI_WRITEDIR
+
+IMPLICIT NONE
+
+COMMON/EPAISCONT/ZLWCONT
+COMMON/FDC/IFDC
+
+INTEGER :: K
+!
+!* 0.1 Local variables
+!
+REAL :: ZLWCONT
+REAL :: ZLAT2, ZLAT, ZLON
+REAL,SAVE :: ZZLAT, ZZLON
+REAL :: ZPL1, ZPL2, ZPL3, ZPL4
+REAL :: ZX1, ZX2, ZY1, ZY2, ZXX1, ZXX2, ZYY1, ZYY2
+REAL :: ZU, ZV, ZSZ, ZPOS, ZCENT
+REAL :: ZI, ZJ, ZX, ZY
+INTEGER :: ICONVI, ICONVJ
+REAL :: ZXMIN, ZXMAX,ZYMIN, ZYMAX
+REAL :: ZWIDTH
+CHARACTER(LEN=40),SAVE :: YCAR40=' '
+CHARACTER(LEN=80),SAVE :: YCAR80=' '
+CHARACTER(LEN=1) :: YSYMB
+CHARACTER(LEN=20) :: YNOM
+CHARACTER(LEN=10) :: FORMAX, FORMAY
+
+INTEGER :: JIP, IT, IDUM, IRPK, JLPCAR,JIJCAR, J,IIT
+INTEGER :: IERR, IPOS, ICOLS, ICOLN
+INTEGER :: IFDC
+!!!!!!!!!!!!!! Modif VD (29/10/2003)
+INTEGER :: IDOT,IPT,IDOT0,IPT0,JLOOP
+REAL, DIMENSION(200000) :: ZZU,ZZV,ZZU0,ZZV0
+!!!!!!!!!!!!!! fin Modif VD
+LOGICAL :: GIND,GCONF
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. SETS CARTOGRAPHIC PROJECTION AND DRAWS BACKGROUND MAP
+! -----------------------------------------------------
+!
+!
+!* 1.1 If Lambert case, computes the second reference latitude
+! (required by the NCAR framework for Lambert)
+!
+IF(L2CONT)THEN
+ IFDC=NIFDC
+ELSE
+ IF(K == 1)THEN
+ IFDC=0
+ ELSE
+ IFDC=NIFDC
+ ENDIF
+ENDIF
+!!!!IFDC=NIFDC
+IF(ABS(XRPK).GT.0..AND.ABS(XRPK).LT.1.)THEN
+ IF(NVERBIA >= 5)THEN
+ print *,' bcgrd XLAT0,XRPK ',XLAT0,XRPK
+ ENDIF
+ ZLAT2=LATREF2(XLAT0,XRPK)
+ IF(NVERBIA >= 5)THEN
+ print *,' bcgrd ZLAT2 ',ZLAT2
+ ENDIF
+ENDIF
+!
+!* 1.2 Convert display window diagonal to cartographic coordinates
+!
+! (The main diagonal of the displayed domain is given by Meso-NH
+! indexes NIINF-NJINF, NISUP-NJSUP)
+!
+!ZXMIN=100000.
+ZXMIN=XXX(NIINF,NMGRID)
+ZYMIN=XXY(NJINF,NMGRID)
+!ZXMAX=2500000.
+ZXMAX=XXX(NISUP,NMGRID)
+ZYMAX=XXY(NJSUP,NMGRID)
+IF(NVERBIA >= 2)THEN
+ print *,' ** bcg NIINF,NJINF,NMGRID,NISUP,NJSUP ',NIINF,NJINF,NMGRID,NISUP,NJSUP
+ENDIF
+!
+CALL SM_LATLON_S(XLATORI,XLONORI,ZXMIN,ZYMIN,ZPL1,ZPL2)
+CALL SM_LATLON_S(XLATORI,XLONORI,ZXMAX,ZYMAX,ZPL3,ZPL4)
+IF(NVERBIA >= 2)THEN
+ print *,' ZXMIN,ZYMIN,ZXMAX,ZYMAX ',ZXMIN,ZYMIN,ZXMAX,ZYMAX
+ print *,' XLATORI,XLONORI,ZPL1,ZPL2,ZPL3,ZPL4 ',XLATORI,XLONORI,ZPL1,ZPL2,ZPL3,ZPL4
+ print *,' XLATO,XLONO ',XLAT0,XLON0
+ENDIF
+!
+!* 1.3 Selects a standard NCAR continental/state outline mode
+!* and visual details
+!
+! -> NCAR default : call mapstc('OU','PO')
+! -> None : call mapstc('OU','NO')
+!
+!IF (NIFDC.NE.1)THEN
+IF (NIFDC.EQ.1 .OR. NIFDC.EQ.3)THEN
+ CALL MAPSTC('OU','PO')
+ELSE
+ CALL MAPSTC('OU','NO')
+ENDIF
+!
+CALL MAPSTI('DO',0) ! Solid coastlines
+!CALL MAPSTI('DO',1) ! Dotted coastlines
+CALL MAPSTI('RE',10000) ! Plotter resolution
+CALL MAPSTI('DL',0) ! MAPIT draws solid lines
+!CALL MAPSTI('DL',1) ! MAPIT draws dotted lines
+!CALL MAPSTI('GR',NIGRNC) ! Grid spacing in degrees
+if(nverbia > 0)then
+ print *,' **bcgrd AV CALL MAPSTI(GR,0)'
+endif
+IF(K == 1)THEN
+ CALL MAPSTI('GR',0) ! Grid spacing in degrees
+ELSE IF(K == 2)THEN
+ IF(LANIMK )THEN
+ ELSE
+ CALL MAPSTI('GR',NIGRNC) ! Grid spacing in degrees
+ ENDIF
+ENDIF
+!
+!* 1.4 Selects NCAR cartographic projection
+!
+IRPK=2
+IF(XRPK.EQ.0.)IRPK=0
+! Oct 99 Pole Sud Proj. stereog.
+IF(ABS(XRPK).EQ.1.)IRPK=1
+! Oct 99 Pole Sud Proj. stereog.
+!IF(XRPK.EQ.1.)IRPK=1
+!write(0,*)' BCGRD IRPK ',IRPK
+!
+SELECT CASE(IRPK)
+ CASE(0)
+ CALL MAPROJ('ME',0.,XLON0,XBETA) ! Mercator
+ CASE(1)
+ CALL MAPROJ('ST',90.,XLON0,-XBETA) ! Polar Stereographic
+! Oct 99 Pole Sud Proj. stereog.
+! BESOIN DE VERIFIER si dans ce cas on met XBETA ou -XBETA
+ IF(XRPK < 0.)CALL MAPROJ('ST',-90.,XLON0,-XBETA)
+! Oct 99 Pole Sud Proj. stereog.
+ CASE DEFAULT
+ CALL MAPROJ('LC',XLAT0,XLON0+XBETA/XRPK,ZLAT2) ! Lambert
+END SELECT
+!
+!* 1.5 Sets map transformation, map display window
+!* and draws lat-lon grid
+!
+IF(LVPTUSER)THEN
+ CALL MAPPOS(XVPTL,XVPTR,XVPTB,XVPTT)
+ELSE
+ CALL MAPPOS(.05,.95,.05,.95)
+ENDIF
+CALL MAPSET('CO',ZPL1,ZPL2,ZPL3,ZPL4)
+IF(XLWCONT /= 0.)THEN
+ ZLWCONT=XLWCONT
+ELSE
+ ZLWCONT=5.
+ENDIF
+!
+! Pour V4.1.1 A la place de CALL MAPDRW a mettre en commentaire
+! Non c'est fait EN PRINCIPE dans MAPDRW qui est inclus dans le fichier frame
+!CALL MAPINT
+!CALL MAPGRD
+!CALL MAPLBL
+!CALL MPLNDR('Earth..1',3)
+if(nverbia > 0)then
+ print *,' **bcgrd AV CALL MAPDRW'
+endif
+CALL MAPDRW
+!
+!* 1.6 Use of non-NCAR coastline data sets if available
+!* (ex. IGN ones) on fortran unit 1
+!
+! NOTICE: The use of fortran unit 1 here does not
+! fit Meso-NH file access norm
+!
+IF((NIFDC.EQ.2 .OR. NIFDC.EQ.3) .AND. K.EQ.2)THEN
+ IF(YCAR40(1:LEN(YCAR40)) == ' ')THEN
+ print *,'ENTREZ le nom du fichier des contours (geograp. ou polit....) '
+ !print *,' avec un PATH ABSOLU (40 caracteres maximum) et entre quotes'
+ print *,' entre quotes (40 caracteres maximum)'
+ READ(5,*)YCAR40
+ YCAR40=ADJUSTL(YCAR40)
+ YCAR80(1:1)="'"
+ YCAR80(2:LEN_TRIM(YCAR40)+1)=YCAR40(1:LEN_TRIM(YCAR40))
+ YCAR80(LEN_TRIM(YCAR40)+2:LEN_TRIM(YCAR40)+2)="'"
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,YCAR80)
+ CALL CREATLINK('DIRFDC',YCAR40(1:LEN_TRIM(YCAR40)),'CREAT',NVERBIA)
+! print *,YCAR40
+ ENDIF
+ OPEN(1,FILE=YCAR40(1:LEN_TRIM(YCAR40)),FORM='FORMATTED',STATUS='OLD') ! Opens coastline file
+! OPEN(1,FILE='/u/m/mrmh/mrmh005/mesonh/data/cotign') ! Opens coastline file
+ CALL GSCLIP(0)
+ CALL GQLWSC(IERR,ZWIDTH)
+ IF(XLWCONT /= 0.)THEN
+ ZLWCONT=XLWCONT
+ ELSE
+ ZLWCONT=4.
+ ENDIF
+ CALL GSLWSC(ZLWCONT)
+!
+!!!!!!!!! MODIF VD TO introduce dashed lines with NIFDC=2 (29/10/2003)
+! Initial coordinate transformation saved
+ CALL GETSET(ZX1,ZX2,ZY1,ZY2,ZXX1,ZXX2,ZYY1,ZYY2,IDUM)
+! Initial coordinate transformation restored
+ CALL SET(ZX1,ZX2,ZY1,ZY2,ZXMIN,ZXMAX,ZYMIN,ZYMAX,IDUM)
+ IPT=0
+ IPT0=0
+ IDOT=838860 ! dashed pattern used for dashed lines (IT=2 or 3)
+ IDOT0=65535 ! dashed pattern used for solid lines (IT=0 or 1)
+ DO JIP=1,200000
+ READ(1,*,END=50)ZLAT,ZLON,IT ! Reads coastline file
+ IF(JIP == 1)print *,' 1er enr. ',ZLAT,ZLON,IT
+! IF(ABS(ZZLAT-ZLAT) > .2 .OR. ABS(ZZLON-ZLON) > .2)THEN
+! print *,'ZZLAT,ZLAT,ZZLON,ZLON ',ZZLAT,ZLAT,ZZLON,ZLON
+! IT=0
+! CALL MAPIT(ZLAT,ZLON,IT) ! Draws IGN one coastline point
+! ELSE
+! CALL MAPIT(ZLAT,ZLON,IT) ! Draws IGN one coastline point
+! ENDIF
+ !ZZLAT=ZLAT
+ !ZZLON=ZLON
+ CALL SM_XYHAT_S(XLATORI,XLONORI,ZLAT,ZLON,ZU,ZV)
+!
+ IF (IT==2 .OR. IT==3) THEN
+ IF (IT==2) THEN
+ IF (IPT>0) THEN
+ CALL DASHDB(IDOT)
+ CALL CURVED(ZZU,ZZV,IPT)
+ ENDIF
+ IPT=0
+ IF ((ZU>= ZXMIN).AND.(ZU<=ZXMAX).AND.(ZV>=ZYMIN).AND.(ZV<=ZYMAX)) THEN
+ IPT=IPT+1
+ ZZU(IPT)=ZU
+ ZZV(IPT)=ZV
+ ENDIF
+ ELSE
+ IF ((ZU>= ZXMIN).AND.(ZU<=ZXMAX).AND.(ZV>=ZYMIN).AND.(ZV<=ZYMAX)) THEN
+ IPT=IPT+1
+ ZZU(IPT)=ZU
+ ZZV(IPT)=ZV
+ END IF
+ ENDIF
+ ELSE
+
+ IF (IT==0) THEN ! begin of the definition of the
+ IF (IPT0>0) THEN
+ CALL DASHDB(IDOT0)
+ CALL CURVED(ZZU0,ZZV0,IPT0)
+ ENDIF
+ IPT0=0
+ IF ((ZU>= ZXMIN).AND.(ZU<=ZXMAX).AND.(ZV>=ZYMIN).AND.(ZV<=ZYMAX)) THEN
+ IPT0=IPT0+1
+ ZZU0(IPT0)=ZU
+ ZZV0(IPT0)=ZV
+ ENDIF
+ ELSE
+ IF ((ZU>= ZXMIN).AND.(ZU<=ZXMAX).AND.(ZV>=ZYMIN).AND.(ZV<=ZYMAX)) THEN
+ IPT0=IPT0+1
+ ZZU0(IPT0)=ZU
+ ZZV0(IPT0)=ZV
+ END IF
+ ENDIF
+ ENDIF
+!
+ ENDDO
+50 CONTINUE
+! finish to draw the last curves :
+ print *,' Dernier enr. ',ZLAT,ZLON,IT
+ !CALL MAPIQ
+ IF (IPT>0) THEN
+ CALL DASHDB(IDOT)
+ CALL CURVED(ZZU,ZZV,IPT)
+ ENDIF
+ IF (IPT0>0) THEN
+ CALL DASHDB(IDOT0)
+ CALL CURVED(ZZU0,ZZV0,IPT0)
+ ENDIF
+!!!!!!!!!!!!!!!!!!! fin modif VD
+ CALL GSCLIP(1) ! Clipping of extra coastline
+ CLOSE(1)
+ CALL GSLN(1) ! restore solid line
+ CALL GSLWSC(ZWIDTH)
+ENDIF
+!
+!* 1.7 Formats and write Map axes with appropriate labels
+!* and axes scale labels
+!
+! Initial coordinate transformation saved
+CALL GETSET(ZX1,ZX2,ZY1,ZY2,ZXX1,ZXX2,ZYY1,ZYY2,IDUM)
+! Sets NCAR user coordinates
+GIND=.NOT.LGEOG .OR. &
+!!!!!!!!!!!!!!! JOEL!!!!!!!!!!!!
+ (.NOT.LGEOG .AND. &
+ (LXYZ00 .OR. LMASK3D .OR. LMASK3D_XY .OR. LMASK3D_XZ .OR. LMASK3D_YZ &
+! .OR. LMARKER .OR. LTRAJ3D .OR. LFLUX3D)
+ .OR. LMSKTOP .OR. LTRAJ3D .OR. LFLUX3D) .AND. LINDAX )
+GCONF= .NOT.LGEOG .AND. &
+ (LXYZ00 .OR. LMASK3D .OR. LMASK3D_XY .OR. LMASK3D_XZ .OR. LMASK3D_YZ &
+! .OR. LMARKER .OR. LTRAJ3D .OR. LFLUX3D)
+ .OR. LMSKTOP .OR. LTRAJ3D .OR. LFLUX3D) .AND. .NOT.LINDAX
+IF (GCONF) GIND=.FALSE.
+!!!!!!!!!!!!!!! JOEL!!!!!!!!!!!!
+
+! limites du domaine en indices de grille
+IF(GIND)THEN
+ CALL SET(ZX1,ZX2,ZY1,ZY2,FLOAT(NIINF),FLOAT(NISUP), &
+ FLOAT(NJINF),FLOAT(NJSUP),IDUM)
+!>>>>>>>>>>>>This section is to be revised***********************
+
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F5.1)'
+ ENDIF
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F5.1)'
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F5.1)','(F5.1)',0,0,10,10,0,0,0)
+!CALL GASETI('LTY',1)
+
+ IF(NCHPCITVXMJ /= 0 .OR. NCHPCITVYMJ /=0 .OR. NCHPCITVXMN /= 0 .OR. &
+ NCHPCITVXMN /= 0)THEN
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCHPCITVXMJ,NCHPCITVXMN,NCHPCITVYMJ,NCHPCITVXMN,0,0,5,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCHPCITVXMJ,NCHPCITVXMN,NCHPCITVYMJ,NCHPCITVXMN,0,1,5,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCHPCITVXMJ,NCHPCITVXMN,NCHPCITVYMJ,NCHPCITVXMN,1,0,5,0.,0.)
+ ELSE
+ CALL GRIDAL(NCHPCITVXMJ,NCHPCITVXMN,NCHPCITVYMJ,NCHPCITVXMN,1,1,5,0.,0.)
+ ENDIF
+!Avril 2002
+
+ ELSE
+ IF(NISUP > 99)THEN
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(I4)'
+ ENDIF
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(I2)'
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(I3)','(I2)',0,0,10,10,0,0,0)
+! CALL LABMOD('(I3)','(I2)',3,2,10,10,0,0,0)
+ IF(NJSUP > 99)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(I4)'
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(I3)','(I3)',0,0,10,10,0,0,0)
+! CALL LABMOD('(I3)','(I3)',3,3,10,10,0,0,0)
+ ENDIF
+ ELSE
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(I2)'
+ ENDIF
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(I2)'
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(I2)','(I2)',0,0,10,10,0,0,0)
+! CALL LABMOD('(I2)','(I2)',2,2,10,10,0,0,0)
+ IF(NJSUP > 99)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(I4)'
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(I2)','(I3)',0,0,10,10,0,0,0)
+! CALL LABMOD('(I2)','(I3)',2,3,10,10,0,0,0)
+ ENDIF
+ ENDIF
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(1,NISUP-NIINF,1,NJSUP-NJINF,0,0,5,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(1,NISUP-NIINF,1,NJSUP-NJINF,0,1,5,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(1,NISUP-NIINF,1,NJSUP-NJINF,1,0,5,0.,0.)
+ ELSE
+ CALL GRIDAL(1,NISUP-NIINF,1,NJSUP-NJINF,1,1,5,0.,0.)
+ !CALL PERIM(NISUP-NIINF,1,NJSUP-NJINF,1)
+ ENDIF
+!Avril 2002
+ ENDIF
+ENDIF
+!
+!!!!!!!!!!!!!!! JOEL!!!!!!!!!!!!
+! limites du domaine en coord. conf. (pour lachers de part. LMASK3D)
+IF(GCONF) THEN
+ CALL SET(ZX1,ZX2,ZY1,ZY2,ZXMIN,ZXMAX,ZYMIN,ZYMAX,1)
+ CALL LABMOD('(F8.0)','(F8.0)',0,0,NSZLBX,NSZLBY,12,0,0)
+ CALL GRIDAL(1,NISUP-NIINF,1,NJSUP-NJINF,1,1,5,0.,0.)
+ENDIF
+!!!!!!!!!!!!!!! JOEL!!!!!!!!!!!!
+!
+! limites du domaine en lat/lon
+IF (LGEOG) THEN
+ CALL SET(ZX1,ZX2,ZY1,ZY2,ZPL2,ZPL4,ZPL1,ZPL3,IDUM)
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F5.1)'
+ ENDIF
+ IF(ZPL2 < -99. .OR. ZPL4 < -99.)THEN
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F6.1)'
+ ENDIF
+! Ai mis 12 pour rapprocher les labels Y de l'axe; sinon troncature
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,12,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,12,0,0)
+! CALL LABMOD('(F6.1)','(F5.1)',0,0,10,10,12,0,0)
+! CALL LABMOD('(F6.1)','(F5.1)',6,5,10,10,0,0,0)
+ ELSE
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F6.2)'
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,12,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,12,0,0)
+! CALL LABMOD('(F6.2)','(F5.1)',0,0,10,10,12,0,0)
+! CALL LABMOD('(F6.2)','(F5.1)',6,5,10,10,0,0,0)
+ ENDIF
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCHPCITVXMJ,NCHPCITVXMN,NCHPCITVYMJ,NCHPCITVXMN,0,0,5,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCHPCITVXMJ,NCHPCITVXMN,NCHPCITVYMJ,NCHPCITVXMN,0,1,5,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCHPCITVXMJ,NCHPCITVXMN,NCHPCITVYMJ,NCHPCITVXMN,1,0,5,0.,0.)
+ ELSE
+ CALL GRIDAL(NCHPCITVXMJ,NCHPCITVXMN,NCHPCITVYMJ,NCHPCITVXMN,1,1,5,0.,0.)
+ ENDIF
+!Avril 2002
+ENDIF
+! Initial coordinate transformation restored
+CALL SET(ZX1,ZX2,ZY1,ZY2,ZXX1,ZXX2,ZYY1,ZYY2,IDUM)
+!
+!* 1.8 A series of landmarks is added to the plot when required
+!
+!!! Enleve le 30/8/99 pour travailler avec les coordonnees conformes ci-apres
+! verifie que idem
+!IF(NLPCAR.GE.1)THEN
+! DO JLPCAR=1,NLPCAR
+! CALL MAPTRN(XLATCAR(JLPCAR),XLONCAR(JLPCAR),ZU,ZV)
+!>>>>>>>May be, this section is to be revised*******************
+! CALL NGWSYM('N',8,ZU,ZV,.012,1,0)
+! Obsolete CALL PWRITX(ZU,ZV,'''KGU''-',6,20,0,0)
+! ENDDO
+!ENDIF
+! Initial coordinate transformation restored
+CALL SET(ZX1,ZX2,ZY1,ZY2,ZXMIN,ZXMAX,ZYMIN,ZYMAX,IDUM)
+if(nverbia > 0)then
+ print *,' **bcgrd AP CALL SET'
+endif
+
+IF(K == 2)THEN
+IF(NLPCAR.GE.1)THEN
+ IF(.NOT.LCOLAREA .AND. .NOT.LCOLINE)THEN
+ call tabcol_fordiachro
+ ENDIF
+ IF(LUMVM .OR. LUTVT .AND. NSUPERDIA == 1)THEN
+ call tabcol_fordiachro
+ ENDIF
+ DO JLPCAR=1,NLPCAR
+ ZLAT=XLATCAR(JLPCAR)
+ ZLON=XLONCAR(JLPCAR)
+ YSYMB=CSYMCAR(JLPCAR)
+ ZPOS=XPOSNOM(JLPCAR)
+ ICOLS=ICOLSYM(JLPCAR)
+ ICOLN=ICOLNOM(JLPCAR)
+ IF(XSZSYM(JLPCAR) /= 0.)THEN
+ ZSZ=XSZSYM(JLPCAR)
+ IF(ZSZ == 9999.)ZSZ=.012
+ ELSE
+ ZSZ=.012
+ ENDIF
+ CALL SM_XYHAT_S(XLATORI,XLONORI,ZLAT,ZLON,ZU,ZV)
+! CALL GSTXCI(ICOLS)
+ CALL PCSETI('OC',ICOLS)
+ IF(YSYMB == '.')THEN
+ CALL NGWSYM('N',8,ZU,ZV,ZSZ,ICOLS,0)
+! CALL NGWSYM('N',8,ZU,ZV,ZSZ,1,0)
+ ELSE
+ CALL PCSETI('OF',2)
+ CALL PCSETR('OL',1.5)
+ CALL PLCHHQ(ZU,ZV,YSYMB,ZSZ,0.,0.)
+ CALL PCSETI('OF',0)
+ CALL PCSETR('OL',0.)
+ ENDIF
+ CALL PCSETI('OC',1)
+ IF(XSZNOM(JLPCAR) /= 0.)THEN
+ ZSZ=XSZNOM(JLPCAR)
+ IF(ZSZ == 9999.)ZSZ=.012
+ ELSE
+ ZSZ=.012
+ ENDIF
+ IPOS=ZPOS
+! print *,' ZSZ NOM ',ZSZ
+ SELECT CASE(IPOS)
+ CASE(0)
+ ZCENT=-1.
+ ZU=ZU+ZSZ*1.1*(ZXMAX-ZXMIN)
+ CASE(45)
+ ZCENT=-1.
+ ZU=ZU+ZSZ*1.0*(ZXMAX-ZXMIN)
+ ZV=ZV+ZSZ*1.0*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+ CASE(90)
+ ZCENT=0.
+ ZV=ZV+ZSZ*1.5*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+! ZV=ZV+ZSZ*1.5*(ZYMAX-ZYMIN)
+ CASE(135)
+ ZCENT=1.
+ ZU=ZU-ZSZ*1.0*(ZXMAX-ZXMIN)
+ ZV=ZV+ZSZ*1.0*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+! ZV=ZV+ZSZ*1.0*(ZYMAX-ZYMIN)
+ CASE(180)
+ ZCENT=1.
+ ZU=ZU-ZSZ*1.1*(ZXMAX-ZXMIN)
+ CASE(225)
+ ZCENT=1.
+ ZU=ZU-ZSZ*1.0*(ZXMAX-ZXMIN)
+ ZV=ZV-ZSZ*1.0*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+! ZV=ZV-ZSZ*1.0*(ZYMAX-ZYMIN)
+ CASE(270)
+ ZCENT=0.
+ ZV=ZV-ZSZ*1.5*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+! ZV=ZV-ZSZ*1.5*(ZYMAX-ZYMIN)
+ CASE(315)
+ ZCENT=-1.
+ ZU=ZU+ZSZ*1.0*(ZXMAX-ZXMIN)
+ ZV=ZV-ZSZ*1.0*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+! ZV=ZV-ZSZ*1.0*(ZYMAX-ZYMIN)
+ END SELECT
+ IF(CNOMCAR(JLPCAR) /= ' ')THEN
+ YNOM=CNOMCAR(JLPCAR)
+ YNOM=ADJUSTL(YNOM)
+ CALL PCSETI('OF',2)
+ CALL PCSETI('OC',ICOLN)
+ !CALL PCSETR('OL',1.5)
+ !MODIF SYLVIE D.: epaisseur des caracteres de CNOMSYM -> XLWNOM
+ CALL PCSETR('OL',XLWCONT)
+! CALL GSTXCI(ICOLN)
+! CALL GSPLCI(ICOLN)
+ CALL PLCHHQ(ZU,ZV,YNOM(1:LEN_TRIM(YNOM)),ZSZ,0.,ZCENT)
+! CALL PLCHHQ(ZU,ZV+ZSZ*1.5*(ZYMAX-ZYMIN),YNOM(1:LEN_TRIM(YNOM)),ZSZ,0.,ZCENT)
+ ENDIF
+ CALL PCSETI('OF',0)
+ CALL PCSETR('OL',0.)
+ CALL PCSETI('OC',1)
+ CALL GSTXCI(1)
+ ENDDO
+ENDIF
+IF(NIJCAR.GE.1)THEN
+ IF(.NOT.LCOLAREA .AND. .NOT.LCOLINE)THEN
+ call tabcol_fordiachro
+ ENDIF
+ DO JIJCAR=1,NIJCAR
+ ZI=XICAR(JIJCAR)
+ ZJ=XJCAR(JIJCAR)
+ print *,' **bcgrd_fordiachro ZI,ZJ ',ZI,ZJ
+ YSYMB=CSYMCAR(JIJCAR)
+ ZPOS=XPOSNOM(JIJCAR)
+ ICOLS=ICOLSYM(JIJCAR)
+ ICOLN=ICOLNOM(JIJCAR)
+ IF(XSZSYM(JIJCAR) /= 0.)THEN
+ ZSZ=XSZSYM(JIJCAR)
+ IF(ZSZ == 9999.)ZSZ=.012
+ ELSE
+ ZSZ=.012
+ ENDIF
+ ICONVI=INT(ZI)
+ ICONVJ=INT(ZJ)
+ if(nverbia > 0)then
+ print *,' **bcgrd_fordiachro ICONVI, ICONVJ ',ICONVI,ICONVJ
+ endif
+ ZX=XXX(ICONVI,NMGRID)+(XXX(MIN(ICONVI+1,SIZE(XXX,1)),NMGRID)-XXX(ICONVI,NMGRID))*(ZI-FLOAT(ICONVI))
+ ZY=XXY(ICONVJ,NMGRID)+(XXY(MIN(ICONVJ+1,SIZE(XXY,1)),NMGRID)-XXY(ICONVJ,NMGRID))*(ZJ-FLOAT(ICONVJ))
+ if(nverbia > 0)then
+ print *,' **bcgrd_fordiachro ZX,ZY ',ZX,ZY
+ endif
+ CALL PCSETI('OC',ICOLS)
+ IF(YSYMB == '.')THEN
+ CALL NGWSYM('N',8,ZX,ZY,ZSZ,ICOLS,0)
+ ELSE
+ CALL PCSETI('OF',2)
+ CALL PCSETR('OL',1.5)
+ CALL PLCHHQ(ZX,ZY,YSYMB,ZSZ,0.,0.)
+ CALL PCSETI('OF',0)
+ CALL PCSETR('OL',0.)
+ ENDIF
+ CALL PCSETI('OC',1)
+ IF(XSZNOM(JIJCAR) /= 0.)THEN
+ ZSZ=XSZNOM(JIJCAR)
+ IF(ZSZ == 9999.)ZSZ=.012
+ ELSE
+ ZSZ=.012
+ ENDIF
+ IPOS=ZPOS
+ SELECT CASE(IPOS)
+ CASE(0)
+ ZCENT=-1.
+ ZX=ZX+ZSZ*1.1*(ZXMAX-ZXMIN)
+ CASE(45)
+ ZCENT=-1.
+ ZX=ZX+ZSZ*1.0*(ZXMAX-ZXMIN)
+ ZY=ZY+ZSZ*1.0*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+ CASE(90)
+ ZCENT=0.
+ ZY=ZY+ZSZ*1.5*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+ CASE(135)
+ ZCENT=1.
+ ZX=ZX-ZSZ*1.0*(ZXMAX-ZXMIN)
+ ZY=ZY+ZSZ*1.0*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+ CASE(180)
+ ZCENT=1.
+ ZX=ZX-ZSZ*1.1*(ZXMAX-ZXMIN)
+ CASE(225)
+ ZCENT=1.
+ ZX=ZX-ZSZ*1.0*(ZXMAX-ZXMIN)
+ ZY=ZY-ZSZ*1.0*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+ CASE(270)
+ ZCENT=0.
+ ZY=ZY-ZSZ*1.5*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+ CASE(315)
+ ZCENT=-1.
+ ZX=ZX+ZSZ*1.0*(ZXMAX-ZXMIN)
+ ZY=ZY-ZSZ*1.0*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+ END SELECT
+ IF(CNOMCAR(JIJCAR) /= ' ')THEN
+ YNOM=CNOMCAR(JIJCAR)
+ YNOM=ADJUSTL(YNOM)
+ CALL PCSETI('OF',2)
+ CALL PCSETI('OC',ICOLN)
+ CALL PCSETR('OL',1.5)
+ CALL PLCHHQ(ZX,ZY,YNOM(1:LEN_TRIM(YNOM)),ZSZ,0.,ZCENT)
+ ENDIF
+ CALL PCSETI('OF',0)
+ CALL PCSETR('OL',0.)
+ CALL PCSETI('OC',1)
+ CALL GSTXCI(1)
+ ENDDO
+ENDIF
+IF(LRADAR)THEN
+ CALL GQLWSC(IERR,ZWIDTH)
+ ZSZ=.012
+ CALL GSLWSC(3.)
+ IF(NPORTRAD1 /= 0)THEN
+ ZLAT=XLATRAD1
+ ZLON=XLONRAD1
+ YSYMB=CSYMRAD1
+ CALL SM_XYHAT_S(XLATORI,XLONORI,ZLAT,ZLON,ZU,ZV)
+ CALL PLCHHQ(ZU,ZV,YSYMB,ZSZ,0.,0.)
+ DO J=1,NPORTRAD1
+ CALL TRACIRCLE(ZU,ZV,XPORTRAD1(J),XLWRAD1(J))
+ CALL SFLUSH
+ ENDDO
+ ENDIF
+ IF(NPORTRAD2 /= 0)THEN
+ ZLAT=XLATRAD2
+ ZLON=XLONRAD2
+ YSYMB=CSYMRAD2
+ CALL SM_XYHAT_S(XLATORI,XLONORI,ZLAT,ZLON,ZU,ZV)
+ CALL PLCHHQ(ZU,ZV,YSYMB,ZSZ,0.,0.)
+ DO J=1,NPORTRAD2
+ CALL TRACIRCLE(ZU,ZV,XPORTRAD2(J),XLWRAD2(J))
+ CALL SFLUSH
+ ENDDO
+ ENDIF
+ IF(NPORTRAD3 /= 0)THEN
+ ZLAT=XLATRAD3
+ ZLON=XLONRAD3
+ YSYMB=CSYMRAD3
+ CALL SM_XYHAT_S(XLATORI,XLONORI,ZLAT,ZLON,ZU,ZV)
+ CALL PLCHHQ(ZU,ZV,YSYMB,ZSZ,0.,0.)
+ DO J=1,NPORTRAD3
+ CALL TRACIRCLE(ZU,ZV,XPORTRAD3(J),XLWRAD3(J))
+ CALL SFLUSH
+ ENDDO
+ ENDIF
+ IF(NPORTRAD4 /= 0)THEN
+ ZLAT=XLATRAD4
+ ZLON=XLONRAD4
+ YSYMB=CSYMRAD4
+ CALL SM_XYHAT_S(XLATORI,XLONORI,ZLAT,ZLON,ZU,ZV)
+ CALL PLCHHQ(ZU,ZV,YSYMB,ZSZ,0.,0.)
+ DO J=1,NPORTRAD4
+ CALL TRACIRCLE(ZU,ZV,XPORTRAD4(J),XLWRAD4(J))
+ CALL SFLUSH
+ ENDDO
+ ENDIF
+ CALL GSLWSC(ZWIDTH)
+ENDIF
+
+ENDIF
+!
+!----------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE BCGRD_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/caluv_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/caluv_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b88b89d691b3858fa22bb594e1ee1ad44c936170
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/caluv_fordiachro.f90
@@ -0,0 +1,397 @@
+! ######spl
+ SUBROUTINE CALUV_FORDIACHRO(KLOOP)
+! ##################################
+!
+!!**** *CALUV_FORDIACHRO* - Computes a wind, and moisture
+!! sounding for the emagram mode
+!!
+!! PURPOSE
+!! -------
+! For the emagram plots case only, reads U, V, and mix. ratio
+! from the Diachro file, and
+! relocates the results on the mass gridpoint, to obtain a colocated
+! emagram sounding data set.
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! MXM, MYM, MXF, MYF : Shuman averaging operators
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODI_SHUMAN : Contains Shuman operator interfaces
+!!
+!! MXM : mean operator in x direction for a mass variable
+!! MYM : mean operator in y direction for a mass variable
+!! MXF : mean operator in x direction for a velocity variable
+!! MYF : mean operator in y direction for a velocity variable
+!!
+!! Module MODD_DIM1 : Contains dimensions
+!!
+!! NIMAX,NJMAX,NKMAX : x, y, and z array dimensions
+!!
+!! Module MODD_PARAMETERS : Declares array border depths
+!!
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!! Module MODD_LUNIT1 : Declares names and log. unit of files
+!!
+!! CLUOUT : Name of output_listing file
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 01/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!USE MODI_SHUMAN
+USE MODI_VERIF_GROUP
+USE MODI_REALLOC_AND_LOAD
+USE MODD_DIM1
+USE MODD_COORD
+USE MODD_PARAMETERS
+USE MODD_RESOLVCAR
+USE MODD_FILES_DIACHRO
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_SEVERAL_RECORDS
+USE MODD_TYPE_AND_LH
+USE MODD_PT_FOR_CH_FORDIACHRO
+
+IMPLICIT NONE
+!
+! Dummy arguments
+!
+
+INTEGER :: KLOOP
+!
+! Local variables
+!
+
+INTEGER :: IIU, IJU, IKU
+INTEGER :: IT, IN, IP
+INTEGER :: J, JM, I, IXXX, IXXY
+INTEGER :: IRS1, IRSP1, IRS2, IRSP2, IRS3, IRSP3
+INTEGER :: JRS1, JRSP1, JRS2, JRSP2, JRS3, JRSP3
+
+CHARACTER(LEN=16) :: YGROUP
+
+REAL :: ZCIINF, ZCISUP, ZCJINF, ZCJSUP
+REAL,DIMENSION(:,:,:,:,:,:),ALLOCATABLE,SAVE :: ZMEANR, ZVAL
+REAL,DIMENSION(:,:,:,:),ALLOCATABLE,SAVE :: ZV
+
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTES SIZES AND RE-ALLOCATES ARRAYS
+! --------------------------------------
+IIU=NIMAX+2*JPHEXT
+IJU=NJMAX+2*JPHEXT
+IKU=NKMAX+2*JPVEXT
+!
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. READS DATA FROM DIACHRO FILE
+! ----------------------------
+!
+!
+NUMFILECUR=NFILESCUR(KLOOP)
+DO J=1,NBFILES
+ IF(NUMFILES(J) == NUMFILECUR)THEN
+ JM=J
+ ENDIF
+ENDDO
+DO J = 1,3
+YGROUP(1:LEN(YGROUP))=' '
+ IF(NMT == 1)THEN
+ IF(J == 1)YGROUP = 'UM'
+ IF(J == 2)YGROUP = 'VM'
+ IF(J == 3)YGROUP = 'RVM'
+ ELSE
+ IF(J == 1)YGROUP = 'UT'
+ IF(J == 2)YGROUP = 'VT'
+ IF(J == 3)YGROUP = 'RVT'
+ ENDIF
+ YGROUP=ADJUSTL(YGROUP)
+
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ print *,YGROUP(1:LEN_TRIM(YGROUP)),' N''EXISTE PAS'
+ EXIT
+ ENDIF
+ IF(LGROUP)THEN
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ ENDIF
+ IF(.NOT.LFIC1)THEN
+ CALL REALLOC_AND_LOAD(YGROUP)
+ IF(LPBREAD)THEN
+! LPBREAD=.FALSE.
+ print *,YGROUP(1:LEN_TRIM(YGROUP)),' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ EXIT
+ ENDIF
+ ENDIF
+
+ IF(J == 1)THEN
+ ALLOCATE(XU(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ XU(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ELSE IF(J == 2)THEN
+ ALLOCATE(XV(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ XV(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ELSE
+ ALLOCATE(XRVJD(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ XRVJD(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+! VOLONTAIREMENT Je ne desalloue pas parce besoin de XDATIME et desallocation
+! dans le pg pal comme pour les autres cas.
+! CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ENDDO
+!
+!
+!------------------------------------------------------------------------------
+!
+!* 3. RELOCATES THE EMAGRAM POINTS (when profile is defined with
+! ---------------------------- NIRS et NJRS)
+!
+!
+IF(XIRS /= -999.)THEN
+
+ IXXX=SIZE(XXX,1)
+ IXXY=SIZE(XXY,1)
+
+ DO I=1,IXXX-1
+ IF(XIRSCC >= XXX(I,1) .AND. XIRSCC < XXX(I+1,1))THEN
+ IRS1=I
+ IRSP1=MIN(I+1,NIH)
+ if(nverbia > 0)then
+ print *,' XIRSCC,XXX(I,1),XXX(IRSP1,1) ',XIRSCC,XXX(I,1),XXX(IRSP1,1)
+ endif
+ EXIT
+ ENDIF
+ ENDDO
+
+ DO J=1,IXXY-1
+ IF(XJRSCC >= XXY(J,1) .AND. XJRSCC < XXY(J+1,1))THEN
+ JRS1=J
+ JRSP1=MIN(J+1,NJH)
+ if(nverbia > 0)then
+ print *,' XJRSCC,XXY(J,1),XXY(JRSP1,1) ',XJRSCC,XXY(J,1),XXY(JRSP1,1)
+ endif
+ EXIT
+ ENDIF
+ ENDDO
+
+ DO I=1,IXXX-1
+ IF(XIRSCC >= XXX(I,2) .AND. XIRSCC < XXX(I+1,2))THEN
+ IRS2=I
+ IRSP2=MIN(I+1,NIH)
+ EXIT
+ ENDIF
+ ENDDO
+
+ DO J=1,IXXY-1
+ IF(XJRSCC >= XXY(J,2) .AND. XJRSCC < XXY(J+1,2))THEN
+ JRS2=J
+ JRSP2=MIN(J+1,NJH)
+ EXIT
+ ENDIF
+ ENDDO
+
+ DO I=1,IXXX-1
+ IF(XIRSCC >= XXX(I,3) .AND. XIRSCC < XXX(I+1,3))THEN
+ IRS3=I
+ IRSP3=MIN(I+1,NIH)
+ EXIT
+ ENDIF
+ ENDDO
+
+ DO J=1,IXXY-1
+ IF(XJRSCC >= XXY(J,3) .AND. XJRSCC < XXY(J+1,3))THEN
+ JRS3=J
+ JRSP3=MIN(J+1,NJH)
+ EXIT
+ ENDIF
+ ENDDO
+
+! Je mets toutes les informations du RS arbitrairement au point NIRS=2,NJRS=2
+! qd le profil est defini avec XIRS et XJRS. Cela m'evite d'avoir a modifier
+! la partie dans oper (ou je sauvegarde et restitue ap. le RS NIRS et NJRS)
+ NIRS=2; NJRS=2
+
+! Grille 1
+ IF(IRS1 == IRSP1)THEN
+ ZCIINF=0.
+ ZCISUP=0.
+ ELSE
+ ZCIINF=(XXX(IRSP1,1)-XIRSCC)/MAX(1.E-10,(XXX(IRSP1,1)-XXX(IRS1,1)))
+ ZCISUP=(XIRSCC-XXX(IRS1,1))/MAX(1.E-10,(XXX(IRSP1,1)-XXX(IRS1,1)))
+ ENDIF
+ IF(JRS1 == JRSP1)THEN
+ ZCJINF=0.
+ ZCJSUP=0.
+ ELSE
+ ZCJINF=(XXY(JRSP1,1)-XJRSCC)/MAX(1.E-10,(XXY(JRSP1,1)-XXY(JRS1,1)))
+ ZCJSUP=(XJRSCC-XXY(JRS1,1))/MAX(1.E-10,(XXY(JRSP1,1)-XXY(JRS1,1)))
+ ENDIF
+ IF(NVERBIA == 10)THEN
+ print *,' ZCIINF...',ZCIINF,ZCISUP,ZCJINF,ZCJSUP
+ print *,' IRS1,JRS1,IRSP1,JRSP1 ',IRS1,JRS1,IRSP1,JRSP1
+ print *,' TH 1 2 3 4 ',XTH(IRS1,JRS1,:,:,:,:)
+ print *,' TH 1 2 3 4 ',XTH(IRSP1,JRS1,:,:,:,:)
+ print *,' TH 1 2 3 4 ',XTH(IRS1,JRSP1,:,:,:,:)
+ print *,' TH 1 2 3 4 ',XTH(IRSP1,JRSP1,:,:,:,:)
+ print *,' PRES 1 2 3 4 ',XPRES(IRS1,JRS1,:,:,:,:)
+ print *,' PRES 1 2 3 4 ',XPRES(IRSP1,JRS1,:,:,:,:)
+ print *,' PRES 1 2 3 4 ',XPRES(IRS1,JRSP1,:,:,:,:)
+ print *,' PRES 1 2 3 4 ',XPRES(IRSP1,JRSP1,:,:,:,:)
+ print *,' RVJD 1 2 3 4 ',XRVJD(IRS1,JRS1,:,:,:,:)
+ print *,' RVJD 1 2 3 4 ',XRVJD(IRSP1,JRS1,:,:,:,:)
+ print *,' RVJD 1 2 3 4 ',XRVJD(IRS1,JRSP1,:,:,:,:)
+ print *,' RVJD 1 2 3 4 ',XRVJD(IRSP1,JRSP1,:,:,:,:)
+ ENDIF
+ IF(NVERBIA == 10)THEN
+ print *,' U 1 2 3 4 ',XU(IRS2,JRS2,:,:,:,:), &
+ XU(IRSP2,JRS2,:,:,:,:),XU(IRS2,JRSP2,:,:,:,:),&
+ XU(IRSP2,JRSP2,:,:,:,:)
+ print *,' V 1 2 3 4 ',XV(IRS3,JRS3,:,:,:,:), &
+ XV(IRSP3,JRS3,:,:,:,:),XV(IRS3,JRSP3,:,:,:,:),&
+ XV(IRSP3,JRSP3,:,:,:,:)
+ ENDIF
+
+ALLOCATE(ZVAL(SIZE(XTH,1),SIZE(XTH,2),SIZE(XTH,3),SIZE(XTH,4),SIZE(XTH,5),SIZE(XTH,6)))
+ALLOCATE(ZV(SIZE(XTH,3),SIZE(XTH,4),SIZE(XTH,5),SIZE(XTH,6)))
+! XTH
+! ZVAL(IRS1,JRS1,:,:,:,:)=ZCIINF*ZCJINF*XTH(IRS1,JRS1,:,:,:,:)+ &
+ DO IP=1,SIZE(XTH,6)
+ DO IN=1,SIZE(XTH,5)
+ DO IT=1,SIZE(XTH,4)
+ ZV(:,IT,IN,IP)=ZCIINF*ZCJINF*XTH(IRS1,JRS1,:,IT,IN,IP)+ &
+ ZCIINF*ZCJSUP*XTH(IRS1,JRSP1,:,IT,IN,IP)+ &
+ ZCISUP*ZCJINF*XTH(IRSP1,JRS1,:,IT,IN,IP)+ &
+ ZCISUP*ZCJSUP*XTH(IRSP1,JRSP1,:,IT,IN,IP)
+! ZV(:,IT,IN,IP)=ZVAL(IRS1,JRS1,:,IT,IN,IP)
+ XTH(NIRS,NJRS,:,IT,IN,IP)=ZV(:,IT,IN,IP)
+ print *,' XTH(NIRS,NJRS,:,IT,IN,IP) ',XTH(NIRS,NJRS,:,IT,IN,IP)
+ ENDDO
+ ENDDO
+ ENDDO
+! XPRES
+ ZVAL(IRS1,JRS1,:,:,:,:)=ZCIINF*ZCJINF*XPRES(IRS1,JRS1,:,:,:,:)+ &
+ ZCIINF*ZCJSUP*XPRES(IRS1,JRSP1,:,:,:,:)+ &
+ ZCISUP*ZCJINF*XPRES(IRSP1,JRS1,:,:,:,:)+ &
+ ZCISUP*ZCJSUP*XPRES(IRSP1,JRSP1,:,:,:,:)
+ ZV(:,:,:,:)=ZVAL(IRS1,JRS1,:,:,:,:)
+ XPRES(NIRS,NJRS,:,:,:,:)=ZV(:,:,:,:)
+! XRVJD
+ ZVAL(IRS1,JRS1,:,:,:,:)=ZCIINF*ZCJINF*XRVJD(IRS1,JRS1,:,:,:,:)+ &
+ ZCIINF*ZCJSUP*XRVJD(IRS1,JRSP1,:,:,:,:)+ &
+ ZCISUP*ZCJINF*XRVJD(IRSP1,JRS1,:,:,:,:)+ &
+ ZCISUP*ZCJSUP*XRVJD(IRSP1,JRSP1,:,:,:,:)
+ ZV(:,:,:,:)=ZVAL(IRS1,JRS1,:,:,:,:)
+ XRVJD(NIRS,NJRS,:,:,:,:)=ZV(:,:,:,:)
+! Grille 2
+ IF(IRS2 == IRSP2)THEN
+ ZCIINF=0.
+ ZCISUP=0.
+ ELSE
+ ZCIINF=(XXX(IRSP2,2)-XIRSCC)/MAX(1.E-10,(XXX(IRSP2,2)-XXX(IRS2,2)))
+ ZCISUP=(XIRSCC-XXX(IRS2,2))/MAX(1.E-10,(XXX(IRSP2,2)-XXX(IRS2,2)))
+ ENDIF
+ IF(JRS2 == JRSP2)THEN
+ ZCJINF=0.
+ ZCJSUP=0.
+ ELSE
+ ZCJINF=(XXY(JRSP2,2)-XJRSCC)/MAX(1.E-10,(XXY(JRSP2,2)-XXY(JRS2,2)))
+ ZCJSUP=(XJRSCC-XXY(JRS2,2))/MAX(1.E-10,(XXY(JRSP2,2)-XXY(JRS2,2)))
+ ENDIF
+! XU
+ ZVAL(IRS2,JRS2,:,:,:,:)=ZCIINF*ZCJINF*XU(IRS2,JRS2,:,:,:,:)+ &
+ ZCIINF*ZCJSUP*XU(IRS2,JRSP2,:,:,:,:)+ &
+ ZCISUP*ZCJINF*XU(IRSP2,JRS2,:,:,:,:)+ &
+ ZCISUP*ZCJSUP*XU(IRSP2,JRSP2,:,:,:,:)
+ ZV(:,:,:,:)=ZVAL(IRS2,JRS2,:,:,:,:)
+ XU(NIRS,NJRS,:,:,:,:)=ZV(:,:,:,:)
+! Grille 3
+ IF(IRS3 == IRSP3)THEN
+ ZCIINF=0.
+ ZCISUP=0.
+ ELSE
+ ZCIINF=(XXX(IRSP3,3)-XIRSCC)/MAX(1.E-10,(XXX(IRSP3,3)-XXX(IRS3,3)))
+ ZCISUP=(XIRSCC-XXX(IRS3,3))/MAX(1.E-10,(XXX(IRSP3,3)-XXX(IRS3,3)))
+ ENDIF
+ IF(JRS3 == JRSP3)THEN
+ ZCJINF=0.
+ ZCJSUP=0.
+ ELSE
+ ZCJINF=(XXY(JRSP3,3)-XJRSCC)/MAX(1.E-10,(XXY(JRSP3,3)-XXY(JRS3,3)))
+ ZCJSUP=(XJRSCC-XXY(JRS3,3))/MAX(1.E-10,(XXY(JRSP3,3)-XXY(JRS3,3)))
+ ENDIF
+
+! XV
+ ZVAL(IRS3,JRS3,:,:,:,:)=ZCIINF*ZCJINF*XV(IRS3,JRS3,:,:,:,:)+ &
+ ZCIINF*ZCJSUP*XV(IRS3,JRSP3,:,:,:,:)+ &
+ ZCISUP*ZCJINF*XV(IRSP3,JRS3,:,:,:,:)+ &
+ ZCISUP*ZCJSUP*XV(IRSP3,JRSP3,:,:,:,:)
+ ZV(:,:,:,:)=ZVAL(IRS3,JRS3,:,:,:,:)
+ XV(NIRS,NJRS,:,:,:,:)=ZV(:,:,:,:)
+
+ DEALLOCATE(ZVAL,ZV)
+
+ IF(NVERBIA == 10)THEN
+ print *,' TH,PRES,RVJD,U,V interpoles ',XTH(NIRS,NJRS,:,:,:,:),' ', &
+ XPRES(NIRS,NJRS,:,:,:,:),' ',XRVJD(NIRS,NJRS,:,:,:,:),' ',&
+ XU(NIRS,NJRS,:,:,:,:),' ',XV(NIRS,NJRS,:,:,:,:)
+ ENDIF
+
+ELSE
+
+IF(.NOT.ALLOCATED(ZMEANR))THEN
+ ALLOCATE(ZMEANR(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+END IF
+! A CORRIGER (Fait le 6/1/97)
+ZMEANR(1:IIU-1,:,:,:,:,:)=.5*(XU(1:IIU-1,:,:,:,:,:)+XU(2:IIU,:,:,:,:,:))
+!ZMEANR(:,:,:,:,:,:)=MXF(XU)
+ZMEANR(IIU,:,:,:,:,:)=2.*ZMEANR(IIU-1,:,:,:,:,:)-ZMEANR(IIU-2,:,:,:,:,:)
+XU(:,:,:,:,:,:)=ZMEANR(:,:,:,:,:,:)
+!
+!ZMEANR(:,:,:,:,:,:)=MYF(XV)
+! A CORRIGER (Fait le 6/1/97)
+ZMEANR(:,1:IJU-1,:,:,:,:)=.5*(XV(:,1:IJU-1,:,:,:,:)+XV(:,2:IJU,:,:,:,:))
+ZMEANR(:,IJU,:,:,:,:)=2.*ZMEANR(:,IJU-1,:,:,:,:)-ZMEANR(:,IJU-2,:,:,:,:)
+XV(:,:,:,:,:,:)=ZMEANR(:,:,:,:,:,:)
+!
+!
+!-----------------------------------------------------------------------------
+!
+!* 4. EXIT
+! ----
+!
+DEALLOCATE(ZMEANR)
+
+ENDIF
+!
+RETURN
+END SUBROUTINE CALUV_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/careal.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/careal.f90
new file mode 100644
index 0000000000000000000000000000000000000000..37418bf0caf70bfd63ab485495a81a43b88859bd
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/careal.f90
@@ -0,0 +1,81 @@
+! ######spl
+ MODULE MODI_CAREAL
+! ##################
+!
+INTERFACE
+!
+SUBROUTINE CAREAL(HCAR,POUT)
+CHARACTER(LEN=*) :: HCAR
+REAL :: POUT
+END SUBROUTINE CAREAL
+!
+END INTERFACE
+!
+END MODULE MODI_CAREAL
+! ######spl
+ SUBROUTINE CAREAL(HCAR,POUT)
+! ############################
+!
+!!**** *CAREAL* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCAR
+REAL :: POUT
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+CHARACTER(LEN=LEN(HCAR)) :: YCAR
+!------------------------------------------------------------------------------
+!
+YCAR=HCAR
+READ(YCAR,*)POUT
+
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE CAREAL
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/caresolv.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/caresolv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2adabcfaef5a7f7d0687abb8912e52872a11bcee
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/caresolv.f90
@@ -0,0 +1,5345 @@
+! ######spl
+ MODULE MODI_CARESOLV
+! ####################
+!
+INTERFACE
+!
+SUBROUTINE CARESOLV(HCARIN)
+CHARACTER(LEN=*) :: HCARIN
+END SUBROUTINE CARESOLV
+!
+END INTERFACE
+!
+END MODULE MODI_CARESOLV
+! ######spl
+ SUBROUTINE CARESOLV(HCARIN)
+! ###########################
+!
+!!**** *CARESOLV* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST : declares model physical constants
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!!
+!! NIOFFD : Label normalisation (=0 none, =/=0 active)
+!! NULBLL : Nb of contours between 2 labelled contours
+!! NIOFFM : =0 --> message at picture bottom
+!! =/= 0 --> no message
+!! NIOFFP : Special point value detection
+!! (=0 none, =/=0 active)
+!! NHI : Extrema detection
+!! (=0 --> H+L, <0 nothing)
+!! NINITA : For streamlimes
+!! NINITB : Not yet implemented
+!! NIGRNC : Not yet implemented
+!! NDOT : Line style
+!! (=0|1|1023|65535 --> solid lines;
+!! <0 --> solid lines for positive values and
+!! dotted lines(ABS(NDOT))for negative values;
+!! >0 --> dotted lines(ABS(NDOT)) )
+!! NIFDC : Coastline data style (0 none, 1 NCAR, 2 IGN)
+!! NLPCAR : Number of land-mark points to be plotted
+!! NIMNMX : Contour selection option
+!! (=-1 Min, max and inc. automatically set;
+!! =0 Min, max automatically set; inc. given;
+!! >0 Min, max, inc. given by user)
+!! NISKIP : Rate for drawing velocity vectors
+!! CTYPHOR : Horizontal cross-section type
+!! (='K' --> model level section;
+!! ='Z' --> constant-altitude section;
+!! ='P' --> isobar section (planned)
+!! ='T' --> isentrope section (planned)
+!! XSPVAL : Special value
+!! XSIZEL : Label size
+!! XLATCAR, XLONCAR : Lat. and Long. of land-mark points
+!! LXY : If =.TRUE., plots a grid-mesh stencil background
+!! LXZ : If =.TRUE., plots a model-level stencil background
+!!
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist
+!! (former PARA common)
+!!
+!! XIDEBCOU, XJDEBCOU : Origin of a vertical cross-section
+!! in cartesian (or conformal) real values
+!! XHMIN : Altitude of the vert. cross-section
+!! bottom (in meters above sea-level)
+!! XHMAX : Altitude of the vert. cross-section
+!! top (in meters above sea-level)
+!!
+!! Module MODD_ALLVAR
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+#ifdef NAGf95
+USE F90_UNIX ! for FLUSH and GETENV
+#endif
+USE MODD_RESOLVCAR
+USE MODE_GRIDPROJ
+USE MODD_SUPER
+USE MODD_EXPR
+USE MODD_RADAR
+USE MODD_MASK3D
+USE MODN_NCAR
+USE MODN_PARA
+USE MODI_RESOLVT
+USE MODI_RESOLVN
+USE MODI_RESOLVON
+USE MODI_RESOLVP
+USE MODI_RESOLVK
+USE MODI_RESOLVZ
+USE MODI_RESOLVX
+USE MODI_CAREAL
+USE MODI_CARINT
+USE MODI_RESOLVI
+USE MODI_RESOLVIARRAY
+USE MODI_RESOLVL
+USE MODI_CARMEMORY
+USE MODI_RESOLVXISOLEV
+USE MODD_FILES_DIACHRO
+USE MODD_DIM1
+USE MODD_GRID1
+USE MODD_GRID, ONLY: XLONORI,XLATORI
+USE MODD_HACH
+USE MODD_PVT
+USE MODD_COORD
+USE MODD_DEFCV
+USE MODD_TIT
+USE MODD_RSISOCOL
+USE MODD_MEMCV
+USE MODD_CTL_AXES_AND_STYL
+USE MODD_PARAMETERS
+USE MODD_ALLOC_FORDIACHRO
+USE MODI_LOADMNMX_FT_PVKT
+USE MODI_LOADMNMXINT_ISO
+USE MODI_LOADXISOLEVP
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+USE MODD_TRAJ3D
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+USE MODI_WRITEDIR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+!CHARACTER(LEN=32) :: HGRP
+!
+!* 0.1 Local variables
+! ---------------
+!
+CHARACTER(LEN=80) :: YCAR80
+!CHARACTER(LEN=LEN(HCARIN)+240) :: YCARIN, YCAR
+!CHARACTER(LEN=800) :: YCAROUT
+CHARACTER(LEN=LEN(HCARIN)) :: YCARIN, YCAROUT, YCAR
+!
+INTEGER :: INDPARTIEL
+INTEGER :: ILENC, ILENGRP, ILENC2, IETOILE, ILOG, ILEN, INDEXPR
+INTEGER :: INDP, INDT, INDK, INDZ, INDCV, INDPV, INDPVT, INDPH, INDON, &
+ INDTOT, INDMIN, INDFI, INDN, INDID, INDPVKT, INDPXT, INDPYT
+INTEGER :: INDNDOMAINL, INDNDOMAINR, INDNDOMAINB, INDNDOMAINT
+INTEGER :: INDNSZLBX, INDNSZLBY, INDTMP
+INTEGER :: INDPVKT1, INDZT, INDXT, INDYT, INDXY, INDZTPVKT1, INDXYZ
+INTEGER :: INDFT, INDFT1, INDMASK, INDMASKCUM, INDMASKSUM
+INTEGER :: INDTK, INDPR, INDRS, INDRS1, INDEV, INDUMVMPV
+INTEGER :: INDIINF, INDJINF, INDISUP, INDJSUP, INDIM, INDNZSTR, INDNARSTR
+INTEGER :: INDIDEBCOU, INDJDEBCOU, INDXIDEBCOU, INDXJDEBCOU, INDNLANGLE, &
+ INDNLMAX, INDXHMIN, INDXHMAX, INDXISOMIN, INDXISOMAX
+INTEGER :: INDXPMIN, INDXPMAX, INDXPINT, INDXSSP, INDXLWSTR, INDXARLSTR
+INTEGER :: INDXISOMIN_, INDXISOMAX_, INDXDIAINT_, INDXANGULVT
+INTEGER :: INDXDIAINT, INDLXY, INDLXZ, INDLISO, INDLMINMAX, INDATFILE, &
+ INDLCOLAREA, INDLCOLINE, INDLISOWHI, INDLCOLBR, INDLCOLAREASEL, &
+ INDLSPVALT, INDLSEGM, INDLPRESY, INDLSPSECT, INDLEGVECT , &
+ INDLINTERPTOP, INDLCOLISONE, INDLCOLRSONE, INDLCOLRS1ONE, &
+ INDLCOLINESEL, INDLTABCOLDEF, INDVISU, INDNOVISU, INDXSIZEL, &
+ INDLMNMXUSER, INDLCOLUSER, INDLVECTMNMX, INDLANIMK, INDLANIMT, &
+ INDLMNMXLOC, INDLULMVTMOLD, INDLTITFTUSER, INDLFMTAXEX, &
+ INDLTIMEUSER, INDXTIMEMIN, INDXTIMEMAX, INDLSTREAM, &
+ INDLNOUVRS, INDLMYHEURX, INDNHEURXLBL, INDNHEURXGRAD
+INTEGER :: INDLINZEROPV, INDLBLFT1SUP, INDL24H
+INTEGER :: INDNVERBIA, INDLISOWHI2, INDLISOWHI3, INDLFMTAXEY
+INTEGER :: INDLINVWB , INDLGEOG, INDLMASK3D, INDMSKTOP, INDSV3
+INTEGER :: INDLINVPTIR, INDLDOMAIN, INDLNOLABELX, INDLNOLABELY
+INTEGER :: INDLNOLBLBAR
+INTEGER :: INDLMASK3D_XY,INDLMASK3D_XZ,INDLMASK3D_YZ,INDLXYZ00
+INTEGER :: INDLINDSP, INDLOGNEP, INDLTABCOLDEF2, INDLCONT, INDLRELIEF, &
+ INDLCONV2XY, INDLINDAX, INDLCHREEL,INDLCOLUSERUV,INDL2CONT, &
+ INDLCONVG2MASS
+INTEGER :: INDLSPLO, INDSPO, INDOSPLO, INDPHALO, INDPHAO, INDLFTBAUTO, &
+ INDLFT1BAUTO
+INTEGER :: INDLPRINT, INDLPOINTG, INDL2DBX, INDL2DBY, INDLXYO, INDLPRINTXY
+INTEGER :: INDLPRDAT, INDLINTERPOLSTR, INDL3D
+INTEGER :: INDLVPTUSER, INDLVPTVUSER, INDLVPTPVUSER, INDLXABSC, INDLXMINTOP
+INTEGER :: INDLVPTXYUSER, INDLFACTIMP, INDLFACTAXEX, INDLFACTAXEY
+INTEGER :: INDLAXEXUSER, INDLAXEYUSER
+INTEGER :: INDLHACH1, INDLHACH2, INDLHACH3, INDLHACH4, INDLHACHSEL
+INTEGER :: INDLGREY
+INTEGER :: INDLHEURX
+INTEGER :: INDLABEL1, INDLBLUSER1, INDLBLUSER2, INDLBLUSER3, INDLBLUSER4
+INTEGER :: INDXFACTAXEX, INDXFACTAXEY, INDXAXEXUSERD, INDXAXEYUSERD
+INTEGER :: INDXAXEXUSERF, INDXAXEYUSERF
+INTEGER :: INDXVPTL, INDXVPTR, INDXVPTB, INDXVPTT
+INTEGER :: INDXVPTVL, INDXVPTVR, INDXVPTVB, INDXVPTVT
+INTEGER :: INDXVPTPVL, INDXVPTPVR, INDXVPTPVB, INDXVPTPVT
+INTEGER :: INDXVPTXYL, INDXVPTXYR, INDXVPTXYB, INDXVPTXYT
+INTEGER :: INDXISOLEV, INDXFTMIN, INDXFTMAX, INDXPVKTMIN, INDXPVKTMAX
+INTEGER :: INDXFT_ADTIM1, INDXFT_ADTIM2, INDXFT_ADTIM3, INDXFT_ADTIM4
+INTEGER :: INDXFT_ADTIM5, INDXFT_ADTIM6, INDXFT_ADTIM7, INDXFT_ADTIM8
+INTEGER :: INDXFT1_ADTIM1, INDXFT1_ADTIM2, INDXFT1_ADTIM3, INDXFT1_ADTIM4
+INTEGER :: INDXFT1_ADTIM5, INDXFT1_ADTIM6, INDXFT1_ADTIM7, INDXFT1_ADTIM8
+INTEGER :: INDXISOLEV_ , INDXPARCOLUV
+INTEGER :: INDXFT1MIN, INDXFT1MAX, INDXFT1MIN_, INDXFT1MAX_
+INTEGER :: INDXVARMIN, INDXVARMAX, INDXZTMIN, INDXZTMAX
+INTEGER :: INDXLATCAR, INDXLONCAR, INDXXL, INDXXH, INDXYL, INDXYH
+INTEGER :: INDXICAR, INDXJCAR
+INTEGER :: INDCNOMCAR, INDCSYMCAR, INDXPOSNOM, INDXSZNOM, INDXSZSYM
+INTEGER :: INDXPOSXVARNPV1TOP,INDXPOSYVARNPV1TOP
+INTEGER :: INDXPOSXVARNPV5BOT,INDXPOSYVARNPV5BOT
+INTEGER :: INDXSZVARNPVTOP,INDXSZVARNPVBOT
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!! pour les retrotrajectoires !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+INTEGER :: INDNSZRTRAJ,INDLFMTRTRAJ
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+INTEGER :: INDXLWPH1, INDXLWPH2, INDXLWPH3, INDXLWPH4
+INTEGER :: INDXLWPH5, INDXLWPH6, INDXLWPH7, INDXLWPH8
+INTEGER :: INDXSZTITYT, INDXSZTITYM, INDXSZTITYB
+INTEGER :: INDXSZTITT1, INDXSZTITT2, INDXSZTITT3
+INTEGER :: INDXSZTITB1, INDXSZTITB2, INDXSZTITB3
+INTEGER :: INDXSZTITVAR1, INDXSZTITVAR2, INDXSZTITVAR3, INDXSZTITVAR4
+INTEGER :: INDXSZTITVAR5, INDXSZTITVAR6, INDXSZTITVAR7, INDXSZTITVAR8
+INTEGER :: INDXPOSTITYT, INDXPOSTITYM, INDXPOSTITYB
+INTEGER :: INDXPOSTITT1, INDXPOSTITT2, INDXPOSTITT3
+INTEGER :: INDXPOSTITB1, INDXPOSTITB2, INDXPOSTITB3
+INTEGER :: INDXPOSTITVAR1, INDXPOSTITVAR2, INDXPOSTITVAR3, INDXPOSTITVAR4
+INTEGER :: INDXPOSTITVAR5, INDXPOSTITVAR6, INDXPOSTITVAR7, INDXPOSTITVAR8
+INTEGER :: INDXYPOSTITYT, INDXYPOSTITYM, INDXYPOSTITYB
+INTEGER :: INDXYPOSTITT1, INDXYPOSTITT2, INDXYPOSTITT3
+INTEGER :: INDXYPOSTITB1, INDXYPOSTITB2, INDXYPOSTITB3
+INTEGER :: INDXYPOSTITVAR1, INDXYPOSTITVAR2, INDXYPOSTITVAR3,INDXYPOSTITVAR4
+INTEGER :: INDXYPOSTITVAR5, INDXYPOSTITVAR6, INDXYPOSTITVAR7,INDXYPOSTITVAR8
+INTEGER :: INDICOLNOM, INDICOLSYM
+INTEGER :: INDXZL, INDXZH
+INTEGER :: INDNIFDC, INDNIGRNC, INDNDOT, INDNISKIP, INDNISKIPVX, INDNISKIPVY
+INTEGER :: INDNIOFFD, INDNULBLL, INDNHI, INDNIMNMX, INDNPROFILE, INDNSD
+INTEGER :: INDMINUS, INDPLUS, INDNFT1ITVXMJ, INDNFT1ITVXMN
+INTEGER :: INDNFT1ITVYMJ, INDNFT1ITVYMN, INDNINDCOLUV
+INTEGER :: INDNFTITVXMJ, INDNFTITVXMN, INDNFTITVYMJ, INDNFTITVYMN
+INTEGER :: INDNCHITVXMJ, INDNCHITVXMN, INDNCHITVYMJ, INDNCHITVYMN
+INTEGER :: INDNCHPCITVXMJ, INDNCHPCITVXMN, INDNCHPCITVYMJ, INDNCHPCITVYMN
+INTEGER :: INDNCVITVXMJ, INDNCVITVXMN, INDNCVITVYMJ, INDNCVITVYMN
+INTEGER :: INDNPVITVXMJ, INDNPVITVXMN, INDNPVITVYMJ, INDNPVITVYMN
+INTEGER :: INDNMASKITVXMJ, INDNMASKITVXMN, INDNMASKITVYMJ, INDNMASKITVYMN
+INTEGER :: INDNXYITVXMJ, INDNXYITVXMN, INDNXYITVYMJ, INDNXYITVYMN
+INTEGER :: INDXPVMIN, INDXPVMAX, INDXPVMINT, INDXPVMAXT
+INTEGER :: INDXLWV, INDXLWDEF, INDXLWVDEF, INDXLWCONT, INDLMARKER
+INTEGER :: INDXLWFTALL, INDXLWSEGM
+INTEGER :: INDXLW, INDXLW1, INDXLW2, INDXLW3, INDXLW4, INDXLWDOMAIN
+INTEGER :: INDXLWPV1, INDXLWPV2, INDXLWPV3, INDXLWPV4, INDXLWPV5
+INTEGER :: INDXLWPV6, INDXLWPV7, INDXLWPV8, INDXLWTRACECV
+INTEGER :: INDXLWPV9, INDXLWPV10
+INTEGER :: INDXLWPV11, INDXLWPV12, INDXLWPV13, INDXLWPV14, INDXLWPV15
+INTEGER :: INDXSTYLPV1, INDXSTYLPV2, INDXSTYLPV3, INDXSTYLPV4, INDXSTYLPV5
+INTEGER :: INDXSTYLPV6, INDXSTYLPV7, INDXSTYLPV8
+INTEGER :: INDXSTYLPV9, INDXSTYLPV10
+INTEGER :: INDXSTYLPV11, INDXSTYLPV12, INDXSTYLPV13, INDXSTYLPV14, INDXSTYLPV15
+INTEGER :: INDXAMX, INDXVHC, INDXVRL, INDXVLC, INDXVRLPH, INDXVHCPH
+INTEGER :: INDNIRS, INDNJRS, INDXIRS, INDXJRS, INDXSPVAL, INDXSPVALT
+INTEGER :: INDLCOLZERO, INDNCOLZERO, INDLFT1STYLUSER, INDLFTSTYLUSER
+INTEGER :: INDNCOLSEGM, INDLFT3C, INDLFT4C, INDLFTCLIP
+INTEGER :: INDNCOLUV1, INDNCOLUV2, INDNCOLUV3, INDNCOLUV4, INDNCOLUV5
+INTEGER :: INDNCOLISONE1, INDNCOLISONE2, INDNCOLISONE3,INDNCOLISONE4
+INTEGER :: INDNCOLISONE5, INDNCOLRSONE, INDNCOLRS1ONE1,INDNCOLRS1ONE2
+INTEGER :: INDNCOLRS1ONE3, INDNCOLRS1ONE4,INDNCOLRS1ONE5
+INTEGER :: INDXSZTITXL, INDXSZTITXM, INDXSZTITXR
+INTEGER :: INDLDEFCV2, INDLDEFCV2LL, INDLDEFCV2IND
+INTEGER :: INDXIDEBCV, INDXIFINCV, INDXJDEBCV, INDXJFINCV
+INTEGER :: INDXIDEBCVLL, INDXIFINCVLL, INDXJDEBCVLL, INDXJFINCVLL
+INTEGER :: INDNIDEBCV, INDNIFINCV, INDNJDEBCV, INDNJFINCV
+INTEGER :: INDLSYMB, INDLTEXTG, INDLTEXTIT, INDLSYMBTEXTG, INDLSTI
+INTEGER :: INDLTRACECV, INDLM5S3, INDLCVZOOM, INDLDILW, INDLVST
+INTEGER :: INDLVSUPSCA, INDLXYWINCUR, INDLXYNVARTOP, INDLXYSTYLTOP
+INTEGER :: INDLRADAR, INDXLATRAD1,INDXLATRAD2,INDXLATRAD3,INDXLATRAD4
+INTEGER :: INDLRADIST, INDLRADRAY
+INTEGER :: INDXLONRAD1,INDXLONRAD2,INDXLONRAD3,INDXLONRAD4
+INTEGER :: INDXPORTRAD1,INDXPORTRAD2,INDXPORTRAD3,INDXPORTRAD4
+INTEGER :: INDXLWRAD1,INDXLWRAD2,INDXLWRAD3,INDXLWRAD4
+INTEGER :: INDCSYMRAD1,INDCSYMRAD2,INDCSYMRAD3,INDCSYMRAD4
+INTEGER :: INDXISOREF,INDXISOREF_,INDLSPOT
+INTEGER :: INDLFT1LUSER,INDNFT1STY1,INDNFT1STY2,INDNFT1STY3,INDNFT1STY4
+INTEGER :: INDNFT1STY5,INDNFT1STY6,INDNFT1STY7,INDNFT1STY8,INDNFT1STY9
+INTEGER :: INDNFT1STY10,INDNFT1STY11,INDNFT1STY12,INDNFT1STY13,INDNFT1STY14
+INTEGER :: INDNFT1STY15
+INTEGER :: INDNFT1COL1,INDNFT1COL2,INDNFT1COL3,INDNFT1COL4,INDNFT1COL5
+INTEGER :: INDNFT1COL6,INDNFT1COL7,INDNFT1COL8,INDNFT1COL9,INDNFT1COL10
+INTEGER :: INDNFT1COL11,INDNFT1COL12,INDNFT1COL13,INDNFT1COL14,INDNFT1COL15
+INTEGER :: INDXFT1LW1,INDXFT1LW2,INDXFT1LW3,INDXFT1LW4,INDXFT1LW5
+INTEGER :: INDXFT1LW6,INDXFT1LW7,INDXFT1LW8,INDXFT1LW9,INDXFT1LW10
+INTEGER :: INDXFT1LW11,INDXFT1LW12,INDXFT1LW13,INDXFT1LW14,INDXFT1LW15
+INTEGER :: INDCFT1TIT1,INDCFT1TIT2,INDCFT1TIT3,INDCFT1TIT4,INDCFT1TIT5
+INTEGER :: INDCFT1TIT6,INDCFT1TIT7,INDCFT1TIT8,INDCFT1TIT9,INDCFT1TIT10
+INTEGER :: INDCFT1TIT11,INDCFT1TIT12,INDCFT1TIT13,INDCFT1TIT14,INDCFT1TIT15
+INTEGER :: INDXVPTFT1L,INDXVPTFT1R,INDXVPTFT1B,INDXVPTFT1T
+INTEGER :: INDLVPTFT1USER, INDLVARNPVUSER, INDNSTYLINZEROPV
+INTEGER :: INDCVARNPV1,INDCVARNPV2,INDCVARNPV3,INDCVARNPV4,INDCVARNPV5
+INTEGER :: INDCVARNPV6,INDCVARNPV7,INDCVARNPV8,INDCVARNPV9,INDCVARNPV10
+INTEGER :: INDCVARNPV11,INDCVARNPV12,INDCVARNPV13,INDCVARNPV14,INDCVARNPV15
+INTEGER :: INDCVARNPH1,INDCVARNPH2,INDCVARNPH3,INDCVARNPH4,INDCVARNPH5
+INTEGER :: INDCVARNPH6,INDCVARNPH7,INDCVARNPH8,INDLVARNPHUSER
+INTEGER :: INDNPHCOL1,INDNPHCOL2,INDNPHCOL3,INDNPHCOL4,INDNPHCOL5
+INTEGER :: INDNPHCOL6,INDNPHCOL7,INDNPHCOL8
+INTEGER :: INDNPHSTY1,INDNPHSTY2,INDNPHSTY3,INDNPHSTY4,INDNPHSTY5
+INTEGER :: INDNPHSTY6,INDNPHSTY7,INDNPHSTY8
+INTEGER :: INDLPHCOLUSER,INDLPHSTYUSER
+INTEGER :: INDLPATCH
+#ifdef RHODES
+INTEGER :: ISTAF
+#endif
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+INTEGER :: INDXXPART,INDXYPART,INDXZPART,INDLTRAJ3D,INDLFLUX3D
+INTEGER :: INDLTRAJ_GROUP
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+INTEGER :: INBMIN, J, JJ, JM
+INTEGER :: ISTA
+INTEGER :: INBV, IND9999
+INTEGER :: INDQ1,INDQ2
+INTEGER,DIMENSION(30,100) :: IIMIN
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+INTEGER,DIMENSION(603) :: IT
+REAL,DIMENSION(100) :: ZISOLEV
+REAL :: ZISO, ZX, ZY
+LOGICAl :: GXI=.FALSE., GXJ=.FALSE.
+!!! NOVEMBRE 2009 G. TANGUY
+INTEGER :: INDL90TITYT,INDL90TITYM,INDL90TITYB
+!------------------------------------------------------------------------------
+!
+YCARIN=' '
+YCARIN = ADJUSTL(HCARIN)
+YCARIN = ADJUSTL(YCARIN)
+ILENC = LEN_TRIM(YCARIN)
+if(nverbia >0)then
+print *,' **entree caresolv YCARIN(1:LEN_TRIM(YCARIN)) ',YCARIN(1:ILENC)
+endif
+!
+INDID = INDEX(YCARIN,'_IDEM')
+IF(INDID /= 0)THEN
+ CALL CARMEMORY(YCAR,2)
+ YCAR=ADJUSTL(YCAR)
+! print *,' AP CARMEMORY YCAR ',YCAR(1:LEN_TRIM(YCAR))
+ ILENGRP=0
+! ILENGRP=INDEX(YCAR,'_')-1
+ ILENC2 = LEN_TRIM(YCAR)
+ YCARIN(INDID:INDID+ILENC2-ILENGRP-1)=YCAR(ILENGRP+1:ILENC2)
+ ILENC = LEN_TRIM(YCARIN)
+
+ DO J=1,20
+ IF((INDID-1+ILENC2-ILENGRP) >= ILENC)THEN
+ EXIT
+ ELSE
+ YCARIN(ILENC:ILENC)=' '
+ ILENC=ILENC-1
+ ENDIF
+ ENDDO
+
+ENDIF
+
+INDNSZLBX=INDEX(YCARIN,'NSZLBX')
+INDNSZLBY=INDEX(YCARIN,'NSZLBY')
+INDIINF=INDEX(YCARIN,'NIINF')
+INDISUP=INDEX(YCARIN,'NISUP')
+INDJINF=INDEX(YCARIN,'NJINF')
+INDJSUP=INDEX(YCARIN,'NJSUP')
+INDNHEURXLBL=INDEX(YCARIN,'NHEURXLBL')
+INDNHEURXGRAD=INDEX(YCARIN,'NHEURXGRAD')
+INDIDEBCOU=INDEX(YCARIN,'NIDEBCOU')
+INDJDEBCOU=INDEX(YCARIN,'NJDEBCOU')
+INDXTIMEMIN=INDEX(YCARIN,'XTIMEMIN')
+INDXTIMEMAX=INDEX(YCARIN,'XTIMEMAX')
+INDXIDEBCOU=INDEX(YCARIN,'XIDEBCOU')
+INDXJDEBCOU=INDEX(YCARIN,'XJDEBCOU')
+INDXSSP=INDEX(YCARIN,'XSSP')
+INDXARLSTR=INDEX(YCARIN,'XARLSTR')
+INDXLWSTR=INDEX(YCARIN,'XLWSTR')
+INDXANGULVT=INDEX(YCARIN,'XANGULVT')
+INDXFACTAXEX=INDEX(YCARIN,'XFACTAXEX')
+INDXFACTAXEY=INDEX(YCARIN,'XFACTAXEY')
+INDXAXEXUSERD=INDEX(YCARIN,'XAXEXUSERD')
+INDXAXEYUSERD=INDEX(YCARIN,'XAXEYUSERD')
+INDXAXEXUSERF=INDEX(YCARIN,'XAXEXUSERF')
+INDXAXEYUSERF=INDEX(YCARIN,'XAXEYUSERF')
+INDXSIZEL=INDEX(YCARIN,'XSIZEL')
+INDXSZTITXL=INDEX(YCARIN,'XSZTITXL')
+INDXSZTITXM=INDEX(YCARIN,'XSZTITXM')
+INDXSZTITXR=INDEX(YCARIN,'XSZTITXR')
+INDXSZTITYT=INDEX(YCARIN,'XSZTITYT')
+INDXSZTITYM=INDEX(YCARIN,'XSZTITYM')
+INDXSZTITYB=INDEX(YCARIN,'XSZTITYB')
+
+INDXSZTITT1=INDEX(YCARIN,'XSZTITT1')
+INDXSZTITT2=INDEX(YCARIN,'XSZTITT2')
+INDXSZTITT3=INDEX(YCARIN,'XSZTITT3')
+INDXPOSTITYT=INDEX(YCARIN,'XPOSTITYT')
+INDXPOSTITYM=INDEX(YCARIN,'XPOSTITYM')
+INDXPOSTITYB=INDEX(YCARIN,'XPOSTITYB')
+INDXPOSTITT1=INDEX(YCARIN,'XPOSTITT1')
+INDXPOSTITT2=INDEX(YCARIN,'XPOSTITT2')
+INDXPOSTITT3=INDEX(YCARIN,'XPOSTITT3')
+INDXYPOSTITT1=INDEX(YCARIN,'XYPOSTITT1')
+INDXYPOSTITT2=INDEX(YCARIN,'XYPOSTITT2')
+INDXYPOSTITT3=INDEX(YCARIN,'XYPOSTITT3')
+
+INDXSZTITB1=INDEX(YCARIN,'XSZTITB1')
+INDXSZTITB2=INDEX(YCARIN,'XSZTITB2')
+INDXSZTITB3=INDEX(YCARIN,'XSZTITB3')
+INDXPOSTITB1=INDEX(YCARIN,'XPOSTITB1')
+INDXPOSTITB2=INDEX(YCARIN,'XPOSTITB2')
+INDXPOSTITB3=INDEX(YCARIN,'XPOSTITB3')
+INDXYPOSTITYT=INDEX(YCARIN,'XYPOSTITYT')
+INDXYPOSTITYM=INDEX(YCARIN,'XYPOSTITYM')
+INDXYPOSTITYB=INDEX(YCARIN,'XYPOSTITYB')
+INDXYPOSTITB1=INDEX(YCARIN,'XYPOSTITB1')
+INDXYPOSTITB2=INDEX(YCARIN,'XYPOSTITB2')
+INDXYPOSTITB3=INDEX(YCARIN,'XYPOSTITB3')
+INDXSZTITVAR1=INDEX(YCARIN,'XSZTITVAR1')
+INDXSZTITVAR2=INDEX(YCARIN,'XSZTITVAR2')
+INDXSZTITVAR3=INDEX(YCARIN,'XSZTITVAR3')
+INDXSZTITVAR4=INDEX(YCARIN,'XSZTITVAR4')
+INDXSZTITVAR5=INDEX(YCARIN,'XSZTITVAR5')
+INDXSZTITVAR6=INDEX(YCARIN,'XSZTITVAR6')
+INDXSZTITVAR7=INDEX(YCARIN,'XSZTITVAR7')
+INDXSZTITVAR8=INDEX(YCARIN,'XSZTITVAR8')
+INDXPOSTITVAR1=INDEX(YCARIN,'XPOSTITVAR1')
+INDXPOSTITVAR2=INDEX(YCARIN,'XPOSTITVAR2')
+INDXPOSTITVAR3=INDEX(YCARIN,'XPOSTITVAR3')
+INDXYPOSTITVAR1=INDEX(YCARIN,'XYPOSTITVAR1')
+INDXYPOSTITVAR2=INDEX(YCARIN,'XYPOSTITVAR2')
+INDXYPOSTITVAR3=INDEX(YCARIN,'XYPOSTITVAR3')
+INDXPOSTITVAR4=INDEX(YCARIN,'XPOSTITVAR4')
+INDXPOSTITVAR5=INDEX(YCARIN,'XPOSTITVAR5')
+INDXPOSTITVAR6=INDEX(YCARIN,'XPOSTITVAR6')
+INDXYPOSTITVAR4=INDEX(YCARIN,'XYPOSTITVAR4')
+INDXYPOSTITVAR5=INDEX(YCARIN,'XYPOSTITVAR5')
+INDXYPOSTITVAR6=INDEX(YCARIN,'XYPOSTITVAR6')
+INDXPOSTITVAR7=INDEX(YCARIN,'XPOSTITVAR7')
+INDXPOSTITVAR8=INDEX(YCARIN,'XPOSTITVAR8')
+INDXYPOSTITVAR7=INDEX(YCARIN,'XYPOSTITVAR7')
+INDXYPOSTITVAR8=INDEX(YCARIN,'XYPOSTITVAR8')
+!*JD*Mars 2009
+INDXPOSXVARNPV1TOP=INDEX(YCARIN,'XPOSXVARNPV1TOP')
+INDXPOSYVARNPV1TOP=INDEX(YCARIN,'XPOSYVARNPV1TOP')
+INDXPOSXVARNPV5BOT=INDEX(YCARIN,'XPOSXVARNPV5BOT')
+INDXPOSYVARNPV5BOT=INDEX(YCARIN,'XPOSYVARNPV5BOT')
+INDXSZVARNPVTOP=INDEX(YCARIN,'XSZVARNPVTOP')
+INDXSZVARNPVBOT=INDEX(YCARIN,'XSZVARNPVBOT')
+!*JD*Mars 2009
+
+INDXIDEBCVLL=INDEX(YCARIN,'XIDEBCVLL')
+INDXIDEBCV=0
+IF(INDXIDEBCVLL == 0)THEN
+ INDXIDEBCV=INDEX(YCARIN,'XIDEBCV')
+ENDIF
+INDXJDEBCVLL=INDEX(YCARIN,'XJDEBCVLL')
+INDXJDEBCV=0
+IF(INDXJDEBCVLL == 0)THEN
+ INDXJDEBCV=INDEX(YCARIN,'XJDEBCV')
+ENDIF
+INDXIFINCVLL=INDEX(YCARIN,'XIFINCVLL')
+INDXIFINCV=0
+IF(INDXIFINCVLL == 0)THEN
+ INDXIFINCV=INDEX(YCARIN,'XIFINCV')
+ENDIF
+INDXJFINCVLL=INDEX(YCARIN,'XJFINCVLL')
+INDXJFINCV=0
+IF(INDXJFINCVLL == 0)THEN
+ INDXJFINCV=INDEX(YCARIN,'XJFINCV')
+ENDIF
+INDNIDEBCV=INDEX(YCARIN,'NIDEBCV')
+INDNJDEBCV=INDEX(YCARIN,'NJDEBCV')
+INDNIFINCV=INDEX(YCARIN,'NIFINCV')
+INDNJFINCV=INDEX(YCARIN,'NJFINCV')
+INDXAMX=INDEX(YCARIN,'XAMX')
+INDXVHC=INDEX(YCARIN,'XVHC=')
+IF(INDXVHC == 0)THEN
+ INDXVHC=INDEX(YCARIN,'XVHC =')
+ENDIF
+INDXVHCPH=INDEX(YCARIN,'XVHCPH')
+INDXVLC=INDEX(YCARIN,'XVLC')
+INDXVRL=INDEX(YCARIN,'XVRL=')
+IF(INDXVRL == 0)THEN
+ INDXVRL=INDEX(YCARIN,'XVRL =')
+ENDIF
+INDXVRLPH=INDEX(YCARIN,'XVRLPH')
+INDVISU=INDEX(YCARIN,'VISU')
+INDNOVISU=INDEX(YCARIN,'NOVISU')
+INDNVERBIA=INDEX(YCARIN,'NVERBIA')
+INDXPMIN=INDEX(YCARIN,'XPMIN')
+INDXPMAX=INDEX(YCARIN,'XPMAX')
+INDXPINT=INDEX(YCARIN,'XPINT')
+INDXHMIN=INDEX(YCARIN,'XHMIN')
+INDXHMAX=INDEX(YCARIN,'XHMAX')
+INDXLATRAD1=INDEX(YCARIN,'XLATRAD1')
+INDXLATRAD2=INDEX(YCARIN,'XLATRAD2')
+INDXLATRAD3=INDEX(YCARIN,'XLATRAD3')
+INDXLATRAD4=INDEX(YCARIN,'XLATRAD4')
+INDXLONRAD1=INDEX(YCARIN,'XLONRAD1')
+INDXLONRAD2=INDEX(YCARIN,'XLONRAD2')
+INDXLONRAD3=INDEX(YCARIN,'XLONRAD3')
+INDXLONRAD4=INDEX(YCARIN,'XLONRAD4')
+INDXSPVALT=INDEX(YCARIN,'XSPVALT')
+INDXSPVAL=INDEX(YCARIN,'XSPVAL=')
+IF(INDXSPVAL == 0)THEN
+ INDXSPVAL=INDEX(YCARIN,'XSPVAL =')
+ IF(INDXSPVAL == 0)THEN
+ INDXSPVAL=INDEX(YCARIN,'XSPVAL =')
+ ENDIF
+ENDIF
+INDXPORTRAD1=INDEX(YCARIN,'XPORTRAD1')
+INDXPORTRAD2=INDEX(YCARIN,'XPORTRAD2')
+INDXPORTRAD3=INDEX(YCARIN,'XPORTRAD3')
+INDXPORTRAD4=INDEX(YCARIN,'XPORTRAD4')
+INDXLWRAD1=INDEX(YCARIN,'XLWRAD1')
+INDXLWRAD2=INDEX(YCARIN,'XLWRAD2')
+INDXLWRAD3=INDEX(YCARIN,'XLWRAD3')
+INDXLWRAD4=INDEX(YCARIN,'XLWRAD4')
+INDXISOMIN_=INDEX(YCARIN,'XISOMIN_')
+INDXISOMAX_=INDEX(YCARIN,'XISOMAX_')
+INDXISOMIN=INDEX(YCARIN,'XISOMIN')
+INDXISOMAX=INDEX(YCARIN,'XISOMAX')
+IF(INDXISOMIN_ /= 0)THEN
+ INDXISOMIN=0
+ENDIF
+IF(INDXISOMAX_ /= 0)THEN
+ INDXISOMAX=0
+ENDIF
+INDNLANGLE=INDEX(YCARIN,'NLANGLE')
+INDNLMAX=INDEX(YCARIN,'NLMAX')
+INDNZSTR=INDEX(YCARIN,'NZSTR')
+INDNARSTR=INDEX(YCARIN,'NARSTR')
+INDNIOFFD=INDEX(YCARIN,'NIOFFD')
+INDNSD=INDEX(YCARIN,'NSD')
+INDNULBLL=INDEX(YCARIN,'NULBLL')
+INDNDOT=INDEX(YCARIN,'NDOT')
+INDNISKIP=INDEX(YCARIN,'NISKIP=')
+IF(INDNISKIP == 0)THEN
+ INDNISKIP=INDEX(YCARIN,'NISKIP =')
+ENDIF
+INDNISKIPVX=INDEX(YCARIN,'NISKIPVX')
+INDNISKIPVY=INDEX(YCARIN,'NISKIPVY')
+INDNHI=INDEX(YCARIN,'NHI')
+INDNIMNMX=INDEX(YCARIN,'NIMNMX')
+INDNFT1ITVXMJ=INDEX(YCARIN,'NFT1ITVXMJ')
+INDNFT1ITVXMN=INDEX(YCARIN,'NFT1ITVXMN')
+INDNFT1ITVYMJ=INDEX(YCARIN,'NFT1ITVYMJ')
+INDNFT1ITVYMN=INDEX(YCARIN,'NFT1ITVYMN')
+INDNFTITVXMJ=INDEX(YCARIN,'NFTITVXMJ')
+INDNFTITVXMN=INDEX(YCARIN,'NFTITVXMN')
+INDNFTITVYMJ=INDEX(YCARIN,'NFTITVYMJ')
+INDNFTITVYMN=INDEX(YCARIN,'NFTITVYMN')
+INDNCHITVXMJ=INDEX(YCARIN,'NCHITVXMJ')
+INDNCHITVXMN=INDEX(YCARIN,'NCHITVXMN')
+INDNCHITVYMJ=INDEX(YCARIN,'NCHITVYMJ')
+INDNCHITVYMN=INDEX(YCARIN,'NCHITVYMN')
+INDNCHPCITVXMJ=INDEX(YCARIN,'NCHPCITVXMJ')
+INDNCHPCITVXMN=INDEX(YCARIN,'NCHPCITVXMN')
+INDNCHPCITVYMJ=INDEX(YCARIN,'NCHPCITVYMJ')
+INDNCHPCITVYMN=INDEX(YCARIN,'NCHPCITVYMN')
+INDNCVITVXMJ=INDEX(YCARIN,'NCVITVXMJ')
+INDNCVITVXMN=INDEX(YCARIN,'NCVITVXMN')
+INDNCVITVYMJ=INDEX(YCARIN,'NCVITVYMJ')
+INDNCVITVYMN=INDEX(YCARIN,'NCVITVYMN')
+INDNPVITVXMJ=INDEX(YCARIN,'NPVITVXMJ')
+INDNPVITVXMN=INDEX(YCARIN,'NPVITVXMN')
+INDNPVITVYMJ=INDEX(YCARIN,'NPVITVYMJ')
+INDNPVITVYMN=INDEX(YCARIN,'NPVITVYMN')
+INDNXYITVXMJ=INDEX(YCARIN,'NXYITVXMJ')
+INDNXYITVXMN=INDEX(YCARIN,'NXYITVXMN')
+INDNXYITVYMJ=INDEX(YCARIN,'NXYITVYMJ')
+INDNXYITVYMN=INDEX(YCARIN,'NXYITVYMN')
+INDNMASKITVXMJ=INDEX(YCARIN,'NMASKITVXMJ')
+INDNMASKITVXMN=INDEX(YCARIN,'NMASKITVXMN')
+INDNMASKITVYMJ=INDEX(YCARIN,'NMASKITVYMJ')
+INDNMASKITVYMN=INDEX(YCARIN,'NMASKITVYMN')
+INDXDIAINT_=INDEX(YCARIN,'XDIAINT_')
+INDXDIAINT=INDEX(YCARIN,'XDIAINT')
+IF(INDXDIAINT_ /= 0)THEN
+ INDXDIAINT=0
+ENDIF
+!!!!!!!!!!
+INDLVARNPVUSER=INDEX(YCARIN,'LVARNPVUSER')
+INDLVPTFT1USER=INDEX(YCARIN,'LVPTFT1USER')
+INDLVARNPHUSER=INDEX(YCARIN,'LVARNPHUSER')
+!!!!!!!!!!
+INDLM5S3=INDEX(YCARIN,'LM5S3')
+INDLSYMBTEXTG=INDEX(YCARIN,'LSYMBTEXTG')
+INDLCVZOOM=INDEX(YCARIN,'LCVZOOM')
+INDLVST=INDEX(YCARIN,'LVST')
+INDLDILW=INDEX(YCARIN,'LDILW')
+INDLXYNVARTOP=INDEX(YCARIN,'LXYNVARTOP')
+INDLXYSTYLTOP=INDEX(YCARIN,'LXYSTYLTOP')
+INDLXYWINCUR=INDEX(YCARIN,'LXYWINCUR')
+INDLVSUPSCA=INDEX(YCARIN,'LVSUPSCA')
+INDLSYMB=INDEX(YCARIN,'LSYMB=')
+IF(INDLSYMB == 0)THEN
+ INDLSYMB=INDEX(YCARIN,'LSYMB =')
+ENDIF
+INDLTEXTG=INDEX(YCARIN,'LTEXTG')
+INDLTEXTIT=INDEX(YCARIN,'LTEXTIT')
+INDLTRACECV=INDEX(YCARIN,'LTRACECV')
+INDLSTI=INDEX(YCARIN,'LSTI')
+INDLSEGM=INDEX(YCARIN,'OLSEGM')
+IF(INDLSEGM == 0)THEN
+ INDLSEGM=INDEX(YCARIN,'LSEGM')
+ELSE
+ INDLSEGM=0
+ENDIF
+INDLXY=INDEX(YCARIN,'LXY=')
+IF(INDLXY == 0)THEN
+ INDLXY=INDEX(YCARIN,'LXY =')
+ENDIF
+INDLXZ=INDEX(YCARIN,'LXZ')
+INDLVECTMNMX=INDEX(YCARIN,'LVECTMNMX')
+INDLISO=INDEX(YCARIN,'LISO=')
+IF(INDLISO == 0)THEN
+ INDLISO=INDEX(YCARIN,'LISO =')
+ENDIF
+INDLANIMK=INDEX(YCARIN,'LANIMK')
+INDLANIMT=INDEX(YCARIN,'LANIMT')
+INDLMINMAX=INDEX(YCARIN,'LMINMAX')
+INDATFILE=INDEX(YCARIN,'LDATFILE')
+INDLINTERPTOP=INDEX(YCARIN,'LINTERPTOP=')
+INDLSPSECT=INDEX(YCARIN,'LSPSECT')
+INDLSPVALT=INDEX(YCARIN,'LSPVALT')
+INDLPRESY=INDEX(YCARIN,'LPRESY')
+INDLEGVECT=INDEX(YCARIN,'LEGVECT')
+INDLSTREAM=INDEX(YCARIN,'LSTREAM')
+INDLINTERPOLSTR=INDEX(YCARIN,'LINTERPOLSTR')
+INDLNOLBLBAR=INDEX(YCARIN,'LNOLBLBAR')
+INDLNOLABELX=INDEX(YCARIN,'LNOLABELX')
+INDLNOLABELY=INDEX(YCARIN,'LNOLABELY')
+INDLNOUVRS=INDEX(YCARIN,'LNOUVRS')
+INDLMYHEURX=INDEX(YCARIN,'LMYHEURX')
+INDLRADAR=INDEX(YCARIN,'LRADAR')
+INDLRADIST=INDEX(YCARIN,'LRADIST')
+INDLRADRAY=INDEX(YCARIN,'LRADRAY')
+INDLCOLAREA=INDEX(YCARIN,'LCOLAREA=')
+IF(INDLCOLAREA == 0)THEN
+ INDLCOLAREA=INDEX(YCARIN,'LCOLAREA =')
+ENDIF
+INDLFT1LUSER=INDEX(YCARIN,'LFT1LUSER')
+INDLFTBAUTO=INDEX(YCARIN,'LFTBAUTO')
+INDLFT1BAUTO=INDEX(YCARIN,'LFT1BAUTO')
+INDLTITFTUSER=INDEX(YCARIN,'LTITFTUSER')
+INDLPHCOLUSER=INDEX(YCARIN,'LPHCOLUSER')
+INDLPHSTYUSER=INDEX(YCARIN,'LPHSTYUSER')
+INDLXABSC=INDEX(YCARIN,'LXABSC')
+INDLXMINTOP=INDEX(YCARIN,'LXMINTOP')
+INDLABEL1=INDEX(YCARIN,'LABEL1')
+INDLDEFCV2LL=INDEX(YCARIN,'LDEFCV2LL')
+INDLDEFCV2IND=INDEX(YCARIN,'LDEFCV2IND')
+INDLDEFCV2=0
+INDLDEFCV2=INDEX(YCARIN,'LDEFCV2=')
+IF(INDLDEFCV2 == 0)THEN
+ INDLDEFCV2=INDEX(YCARIN,'LDEFCV2 =')
+ENDIF
+IF(INDLDEFCV2 == 0)THEN
+ INDLDEFCV2=INDEX(YCARIN,'LDEFCV2 =')
+ENDIF
+IF(NVERBIA > 0)THEN
+print *,' INDLDEFCV2LL,INDLDEFCV2IND,INDLDEFCV2 ',INDLDEFCV2LL,INDLDEFCV2IND,INDLDEFCV2
+ENDIF
+INDLBLUSER1=INDEX(YCARIN,'LBLUSER1')
+INDLBLUSER2=INDEX(YCARIN,'LBLUSER2')
+INDLBLUSER3=INDEX(YCARIN,'LBLUSER3')
+INDLBLUSER4=INDEX(YCARIN,'LBLUSER4')
+INDLINDSP=INDEX(YCARIN,'LINDSP')
+INDLINDAX=INDEX(YCARIN,'LINDAX')
+INDLCOLUSERUV=INDEX(YCARIN,'LCOLUSERUV')
+INDLTIMEUSER=INDEX(YCARIN,'LTIMEUSER')
+INDLCHREEL=INDEX(YCARIN,'LCHREEL')
+INDLOGNEP=INDEX(YCARIN,'LOGNEP')
+INDLCOLISONE=INDEX(YCARIN,'LCOLISONE')
+INDLCOLRSONE=INDEX(YCARIN,'LCOLRSONE')
+INDLCOLRS1ONE=INDEX(YCARIN,'LCOLRS1ONE')
+INDLCOLINE=INDEX(YCARIN,'LCOLINE')
+INDL24H=INDEX(YCARIN,'L24H')
+INDLCONT=INDEX(YCARIN,'LCONT')
+INDL2CONT=INDEX(YCARIN,'L2CONT')
+INDLRELIEF=INDEX(YCARIN,'LRELIEF')
+INDLCONV2XY=INDEX(YCARIN,'LCONV2XY')
+INDLCONVG2MASS=INDEX(YCARIN,'LCONVG2MASS')
+INDLCOLZERO=INDEX(YCARIN,'LCOLZERO')
+INDL3D=INDEX(YCARIN,'L3D')
+INDLMARKER=INDEX(YCARIN,'LMARKER')
+INDLPRDAT=INDEX(YCARIN,'LPRDAT')
+INDLPRINTXY=INDEX(YCARIN,'LPRINTXY')
+INDLPRINT=INDEX(YCARIN,'LPRINT')
+IF((INDLPRINTXY == 0 .AND. INDLPRINT == 0) .OR. (INDLPRINTXY /= INDLPRINT))THEN
+ELSE
+ INDLPRINT=INDEX(YCARIN(INDLPRINTXY+1:LEN_TRIM(YCARIN)),'LPRINT')
+ IF(INDLPRINT /= 0)THEN
+ INDLPRINT=INDLPRINT+INDLPRINTXY
+ ENDIF
+ENDIF
+INDLPOINTG=INDEX(YCARIN,'LPOINTG')
+INDLXYO=INDEX(YCARIN,'LXYO')
+INDL2DBX=INDEX(YCARIN,'L2DBX')
+INDL2DBY=INDEX(YCARIN,'L2DBY')
+INDLTIMEUSER=INDEX(YCARIN,'LTIMEUSER=')
+INDLCOLUSER=INDEX(YCARIN,'LCOLUSER=')
+IF(INDLCOLUSER == 0)THEN
+ INDLCOLUSER=INDEX(YCARIN,'LCOLUSER =')
+ENDIF
+IF(INDLCOLUSER == 0)THEN
+ INDLCOLUSER=INDEX(YCARIN,'LCOLUSER =')
+ENDIF
+INDLISOWHI2=INDEX(YCARIN,'LISOWHI2')
+INDLISOWHI3=INDEX(YCARIN,'LISOWHI3')
+INDLISOWHI=INDEX(YCARIN,'LISOWHI=')
+IF(INDLISOWHI == 0)THEN
+ INDLISOWHI=INDEX(YCARIN,'LISOWHI =')
+ENDIF
+IF(INDLISOWHI == 0)THEN
+ INDLISOWHI=INDEX(YCARIN,'LISOWHI =')
+ENDIF
+IF(INDLISOWHI == 0)THEN
+ INDLISOWHI=INDEX(YCARIN,'LISOWHI =')
+ENDIF
+INDLCOLBR=INDEX(YCARIN,'LCOLBR')
+INDLCOLAREASEL=INDEX(YCARIN,'LCOLAREASEL')
+INDLCOLINESEL=INDEX(YCARIN,'LCOLINESEL')
+INDLINVWB=INDEX(YCARIN,'LINVWB')
+INDLINVPTIR=INDEX(YCARIN,'LINVPTIR')
+INDLDOMAIN=INDEX(YCARIN,'LDOMAIN')
+INDLGEOG=INDEX(YCARIN,'LGEOG')
+INDLBLFT1SUP=INDEX(YCARIN,'LBLFT1SUP')
+INDLMASK3D_XY=INDEX(YCARIN,'LMASK3D_XY')
+INDLMASK3D_XZ=INDEX(YCARIN,'LMASK3D_XZ')
+INDLMASK3D_YZ=INDEX(YCARIN,'LMASK3D_YZ')
+INDLMASK3D=INDEX(YCARIN,'LMASK3D=')
+IF(INDLMASK3D == 0)THEN
+ INDLMASK3D=INDEX(YCARIN,'LMASK3D =')
+ENDIF
+IF(INDLMASK3D == 0)THEN
+ INDLMASK3D=INDEX(YCARIN,'LMASK3D =')
+ENDIF
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+INDLTRAJ3D=INDEX(YCARIN,'LTRAJ3D=')
+IF(INDLTRAJ3D == 0)THEN
+ INDLTRAJ3D=INDEX(YCARIN,'LTRAJ3D =')
+ENDIF
+IF(INDLTRAJ3D == 0)THEN
+ INDLTRAJ3D=INDEX(YCARIN,'LTRAJ3D =')
+ENDIF
+!
+INDLFLUX3D=INDEX(YCARIN,'LFLUX3D=')
+IF(INDLFLUX3D == 0)THEN
+ INDLFLUX3D=INDEX(YCARIN,'LFLUX3D =')
+ENDIF
+IF(INDLFLUX3D == 0)THEN
+ INDLFLUX3D=INDEX(YCARIN,'LFLUX3D =')
+ENDIF
+!
+INDLTRAJ_GROUP=INDEX(YCARIN,'LTRAJ_GROUP=')
+IF(INDLTRAJ_GROUP == 0)THEN
+ INDLTRAJ_GROUP=INDEX(YCARIN,'LTRAJ_GROUP =')
+ENDIF
+IF(INDLTRAJ_GROUP == 0)THEN
+ INDLTRAJ_GROUP=INDEX(YCARIN,'LTRAJ_GROUP =')
+ENDIF
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!IF(INDLMASK3D /= 0)THEN
+! LMASK3D_XY=.TRUE.
+! LMASK3D_XZ=.TRUE.
+! LMASK3D_YZ=.TRUE.
+!ENDIF
+INDLXYZ00=INDEX(YCARIN,'LXYZ00')
+INDLFT3C=INDEX(YCARIN,'LFT3C')
+INDLFT4C=INDEX(YCARIN,'LFT4C')
+INDLFTCLIP=INDEX(YCARIN,'LFTCLIP')
+INDLFT1STYLUSER=INDEX(YCARIN,'LFT1STYLUSER')
+INDLFTSTYLUSER=INDEX(YCARIN,'LFTSTYLUSER')
+INDLHEURX=INDEX(YCARIN,'LHEURX')
+INDLHACH1=INDEX(YCARIN,'LHACH1')
+INDLHACH2=INDEX(YCARIN,'LHACH2')
+INDLHACH3=INDEX(YCARIN,'LHACH3')
+INDLHACH4=INDEX(YCARIN,'LHACH4')
+INDLHACHSEL=INDEX(YCARIN,'LHACHSEL')
+INDLGREY=INDEX(YCARIN,'LGREY')
+INDLTABCOLDEF2=INDEX(YCARIN,'LTABCOLDEF2')
+IF(INDLTABCOLDEF2 == 0)THEN
+INDLTABCOLDEF=INDEX(YCARIN,'LTABCOLDEF')
+ELSE
+LTABCOLDEF=.TRUE.
+ENDIF
+INDLTABCOLDEF=INDEX(YCARIN,'LTABCOLDEF=')
+IF(INDLTABCOLDEF == 0)THEN
+ INDLTABCOLDEF=INDEX(YCARIN,'LTABCOLDEF =')
+ENDIF
+INDLMNMXUSER=INDEX(YCARIN,'LMNMXUSER')
+!Mars 2009
+INDLINZEROPV=INDEX(YCARIN,'LINZEROPV')
+INDNSTYLINZEROPV=INDEX(YCARIN,'NSTYLINZEROPV')
+IF(INDNSTYLINZEROPV /= 0 .AND. (ABS(INDNSTYLINZEROPV-INDLINZEROPV) == 4))THEN
+ INDLINZEROPV=0
+ENDIF
+!Mars 2009
+INDLMNMXLOC=INDEX(YCARIN,'LMNMXLOC')
+INDLULMVTMOLD=INDEX(YCARIN,'LULMVTMOLD')
+INDLVPTUSER=INDEX(YCARIN,'LVPTUSER')
+INDLVPTVUSER=INDEX(YCARIN,'LVPTVUSER')
+INDLVPTPVUSER=INDEX(YCARIN,'LVPTPVUSER')
+INDLVPTXYUSER=INDEX(YCARIN,'LVPTXYUSER')
+INDLFACTIMP=INDEX(YCARIN,'LFACTIMP')
+INDLFACTAXEX=INDEX(YCARIN,'LFACTAXEX')
+INDLFACTAXEY=INDEX(YCARIN,'LFACTAXEY')
+INDLAXEYUSER=INDEX(YCARIN,'LAXEYUSER')
+INDLAXEXUSER=INDEX(YCARIN,'LAXEXUSER')
+INDLFMTAXEX=INDEX(YCARIN,'LFMTAXEX')
+INDLFMTAXEY=INDEX(YCARIN,'LFMTAXEY')
+INDLSPOT=INDEX(YCARIN,'LSPOT')
+INDNIFDC=INDEX(YCARIN,'NIFDC')
+INDNDOMAINL=INDEX(YCARIN,'NDOMAINL')
+INDNDOMAINR=INDEX(YCARIN,'NDOMAINR')
+INDNDOMAINB=INDEX(YCARIN,'NDOMAINB')
+INDNDOMAINT=INDEX(YCARIN,'NDOMAINT')
+INDNIGRNC=INDEX(YCARIN,'NIGRNC')
+INDNPROFILE=INDEX(YCARIN,'PROFILE')
+INDXPVMIN=INDEX(YCARIN,'XPVMIN_')
+INDXPVMAX=INDEX(YCARIN,'XPVMAX_')
+INDXPVMINT=INDEX(YCARIN,'XPVMINT')
+INDXPVMAXT=INDEX(YCARIN,'XPVMAXT')
+INDXLWFTALL=INDEX(YCARIN,'XLWFTALL')
+INDXLWSEGM=INDEX(YCARIN,'XLWSEGM')
+INDXLWDOMAIN=INDEX(YCARIN,'XLWDOMAIN')
+INDXLWTRACECV=INDEX(YCARIN,'XLWTRACECV')
+INDXLWV=INDEX(YCARIN,'XLWV=')
+IF(INDXLWV == 0)THEN
+ INDXLWV=INDEX(YCARIN,'XLWV =')
+ENDIF
+IF(INDXLWV == 0)THEN
+ INDXLWV=INDEX(YCARIN,'XLWV =')
+ENDIF
+IF(INDXLWV == 0)THEN
+ INDXLWV=INDEX(YCARIN,'XLWV =')
+ENDIF
+INDXLW=INDEX(YCARIN,'XLW=')
+IF(INDXLW == 0)THEN
+ INDXLW=INDEX(YCARIN,'XLW =')
+ENDIF
+IF(INDXLW == 0)THEN
+ INDXLW=INDEX(YCARIN,'XLW =')
+ENDIF
+IF(INDXLW == 0)THEN
+ INDXLW=INDEX(YCARIN,'XLW =')
+ENDIF
+INDXLW1=INDEX(YCARIN,'XLW1')
+INDXLW2=INDEX(YCARIN,'XLW2')
+INDXLW3=INDEX(YCARIN,'XLW3')
+INDXLW4=INDEX(YCARIN,'XLW4')
+INDXLWDEF=INDEX(YCARIN,'XLWDEF')
+INDXLWVDEF=INDEX(YCARIN,'XLWVDEF')
+INDXLWCONT=INDEX(YCARIN,'XLWCONT')
+INDXLWPV1=INDEX(YCARIN,'XLWPV1')
+INDXLWPV2=INDEX(YCARIN,'XLWPV2')
+INDXLWPV3=INDEX(YCARIN,'XLWPV3')
+INDXLWPV4=INDEX(YCARIN,'XLWPV4')
+INDXLWPV5=INDEX(YCARIN,'XLWPV5')
+INDXLWPV6=INDEX(YCARIN,'XLWPV6')
+INDXLWPV7=INDEX(YCARIN,'XLWPV7')
+INDXLWPV8=INDEX(YCARIN,'XLWPV8')
+INDXLWPV9=INDEX(YCARIN,'XLWPV9')
+INDXLWPV10=INDEX(YCARIN,'XLWPV10')
+INDXLWPV11=INDEX(YCARIN,'XLWPV11')
+INDXLWPV12=INDEX(YCARIN,'XLWPV12')
+INDXLWPV13=INDEX(YCARIN,'XLWPV13')
+INDXLWPV14=INDEX(YCARIN,'XLWPV14')
+INDXLWPV15=INDEX(YCARIN,'XLWPV15')
+INDXSTYLPV1=INDEX(YCARIN,'XSTYLPV1')
+INDXSTYLPV2=INDEX(YCARIN,'XSTYLPV2')
+INDXSTYLPV3=INDEX(YCARIN,'XSTYLPV3')
+INDXSTYLPV4=INDEX(YCARIN,'XSTYLPV4')
+INDXSTYLPV5=INDEX(YCARIN,'XSTYLPV5')
+INDXSTYLPV6=INDEX(YCARIN,'XSTYLPV6')
+INDXSTYLPV7=INDEX(YCARIN,'XSTYLPV7')
+INDXSTYLPV8=INDEX(YCARIN,'XSTYLPV8')
+INDXSTYLPV9=INDEX(YCARIN,'XSTYLPV9')
+INDXSTYLPV10=INDEX(YCARIN,'XSTYLPV10')
+INDXSTYLPV11=INDEX(YCARIN,'XSTYLPV11')
+INDXSTYLPV12=INDEX(YCARIN,'XSTYLPV12')
+INDXSTYLPV13=INDEX(YCARIN,'XSTYLPV13')
+INDXSTYLPV14=INDEX(YCARIN,'XSTYLPV14')
+INDXSTYLPV15=INDEX(YCARIN,'XSTYLPV15')
+INDXPARCOLUV=INDEX(YCARIN,'XPARCOLUV')
+INDXISOLEV_=INDEX(YCARIN,'XISOLEV_')
+INDXISOLEV=INDEX(YCARIN,'XISOLEV')
+IF(INDXISOLEV_ /= 0)THEN
+ INDXISOLEV=0
+ENDIF
+INDXICAR=INDEX(YCARIN,'XICAR')
+INDXJCAR=INDEX(YCARIN,'XJCAR')
+INDXLWPH1=INDEX(YCARIN,'XLWPH1')
+INDXLWPH2=INDEX(YCARIN,'XLWPH2')
+INDXLWPH3=INDEX(YCARIN,'XLWPH3')
+INDXLWPH4=INDEX(YCARIN,'XLWPH4')
+INDXLWPH5=INDEX(YCARIN,'XLWPH5')
+INDXLWPH6=INDEX(YCARIN,'XLWPH6')
+INDXLWPH7=INDEX(YCARIN,'XLWPH7')
+INDXLWPH8=INDEX(YCARIN,'XLWPH8')
+INDXLATCAR=INDEX(YCARIN,'XLATCAR')
+INDXLONCAR=INDEX(YCARIN,'XLONCAR')
+INDCNOMCAR=INDEX(YCARIN,'CNOMCAR')
+INDCSYMCAR=INDEX(YCARIN,'CSYMCAR')
+INDCSYMRAD1=INDEX(YCARIN,'CSYMRAD1')
+INDCSYMRAD2=INDEX(YCARIN,'CSYMRAD2')
+INDCSYMRAD3=INDEX(YCARIN,'CSYMRAD3')
+INDCSYMRAD4=INDEX(YCARIN,'CSYMRAD4')
+INDXPOSNOM=INDEX(YCARIN,'XPOSNOM')
+INDXSZNOM=INDEX(YCARIN,'XSZNOM')
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!! pour les retrotrajectoires !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+INDNSZRTRAJ=INDEX(YCARIN,'NSZRTRAJ')
+INDLFMTRTRAJ=INDEX(YCARIN,'LFMTRTRAJ')
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+INDXSZSYM=INDEX(YCARIN,'XSZSYM')
+INDICOLNOM=INDEX(YCARIN,'ICOLNOM')
+INDICOLSYM=INDEX(YCARIN,'ICOLSYM')
+INDNINDCOLUV=INDEX(YCARIN,'NINDCOLUV')
+INDXXL=INDEX(YCARIN,'XXL')
+INDXXH=INDEX(YCARIN,'XXH')
+INDXVPTXYL=INDEX(YCARIN,'XVPTXYL')
+INDXYL=0
+IF(INDXVPTXYL == 0)THEN
+ INDXYL=INDEX(YCARIN,'XYL')
+! Aout 2001 Pour tenir compte de EMIS_XYLE (xylene chimie)
+ IF(INDXYL /= 0)THEN
+ INDTMP=0
+ INDTMP=INDEX(YCARIN,'_XYLE')
+ IF(INDTMP /= 0)THEN
+ INDXYL=0
+ ENDIF
+ ENDIF
+! Aout 2001 Pour tenir compte de EMIS_XYLE (xylene chimie)
+ENDIF
+INDXYH=INDEX(YCARIN,'XYH')
+INDXZL=INDEX(YCARIN,'XZL')
+INDXZH=INDEX(YCARIN,'XZH')
+INDXFT_ADTIM1=INDEX(YCARIN,'XFT_ADTIM1')
+INDXFT_ADTIM2=INDEX(YCARIN,'XFT_ADTIM2')
+INDXFT_ADTIM3=INDEX(YCARIN,'XFT_ADTIM3')
+INDXFT_ADTIM4=INDEX(YCARIN,'XFT_ADTIM4')
+INDXFT_ADTIM5=INDEX(YCARIN,'XFT_ADTIM5')
+INDXFT_ADTIM6=INDEX(YCARIN,'XFT_ADTIM6')
+INDXFT_ADTIM7=INDEX(YCARIN,'XFT_ADTIM7')
+INDXFT_ADTIM8=INDEX(YCARIN,'XFT_ADTIM8')
+INDXFT1_ADTIM1=INDEX(YCARIN,'XFT1_ADTIM1')
+INDXFT1_ADTIM2=INDEX(YCARIN,'XFT1_ADTIM2')
+INDXFT1_ADTIM3=INDEX(YCARIN,'XFT1_ADTIM3')
+INDXFT1_ADTIM4=INDEX(YCARIN,'XFT1_ADTIM4')
+INDXFT1_ADTIM5=INDEX(YCARIN,'XFT1_ADTIM5')
+INDXFT1_ADTIM6=INDEX(YCARIN,'XFT1_ADTIM6')
+INDXFT1_ADTIM7=INDEX(YCARIN,'XFT1_ADTIM7')
+INDXFT1_ADTIM8=INDEX(YCARIN,'XFT1_ADTIM8')
+INDXFTMIN=INDEX(YCARIN,'XFTMIN')
+INDXFTMAX=INDEX(YCARIN,'XFTMAX')
+INDXFT1MIN=INDEX(YCARIN,'XFT1MIN')
+INDXFT1MAX=INDEX(YCARIN,'XFT1MAX')
+print *,' ***CARESOLV INDXFT1MIN,INDXFT1MAX ',INDXFT1MIN,INDXFT1MAX
+INDXFT1MIN_=INDEX(YCARIN,'XFT1MIN_')
+INDXFT1MAX_=INDEX(YCARIN,'XFT1MAX_')
+IF(INDXFT1MIN_ /= 0)THEN
+ INDXFT1MIN=0
+ENDIF
+IF(INDXFT1MAX_ /= 0)THEN
+ INDXFT1MAX=0
+ENDIF
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+INDXXPART=INDEX(YCARIN,'XXPART')
+INDXYPART=INDEX(YCARIN,'XYPART')
+INDXZPART=INDEX(YCARIN,'XZPART')
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+INDXPVKTMIN=INDEX(YCARIN,'XPVKTMIN')
+INDXPVKTMAX=INDEX(YCARIN,'XPVKTMAX')
+INDXVARMIN=INDEX(YCARIN,'XVARMIN')
+INDXVARMAX=INDEX(YCARIN,'XVARMAX')
+INDXZTMIN=INDEX(YCARIN,'XZTMIN')
+INDXZTMAX=INDEX(YCARIN,'XZTMAX')
+INDXVPTL=INDEX(YCARIN,'XVPTL')
+INDXVPTR=INDEX(YCARIN,'XVPTR')
+INDXVPTB=INDEX(YCARIN,'XVPTB')
+INDXVPTT=INDEX(YCARIN,'XVPTT')
+INDXVPTVL=INDEX(YCARIN,'XVPTVL')
+INDXVPTVR=INDEX(YCARIN,'XVPTVR')
+INDXVPTVB=INDEX(YCARIN,'XVPTVB')
+INDXVPTVT=INDEX(YCARIN,'XVPTVT')
+INDXVPTPVL=INDEX(YCARIN,'XVPTPVL')
+INDXVPTPVR=INDEX(YCARIN,'XVPTPVR')
+INDXVPTPVB=INDEX(YCARIN,'XVPTPVB')
+INDXVPTPVT=INDEX(YCARIN,'XVPTPVT')
+INDXVPTXYL=INDEX(YCARIN,'XVPTXYL')
+INDXVPTXYR=INDEX(YCARIN,'XVPTXYR')
+INDXVPTXYB=INDEX(YCARIN,'XVPTXYB')
+INDXVPTXYT=INDEX(YCARIN,'XVPTXYT')
+!!!!!!!!!!!!!
+INDXVPTFT1L=INDEX(YCARIN,'XVPTFT1L')
+INDXVPTFT1R=INDEX(YCARIN,'XVPTFT1R')
+INDXVPTFT1B=INDEX(YCARIN,'XVPTFT1B')
+INDXVPTFT1T=INDEX(YCARIN,'XVPTFT1T')
+!!!!!!!!!!!!!
+INDNIRS=INDEX(YCARIN,'NIRS')
+INDNJRS=INDEX(YCARIN,'NJRS')
+INDXIRS=INDEX(YCARIN,'XIRS')
+INDXJRS=INDEX(YCARIN,'XJRS')
+INDNCOLZERO=INDEX(YCARIN,'NCOLZERO')
+INDNCOLUV1=INDEX(YCARIN,'NCOLUV1')
+INDNCOLUV2=INDEX(YCARIN,'NCOLUV2')
+INDNCOLUV3=INDEX(YCARIN,'NCOLUV3')
+INDNCOLUV4=INDEX(YCARIN,'NCOLUV4')
+INDNCOLUV5=INDEX(YCARIN,'NCOLUV5')
+INDNCOLSEGM=INDEX(YCARIN,'NCOLSEGMS')
+INDNCOLISONE1=INDEX(YCARIN,'NCOLISONE1')
+INDNCOLISONE2=INDEX(YCARIN,'NCOLISONE2')
+INDNCOLISONE3=INDEX(YCARIN,'NCOLISONE3')
+INDNCOLISONE4=INDEX(YCARIN,'NCOLISONE4')
+INDNCOLISONE5=INDEX(YCARIN,'NCOLISONE5')
+INDNCOLRS1ONE1=INDEX(YCARIN,'NCOLRS1ONE1')
+INDNCOLRS1ONE2=INDEX(YCARIN,'NCOLRS1ONE2')
+INDNCOLRS1ONE3=INDEX(YCARIN,'NCOLRS1ONE3')
+INDNCOLRS1ONE4=INDEX(YCARIN,'NCOLRS1ONE4')
+INDNCOLRS1ONE5=INDEX(YCARIN,'NCOLRS1ONE5')
+INDNCOLRSONE=INDEX(YCARIN,'NCOLRSONE')
+INDXISOREF_=INDEX(YCARIN,'XISOREF_')
+INDXISOREF=INDEX(YCARIN,'XISOREF')
+IF(INDXISOREF_ /= 0)THEN
+ INDXISOLEV=0
+ENDIF
+!*JD* Mars 2009
+INDNFT1STY1=INDEX(YCARIN,'NFT1STY1')
+INDNFT1STY2=INDEX(YCARIN,'NFT1STY2')
+INDNFT1STY3=INDEX(YCARIN,'NFT1STY3')
+INDNFT1STY4=INDEX(YCARIN,'NFT1STY4')
+INDNFT1STY5=INDEX(YCARIN,'NFT1STY5')
+INDNFT1STY6=INDEX(YCARIN,'NFT1STY6')
+INDNFT1STY7=INDEX(YCARIN,'NFT1STY7')
+INDNFT1STY8=INDEX(YCARIN,'NFT1STY8')
+INDNFT1STY9=INDEX(YCARIN,'NFT1STY9')
+INDNFT1STY10=INDEX(YCARIN,'NFT1STY10')
+INDNFT1STY11=INDEX(YCARIN,'NFT1STY11')
+INDNFT1STY12=INDEX(YCARIN,'NFT1STY12')
+INDNFT1STY13=INDEX(YCARIN,'NFT1STY13')
+INDNFT1STY14=INDEX(YCARIN,'NFT1STY14')
+INDNFT1STY15=INDEX(YCARIN,'NFT1STY15')
+!
+INDNFT1COL1=INDEX(YCARIN,'NFT1COL1')
+INDNFT1COL2=INDEX(YCARIN,'NFT1COL2')
+INDNFT1COL3=INDEX(YCARIN,'NFT1COL3')
+INDNFT1COL4=INDEX(YCARIN,'NFT1COL4')
+INDNFT1COL5=INDEX(YCARIN,'NFT1COL5')
+INDNFT1COL6=INDEX(YCARIN,'NFT1COL6')
+INDNFT1COL7=INDEX(YCARIN,'NFT1COL7')
+INDNFT1COL8=INDEX(YCARIN,'NFT1COL8')
+INDNFT1COL9=INDEX(YCARIN,'NFT1COL9')
+INDNFT1COL10=INDEX(YCARIN,'NFT1COL10')
+INDNFT1COL11=INDEX(YCARIN,'NFT1COL11')
+INDNFT1COL12=INDEX(YCARIN,'NFT1COL12')
+INDNFT1COL13=INDEX(YCARIN,'NFT1COL13')
+INDNFT1COL14=INDEX(YCARIN,'NFT1COL14')
+INDNFT1COL15=INDEX(YCARIN,'NFT1COL15')
+!
+INDXFT1LW1=INDEX(YCARIN,'XFT1LW1')
+INDXFT1LW2=INDEX(YCARIN,'XFT1LW2')
+INDXFT1LW3=INDEX(YCARIN,'XFT1LW3')
+INDXFT1LW4=INDEX(YCARIN,'XFT1LW4')
+INDXFT1LW5=INDEX(YCARIN,'XFT1LW5')
+INDXFT1LW6=INDEX(YCARIN,'XFT1LW6')
+INDXFT1LW7=INDEX(YCARIN,'XFT1LW7')
+INDXFT1LW8=INDEX(YCARIN,'XFT1LW8')
+INDXFT1LW9=INDEX(YCARIN,'XFT1LW9')
+INDXFT1LW10=INDEX(YCARIN,'XFT1LW10')
+INDXFT1LW11=INDEX(YCARIN,'XFT1LW11')
+INDXFT1LW12=INDEX(YCARIN,'XFT1LW12')
+INDXFT1LW13=INDEX(YCARIN,'XFT1LW13')
+INDXFT1LW14=INDEX(YCARIN,'XFT1LW14')
+INDXFT1LW15=INDEX(YCARIN,'XFT1LW15')
+!
+INDCFT1TIT1=INDEX(YCARIN,'CFT1TIT1')
+INDCFT1TIT2=INDEX(YCARIN,'CFT1TIT2')
+INDCFT1TIT3=INDEX(YCARIN,'CFT1TIT3')
+INDCFT1TIT4=INDEX(YCARIN,'CFT1TIT4')
+INDCFT1TIT5=INDEX(YCARIN,'CFT1TIT5')
+INDCFT1TIT6=INDEX(YCARIN,'CFT1TIT6')
+INDCFT1TIT7=INDEX(YCARIN,'CFT1TIT7')
+INDCFT1TIT8=INDEX(YCARIN,'CFT1TIT8')
+INDCFT1TIT9=INDEX(YCARIN,'CFT1TIT9')
+INDCFT1TIT10=INDEX(YCARIN,'CFT1TIT10')
+INDCFT1TIT11=INDEX(YCARIN,'CFT1TIT11')
+INDCFT1TIT12=INDEX(YCARIN,'CFT1TIT12')
+INDCFT1TIT13=INDEX(YCARIN,'CFT1TIT13')
+INDCFT1TIT14=INDEX(YCARIN,'CFT1TIT14')
+INDCFT1TIT15=INDEX(YCARIN,'CFT1TIT15')
+!
+INDCVARNPV1=INDEX(YCARIN,'CVARNPV1')
+INDCVARNPV2=INDEX(YCARIN,'CVARNPV2')
+INDCVARNPV3=INDEX(YCARIN,'CVARNPV3')
+INDCVARNPV4=INDEX(YCARIN,'CVARNPV4')
+INDCVARNPV5=INDEX(YCARIN,'CVARNPV5')
+INDCVARNPV6=INDEX(YCARIN,'CVARNPV6')
+INDCVARNPV7=INDEX(YCARIN,'CVARNPV7')
+INDCVARNPV8=INDEX(YCARIN,'CVARNPV8')
+INDCVARNPV9=INDEX(YCARIN,'CVARNPV9')
+INDCVARNPV10=INDEX(YCARIN,'CVARNPV10')
+INDCVARNPV11=INDEX(YCARIN,'CVARNPV11')
+INDCVARNPV12=INDEX(YCARIN,'CVARNPV12')
+INDCVARNPV13=INDEX(YCARIN,'CVARNPV13')
+INDCVARNPV14=INDEX(YCARIN,'CVARNPV14')
+INDCVARNPV15=INDEX(YCARIN,'CVARNPV15')
+!
+INDCVARNPH1=INDEX(YCARIN,'CVARNPH1')
+INDCVARNPH2=INDEX(YCARIN,'CVARNPH2')
+INDCVARNPH3=INDEX(YCARIN,'CVARNPH3')
+INDCVARNPH4=INDEX(YCARIN,'CVARNPH4')
+INDCVARNPH5=INDEX(YCARIN,'CVARNPH5')
+INDCVARNPH6=INDEX(YCARIN,'CVARNPH6')
+INDCVARNPH7=INDEX(YCARIN,'CVARNPH7')
+INDCVARNPH8=INDEX(YCARIN,'CVARNPH8')
+!
+INDNPHCOL1=INDEX(YCARIN,'NPHCOL1')
+INDNPHCOL2=INDEX(YCARIN,'NPHCOL2')
+INDNPHCOL3=INDEX(YCARIN,'NPHCOL3')
+INDNPHCOL4=INDEX(YCARIN,'NPHCOL4')
+INDNPHCOL5=INDEX(YCARIN,'NPHCOL5')
+INDNPHCOL6=INDEX(YCARIN,'NPHCOL6')
+INDNPHCOL7=INDEX(YCARIN,'NPHCOL7')
+INDNPHCOL8=INDEX(YCARIN,'NPHCOL8')
+!
+INDNPHSTY1=INDEX(YCARIN,'NPHSTY1')
+INDNPHSTY2=INDEX(YCARIN,'NPHSTY2')
+INDNPHSTY3=INDEX(YCARIN,'NPHSTY3')
+INDNPHSTY4=INDEX(YCARIN,'NPHSTY4')
+INDNPHSTY5=INDEX(YCARIN,'NPHSTY5')
+INDNPHSTY6=INDEX(YCARIN,'NPHSTY6')
+INDNPHSTY7=INDEX(YCARIN,'NPHSTY7')
+INDNPHSTY8=INDEX(YCARIN,'NPHSTY8')
+!*JD* Mars 2009
+!
+!G. TANGUY NOVEMBRE 2009
+INDL90TITYT=INDEX(YCARIN,'L90TITYT')
+INDL90TITYM=INDEX(YCARIN,'L90TITYM')
+INDL90TITYB=INDEX(YCARIN,'L90TITYB')
+!
+INDLPATCH=INDEX(YCARIN,'LPATCH')
+if(nverbia >0)then
+ print *,' ***caresolv AV CARMEMORY'
+endif
+!!!0701
+ INDPARTIEL=0
+ INDPARTIEL= &
+ INDIINF+INDISUP+INDJINF+INDJSUP+INDIDEBCOU+INDJDEBCOU+INDXIDEBCOU+ &
+ INDXTIMEMIN + INDXTIMEMAX + INDNSZLBX + INDNSZLBY + &
+ INDXJDEBCOU+INDNLANGLE+INDNLMAX+INDNIOFFD+INDNULBLL+INDNHI+INDNIMNMX &
+ +INDNFT1ITVXMJ+INDNFT1ITVXMN+INDNFT1ITVYMJ+INDNFT1ITVYMN &
+ +INDNFTITVXMJ+INDNFTITVXMN+INDNFTITVYMJ+INDNFTITVYMN + INDNSD &
+ +INDNCHITVXMJ+INDNCHITVXMN+INDNCHITVYMJ+INDNCHITVYMN &
+ +INDNCHPCITVXMJ+INDNCHPCITVXMN+INDNCHPCITVYMJ+INDNCHPCITVYMN &
+ +INDNCVITVXMJ+INDNCVITVXMN+INDNCVITVYMJ+INDNCVITVYMN &
+ +INDNPVITVXMJ+INDNPVITVXMN+INDNPVITVYMJ+INDNPVITVYMN &
+ +INDNXYITVXMJ+INDNXYITVXMN+INDNXYITVYMJ+INDNXYITVYMN &
+ +INDNMASKITVXMJ+INDNMASKITVXMN+INDNMASKITVYMJ+INDNMASKITVYMN &
+ +INDXDIAINT+INDLXY+INDLXZ+INDLISO+INDLMINMAX+INDLCOLAREA+INDATFILE &
+ +INDLINTERPTOP+ INDLCOLISONE + INDLCOLRSONE+ INDLCOLRS1ONE+INDLRADAR &
+ +INDLRADIST+ INDLRADRAY + INDLFTBAUTO + INDLFT1BAUTO+ INDLSPOT &
+ +INDLNOUVRS + INDLMYHEURX + INDNHEURXLBL + INDNHEURXGRAD &
+ +INDLCOLINE+INDLISOWHI+INDLCOLBR+INDLCOLAREASEL+INDLCOLINESEL+ &
+ INDLSPVALT + INDLSEGM + INDLPRESY + INDLSPSECT + INDLEGVECT + &
+ INDLVECTMNMX + INDLANIMK +INDLANIMT + INDLPRINT + INDLPRINTXY + &
+ INDLPOINTG + INDL2DBX + INDL2DBY + INDLXYO + INDLISOWHI2+INDLISOWHI3 + &
+ INDLTABCOLDEF+INDNIFDC+INDNIGRNC+INDXHMIN+INDXHMAX+INDXISOMIN+ &
+ INDXPMIN + INDXPMAX + INDXPINT + INDLSTREAM + INDLNOLABELX + INDLNOLABELY + &
+ INDLMNMXUSER + INDLCOLUSER + INDNDOT + INDNISKIP + INDLMNMXLOC + &
+ INDNISKIPVX + INDNISKIPVY + INDLTIMEUSER + INDLINTERPOLSTR +&
+ INDLULMVTMOLD + INDNIRS + INDNJRS + INDXIRS + INDXJRS + INDXSPVAL + &
+ INDXSPVALT + INDLPRDAT + INDNARSTR + INDNZSTR + &
+ INDXISOMAX+INDVISU+INDNOVISU+INDXSIZEL+INDNPROFILE+INDXPVMIN+ &
+ INDXAMX+INDXVHC+INDXVRL+INDXLATCAR+INDXLONCAR+ INDNVERBIA + &
+ INDXICAR + INDXJCAR + INDXLWPH1 + INDXLWPH2 + INDXLWPH3 + INDXLWPH4 + &
+ INDXLWPH5 + INDXLWPH6 + INDXLWPH7 + INDXLWPH8 + &
+ INDICOLNOM + INDICOLSYM + INDXSZTITT1 + INDXSZTITT2 +INDXSZTITT3 + &
+ INDXSZTITYT + INDXSZTITYM +INDXSZTITYB + &
+ INDNINDCOLUV + INDXVRLPH + INDXVHCPH + INDXSSP + INDXARLSTR + INDXLWSTR + &
+ INDXSZTITB1 + INDXSZTITB2 + INDXSZTITB3 + INDXSZTITVAR1 + &
+ INDXSZTITVAR2 + INDXSZTITVAR3 + INDXSZTITVAR4 + INDXSZTITVAR5 + &
+ INDXSZTITVAR6 + INDXSZTITVAR7 + INDXSZTITVAR8 + INDXPOSTITYT + &
+ INDXPOSTITYM + INDXPOSTITYB + INDXPOSTITT1 + &
+ INDXPOSTITT2 + INDXPOSTITT3 + INDXPOSTITB1 + INDXPOSTITB2 + &
+ INDXPOSTITB3 + INDXYPOSTITT1 + INDLCOLUSERUV + INDLNOLBLBAR + &
+ INDXYPOSTITT2 + INDXYPOSTITT3 + INDXYPOSTITYT + INDXYPOSTITYM + &
+ INDXYPOSTITYB + INDXYPOSTITB1 + INDXYPOSTITB2 + &
+ INDXYPOSTITB3 + INDXPOSTITVAR1 +INDXPOSTITVAR2 + INDXPOSTITVAR3 + INDXPOSTITVAR4
+! INDXYPOSTITB3 + INDXPOSTITVAR1 +INDXPOSTITVAR2 + INDXPOSTITVAR3 + INDXPOSTITVAR4 + &
+!!!0701
+ INDPARTIEL=INDPARTIEL + &
+ INDXPOSTITVAR5 + INDXPOSTITVAR6 + INDXPOSTITVAR7 + INDXPOSTITVAR8 + &
+ INDXYPOSTITVAR1 + INDXYPOSTITVAR2 + INDXYPOSTITVAR3 + INDXYPOSTITVAR4 + &
+ INDXYPOSTITVAR5 + INDXYPOSTITVAR6 + INDXYPOSTITVAR7 + INDXYPOSTITVAR8 + &
+ INDCSYMRAD1+INDCSYMRAD2+INDCSYMRAD3+INDCSYMRAD4+ &
+ INDXLATRAD1+INDXLATRAD2+INDXLATRAD3+INDXLATRAD4+ &
+ INDXLONRAD1+INDXLONRAD2+INDXLONRAD3+INDXLONRAD4+ &
+ INDXISOMIN_ + INDXISOMAX_ + INDXDIAINT_ + INDLABEL1 + INDXVLC + &
+ INDXPORTRAD1+INDXPORTRAD2+INDXPORTRAD3+INDXPORTRAD4+ &
+ INDXLWRAD1+INDXLWRAD2+INDXLWRAD3+INDXLWRAD4+ &
+ INDCNOMCAR + INDCSYMCAR + INDXPOSNOM + INDXSZNOM + INDXSZSYM + &
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!! pour les retrotrajectoires !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ INDNSZRTRAJ + INDLFMTRTRAJ + &
+ !!!!!!!!!!!!!!!!!!!!!
+ INDXPVMAX+INDXISOLEV+INDXFTMAX+INDXFTMIN+INDXPVKTMIN+INDXPVKTMAX+ &
+ INDXPARCOLUV + &
+ INDXFT_ADTIM1+ INDXFT_ADTIM2+INDXFT_ADTIM3 +INDXFT_ADTIM4 + &
+ INDXFT_ADTIM5 + INDXFT_ADTIM6 + INDXFT_ADTIM7 + INDXFT_ADTIM8 + &
+ INDXFT1_ADTIM1 + INDXFT1_ADTIM2 + INDXFT1_ADTIM3 + INDXFT1_ADTIM4 + &
+ INDXFT1_ADTIM5 + INDXFT1_ADTIM6 + INDXFT1_ADTIM7 + INDXFT1_ADTIM8 + &
+ INDXFT1MIN+INDXFT1MAX+INDXFT1MIN_+INDXFT1MAX_+INDXISOLEV_+ &
+ INDLVPTUSER + INDLVPTVUSER + INDLVPTPVUSER + INDLXABSC + INDLXMINTOP +&
+ INDXVPTL + INDXVPTR + INDXVPTB + INDXVPTT + INDLVPTXYUSER + &
+ INDXVPTVL + INDXVPTVR + INDXVPTVB + INDXVPTVT + INDLFACTIMP + &
+ INDXVPTPVL + INDXVPTPVR + INDXVPTPVB + INDXVPTPVT + INDLFMTAXEX + &
+ INDXVPTXYL + INDXVPTXYR + INDXVPTXYB + INDXVPTXYT + INDLFMTAXEY + &
+ INDLFACTAXEX + INDLFACTAXEY + INDLAXEXUSER + INDLAXEYUSER + &
+ INDXFACTAXEX + INDXFACTAXEY + INDXAXEXUSERD + INDXAXEXUSERF + &
+ INDXAXEYUSERD + INDXAXEYUSERF + INDLBLFT1SUP + &
+ INDXLWV + INDXLWDEF + INDXLWVDEF + INDLINVWB + INDLGEOG + INDLMASK3D + &
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+ INDXXPART+INDXYPART+INDXZPART+INDLTRAJ3D+INDLFLUX3D+INDLTRAJ_GROUP
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+ INDPARTIEL=INDPARTIEL + &
+ INDLINVPTIR + INDLDOMAIN + INDXLWFTALL + INDXLWSEGM + INDNSTYLINZEROPV + &
+ INDNDOMAINL + INDNDOMAINR + INDNDOMAINB + INDNDOMAINT + &
+ INDLMASK3D_XY + INDLMASK3D_XZ + INDLMASK3D_YZ + INDLXYZ00 + &
+ INDXLWPV1 + INDXLWPV2 + INDXLWPV3 + INDXLWPV4 + INDXLWPV5 + &
+ INDXLWPV6 + INDXLWPV7 + INDXLWPV8 + INDXLWTRACECV + INDXLWDOMAIN + &
+ INDXLWPV9 + INDXLWPV10 + &
+ INDXLWPV11 + INDXLWPV12 + INDXLWPV13 + INDXLWPV14 + INDXLWPV15 + &
+ INDXSTYLPV1 + INDXSTYLPV2 + INDXSTYLPV3 + INDXSTYLPV4 + INDXSTYLPV5 + &
+ INDXSTYLPV6 + INDXSTYLPV7 + INDXSTYLPV8 + &
+ INDXSTYLPV9 + INDXSTYLPV10 + &
+ INDXSTYLPV11 + INDXSTYLPV12 + INDXSTYLPV13 + INDXSTYLPV14 + INDXSTYLPV15 + &
+ INDLFT1STYLUSER + INDLFTSTYLUSER + INDLTITFTUSER + INDXLWCONT + &
+ INDLPHCOLUSER + INDLPHSTYUSER + INDL24H + &
+ INDXLW + INDXLW1 + INDXLW2 + INDXLW3 + INDXLW4 + INDLMARKER + INDLFTCLIP + &
+ INDLCOLZERO + INDNCOLZERO + INDLHACH1 + INDLHACH2 + INDLHACH3 + INDL3D + &
+ INDNCOLISONE1 + INDNCOLISONE2 + INDNCOLISONE3+INDNCOLISONE4+INDNCOLISONE5+ &
+ INDNCOLRS1ONE1+INDNCOLRS1ONE2+INDNCOLRS1ONE3+INDNCOLRS1ONE4+INDNCOLRS1ONE5+ &
+ INDNCOLRSONE + INDLHEURX + INDNCOLSEGM + &
+!!!0701
+ INDXISOREF + INDXISOREF_ + INDLSPOT
+! print *,' ***caresolv INDPARTIEL C ',INDPARTIEL
+!JD240209
+ INDPARTIEL=INDPARTIEL + &
+ INDLFT1LUSER+INDNFT1STY1+INDNFT1STY2+INDNFT1STY3+INDNFT1STY4+ &
+ INDNFT1STY5+INDNFT1STY6+INDNFT1STY7+INDNFT1STY8+INDNFT1STY9+ &
+ INDNFT1STY10+INDNFT1STY11+INDNFT1STY12+INDNFT1STY13+INDNFT1STY14+ &
+ INDNFT1STY15+INDNFT1COL1+INDNFT1COL2+INDNFT1COL3+INDNFT1COL4+INDNFT1COL5
+! print *,' ***caresolv INDPARTIEL CA ',INDPARTIEL
+ INDPARTIEL=INDPARTIEL + &
+ INDNFT1COL6+INDNFT1COL7+INDNFT1COL8+INDNFT1COL9+INDNFT1COL10+ &
+ INDNFT1COL11+INDNFT1COL12+INDNFT1COL13+INDNFT1COL14+INDNFT1COL15
+! print *,' ***caresolv INDPARTIEL CB ',INDPARTIEL
+ INDPARTIEL=INDPARTIEL + &
+ INDXFT1LW1+INDXFT1LW2+INDXFT1LW3+INDXFT1LW4+INDXFT1LW5+ &
+ INDXFT1LW6+INDXFT1LW7+INDXFT1LW8+INDXFT1LW9+INDXFT1LW10+ &
+ INDXFT1LW11+INDXFT1LW12+INDXFT1LW13+INDXFT1LW14+INDXFT1LW15
+! print *,' ***caresolv INDPARTIEL CC',INDPARTIEL
+ INDPARTIEL=INDPARTIEL + &
+ INDCFT1TIT1+INDCFT1TIT2+INDCFT1TIT3+INDCFT1TIT4+INDCFT1TIT5+ &
+ INDCFT1TIT6+INDCFT1TIT7+INDCFT1TIT8+INDCFT1TIT9+INDCFT1TIT10+ &
+ INDCFT1TIT11+INDCFT1TIT12+INDCFT1TIT13+INDCFT1TIT14+INDCFT1TIT15+ &
+ INDLVPTFT1USER+INDXVPTFT1L+INDXVPTFT1R+INDXVPTFT1B+INDXVPTFT1T + &
+ INDXSZVARNPVTOP + INDXSZVARNPVBOT + &
+ INDXPOSXVARNPV5BOT + INDXPOSYVARNPV5BOT + INDLINZEROPV + &
+ INDLVARNPVUSER + INDXPOSXVARNPV1TOP + INDXPOSYVARNPV1TOP +&
+ INDCVARNPV1+INDCVARNPV2+INDCVARNPV3+INDCVARNPV4+INDCVARNPV5+ &
+ INDCVARNPV6+INDCVARNPV7+INDCVARNPV8+INDCVARNPV9+INDCVARNPV10+ &
+ INDCVARNPV11+INDCVARNPV12+INDCVARNPV13+INDCVARNPV14+INDCVARNPV15+&
+ INDL90TITYT+INDL90TITYM+INDL90TITYB+&
+ INDLVARNPHUSER + INDCVARNPH1+INDCVARNPH2+INDCVARNPH3+INDCVARNPH4+&
+ INDCVARNPH5+ INDCVARNPH6+INDCVARNPH7+INDCVARNPH8+INDLPATCH
+! print *,' ***caresolv INDPARTIEL D ',INDPARTIEL
+!
+ IF(INDPARTIEL + &
+ INDNPHSTY1+INDNPHSTY2+INDNPHSTY3+INDNPHSTY4+ &
+ INDNPHSTY5+INDNPHSTY6+INDNPHSTY7+INDNPHSTY8+ &
+ INDNPHCOL1+INDNPHCOL2+INDNPHCOL3+INDNPHCOL4+ &
+ INDNPHCOL5+INDNPHCOL6+INDNPHCOL7+INDNPHCOL8+ &
+ INDLGREY + INDLXYNVARTOP + INDLXYSTYLTOP +&
+ INDLHACH4 + INDLHACHSEL + INDLBLUSER1 + INDLBLUSER2 + &
+ INDLBLUSER3 + INDLBLUSER4 + INDLINDSP + INDLOGNEP + INDLTABCOLDEF2+ &
+ INDXVARMIN +INDXVARMAX + INDXZTMIN + INDXZTMAX + INDLINDAX + INDLCHREEL+ &
+ INDXSZTITXL + INDXSZTITXM + INDXSZTITXR + INDXANGULVT + &
+ INDLDEFCV2 + INDLDEFCV2LL + INDLDEFCV2IND + &
+ INDXIDEBCV + INDXJDEBCV + INDXIFINCV + INDXJFINCV + &
+ INDXXL + INDXXH + INDXYL + INDXYH + INDXZL + INDXZH + &
+ INDXIDEBCVLL + INDXJDEBCVLL + INDXIFINCVLL + INDXJFINCVLL + &
+ INDLCONVG2MASS +&
+ INDNIDEBCV + INDNJDEBCV + INDNIFINCV + INDNJFINCV + INDLM5S3 + &
+ INDLSYMB + INDLSYMBTEXTG + INDLSTI + INDLTEXTIT +INDLTEXTG + INDLTRACECV +&
+ INDLCVZOOM + INDLVST + INDLDILW + INDLVSUPSCA + INDLXYWINCUR + &
+ INDL2CONT + INDNCOLUV1 + INDNCOLUV2 + INDNCOLUV3 + INDNCOLUV4+ INDNCOLUV5 +&
+ INDLCONT + INDLRELIEF +INDLCONV2XY + INDXPVMINT + INDXPVMAXT == 0)THEN
+ CALL CARMEMORY(YCARIN,1)
+ENDIF
+if(nverbia >0)then
+ print *,' ***caresolv INDPARTIEL ',INDPARTIEL
+ print *,' ***caresolv AP CARMEMORY'
+endif
+
+LCH =.TRUE.
+LCHXY=.FALSE.
+LCV =.FALSE.
+LCVXZ=.FALSE.
+LCVYZ=.FALSE.
+LPV =.FALSE.
+LPH =.FALSE.
+LPVT =.FALSE.
+LPXT =.FALSE.
+LPYT =.FALSE.
+LPVKT =.FALSE.
+LCN = .FALSE.
+LCNCUM = .FALSE.
+LCNSUM = .FALSE.
+LFT = .FALSE.
+LFT1 = .FALSE.
+L1K=.FALSE.
+LMINUS=.FALSE.
+LPLUS=.FALSE.
+LTK= .FALSE.
+LEV= .FALSE.
+LPR= .FALSE.
+LRS= .FALSE.
+LRS1= .FALSE.
+LPVKT1 =.FALSE.
+LZTPVKT1 =.FALSE.
+LMSKTOP=.FALSE.
+LSV3=.FALSE.
+LZT=.FALSE.
+LXT=.FALSE.
+LYT=.FALSE.
+LXYZ=.FALSE.
+LUMVMPV=.FALSE.
+LXYDIA=.FALSE.
+!LANIMK=.FALSE.
+!LANIMT=.FALSE.
+LSPLO=.FALSE.
+LSPO=.FALSE.
+LOSPLO=.FALSE.
+LPHALO=.FALSE.
+LPHAO=.FALSE.
+!LCONV2XY=.FALSE.
+if(nverbia > 0)then
+print *,' **caresolv LTK,LPR,LEV,LSV3 ',LTK,LPR,LEV,LSV3
+endif
+
+LSUPERDIA=.FALSE.
+NSUPERDIA=0
+CARSUP(:)(1:LEN(CARSUP))=' '
+LSUPER=.FALSE.
+NSUPER=0
+LARROVL=.FALSE.
+
+NBNDIA(:)=0
+NNDIA(:,:)=0
+LNDIALL(:)=.FALSE.
+NBPROCDIA(:)=0
+NPROCDIA(:,:)=0
+LPROCDIALL(:)=.FALSE.
+NBLVLKDIA(:,:)=0
+NLVLKDIA(:,:,:)=0
+LVLKDIALL(:,:)=.FALSE.
+NBLVLZDIA(:)=0
+XLVLZDIA(:,:)=0.
+NBTIMEDIA(:,:)=0
+NTIMEDIA(:,:,:)=0
+XTIMEDIA(:,:,:)=0.
+LTIMEDIALL(:,:)=.FALSE.
+NHISTORY(:)=0
+
+NBPM=1
+NBPMT=0
+NUMPM(:)=0
+NGRIDIAM=0
+
+NOPE(:)=0
+NOPEL=0
+XCONSTANTE(:)=0.
+CFACT(:)(1:LEN(CFACT))=' '
+if(nverbia >0)then
+ print *,' ***caresolv AP INIT Logiques'
+endif
+! Juillet 2001
+NMULTDIV(:)=0
+CMULTDIV(:)(1:LEN(CMULTDIV))=' '
+! Juillet 2001
+
+IF(INDIINF /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDIINF,NIINF)
+ IF(NIINF /= 999999999)THEN
+ PRINT *,' NIINF FOURNI ',NIINF
+ ENDIF
+ENDIF
+IF(INDJINF /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDJINF,NJINF)
+ IF(NJINF /= 999999999)THEN
+ PRINT *,' NJINF FOURNI ',NJINF
+ ENDIF
+ENDIF
+IF(INDNSZLBX /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNSZLBX,NSZLBX)
+ PRINT *,' NSZLBX FOURNI ',NSZLBX
+ENDIF
+IF(INDNSZLBY /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNSZLBY,NSZLBY)
+ PRINT *,' NSZLBY FOURNI ',NSZLBY
+ENDIF
+if(nverbia >5)then
+ print *,' caresolv AV RESOLVI(INDISUP)'
+endif
+IF(INDISUP /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDISUP,NISUP)
+ IF(NISUP /= 999999999)THEN
+ PRINT *,' NISUP FOURNI ',NISUP
+ ENDIF
+ENDIF
+IF(INDJSUP /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDJSUP,NJSUP)
+ IF(NJSUP /= 999999999)THEN
+ PRINT *,' NJSUP FOURNI ',NJSUP
+ ENDIF
+ENDIF
+IF(INDIDEBCOU /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDIDEBCOU,NIDEBCOU)
+ IF(NIDEBCOU /= 999999999)THEN
+ PRINT *,' NIDEBCOU FOURNI ',NIDEBCOU
+ ENDIF
+ENDIF
+IF(INDJDEBCOU /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDJDEBCOU,NJDEBCOU)
+ IF(NJDEBCOU /= 999999999)THEN
+ PRINT *,' NJDEBCOU FOURNI ',NJDEBCOU
+ ENDIF
+ENDIF
+IF(INDNIDEBCV /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNIDEBCV,NIDEBCV)
+ print *,' VALEUR NIDEBCV FOURNIE : ',NIDEBCV
+ENDIF
+IF(INDNJDEBCV /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNJDEBCV,NJDEBCV)
+ print *,' VALEUR NJDEBCV FOURNIE : ',NJDEBCV
+ENDIF
+IF(INDNHEURXLBL /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNHEURXLBL,NHEURXLBL)
+ print *,' VALEUR NHEURXLBL FOURNIE : ',NHEURXLBL
+ENDIF
+IF(INDNHEURXGRAD /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNHEURXGRAD,NHEURXGRAD)
+ print *,' VALEUR NHEURXGRAD FOURNIE : ',NHEURXGRAD
+ENDIF
+IF(INDNIFINCV /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNIFINCV,NIFINCV)
+ print *,' VALEUR NIFINCV FOURNIE : ',NIFINCV
+ENDIF
+if(nverbia >5)then
+ print *,' caresolv AV RESOLVI(INDNJFINCV)'
+endif
+IF(INDNJFINCV /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNJFINCV,NJFINCV)
+ print *,' VALEUR NJFINCV FOURNIE : ',NJFINCV
+ENDIF
+IF(INDXFACTAXEX /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFACTAXEX,XFACTAXEX)
+ print *,' VALEUR XFACTAXEX FOURNIE : ',XFACTAXEX
+ENDIF
+IF(INDXFACTAXEY /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFACTAXEY,XFACTAXEY)
+ print *,' VALEUR XFACTAXEY FOURNIE : ',XFACTAXEY
+ENDIF
+IF(INDXAXEXUSERD /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXAXEXUSERD,XAXEXUSERD)
+ print *,' VALEUR XAXEXUSERD FOURNIE : ',XAXEXUSERD
+ENDIF
+IF(INDXAXEYUSERD /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXAXEYUSERD,XAXEYUSERD)
+ print *,' VALEUR XAXEYUSERD FOURNIE : ',XAXEYUSERD
+ENDIF
+IF(INDXAXEXUSERF /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXAXEXUSERF,XAXEXUSERF)
+ print *,' VALEUR XAXEXUSERF FOURNIE : ',XAXEXUSERF
+ENDIF
+IF(INDXAXEYUSERF /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXAXEYUSERF,XAXEYUSERF)
+ print *,' VALEUR XAXEYUSERF FOURNIE : ',XAXEYUSERF
+ENDIF
+IF(INDXANGULVT /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXANGULVT,XANGULVT)
+ print *,' VALEUR XANGULVT FOURNIE : ',XANGULVT
+ENDIF
+if(nverbia >5)then
+ print *,' caresolv AV RESOLVX(INDXIDEBCV)',INDXIDEBCV
+endif
+IF(INDXSSP /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSSP,XSSP)
+ print *,' VALEUR XSSP FOURNIE : ',XSSP
+ENDIF
+IF(INDXARLSTR /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXARLSTR,XARLSTR)
+ print *,' VALEUR XARLSTR FOURNIE : ',XARLSTR
+ENDIF
+IF(INDXLWSTR /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWSTR,XLWSTR)
+ print *,' VALEUR XLWSTR FOURNIE : ',XLWSTR
+ENDIF
+IF(INDXIDEBCV /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXIDEBCV,XIDEBCV)
+ print *,' VALEUR XIDEBCV FOURNIE : ',XIDEBCV
+ENDIF
+if(nverbia >5)then
+ print *,' caresolv AV RESOLVX(INDXJDEBCV)',INDXJDEBCV
+endif
+IF(INDXJDEBCV /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXJDEBCV,XJDEBCV)
+ print *,' VALEUR XJDEBCV FOURNIE : ',XJDEBCV
+ENDIF
+if(nverbia >5)then
+ print *,' caresolv AV RESOLVX(INDXIDEBCVLL)',INDXIDEBCVLL
+endif
+IF(INDXIDEBCVLL /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXIDEBCVLL,XIDEBCVLL)
+ print *,' VALEUR XIDEBCVLL FOURNIE : ',XIDEBCVLL
+ENDIF
+IF(INDXJDEBCVLL /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXJDEBCVLL,XJDEBCVLL)
+ print *,' VALEUR XJDEBCVLL FOURNIE : ',XJDEBCVLL
+ENDIF
+IF(INDXIFINCV /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXIFINCV,XIFINCV)
+ print *,' VALEUR XIFINCV FOURNIE : ',XIFINCV
+ENDIF
+IF(INDXJFINCV /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXJFINCV,XJFINCV)
+ print *,' VALEUR XJFINCV FOURNIE : ',XJFINCV
+ENDIF
+IF(INDXIFINCVLL /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXIFINCVLL,XIFINCVLL)
+ print *,' VALEUR XIFINCVLL FOURNIE : ',XIFINCVLL
+ENDIF
+IF(INDXJFINCVLL /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXJFINCVLL,XJFINCVLL)
+ print *,' VALEUR XJFINCVLL FOURNIE : ',XJFINCVLL
+ENDIF
+IF(INDXTIMEMIN /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXTIMEMIN,XTIMEMIN)
+ print *,' VALEUR XTIMEMIN FOURNIE : ',XTIMEMIN
+ENDIF
+IF(INDXTIMEMAX /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXTIMEMAX,XTIMEMAX)
+ print *,' VALEUR XTIMEMAX FOURNIE : ',XTIMEMAX
+ENDIF
+IF(INDXIDEBCOU /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXIDEBCOU,XIDEBCOU)
+ print *,' VALEUR XIDEBCOU FOURNIE : ',XIDEBCOU
+ENDIF
+IF(INDXJDEBCOU /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXJDEBCOU,XJDEBCOU)
+ print *,' VALEUR XJDEBCOU FOURNIE : ',XJDEBCOU
+ENDIF
+IF(INDXPMIN /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPMIN,XPMIN)
+ print *,' VALEUR XPMIN FOURNIE : ',XPMIN
+ENDIF
+IF(INDXPMAX /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPMAX,XPMAX)
+ print *,' VALEUR XPMAX FOURNIE : ',XPMAX
+ENDIF
+IF(INDXPINT /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPINT,XPINT)
+ print *,' VALEUR XPINT FOURNIE : ',XPINT
+ENDIF
+IF(INDXHMIN /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXHMIN,XHMIN)
+ print *,' VALEUR XHMIN FOURNIE : ',XHMIN
+ENDIF
+IF(INDXHMAX /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXHMAX,XHMAX)
+ print *,' VALEUR XHMAX FOURNIE : ',XHMAX
+ENDIF
+IF(INDXLATRAD1 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLATRAD1,XLATRAD1)
+ print *,' VALEUR XLATRAD1 FOURNIE : ',XLATRAD1
+ENDIF
+IF(INDXLATRAD2 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLATRAD2,XLATRAD2)
+ print *,' VALEUR XLATRAD2 FOURNIE : ',XLATRAD2
+ENDIF
+IF(INDXLATRAD3 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLATRAD3,XLATRAD3)
+ print *,' VALEUR XLATRAD3 FOURNIE : ',XLATRAD3
+ENDIF
+IF(INDXLATRAD4 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLATRAD4,XLATRAD4)
+ print *,' VALEUR XLATRAD4 FOURNIE : ',XLATRAD4
+ENDIF
+IF(INDXLONRAD1 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLONRAD1,XLONRAD1)
+ print *,' VALEUR XLONRAD1 FOURNIE : ',XLONRAD1
+ENDIF
+IF(INDXLONRAD2 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLONRAD2,XLONRAD2)
+ print *,' VALEUR XLONRAD2 FOURNIE : ',XLONRAD2
+ENDIF
+IF(INDXLONRAD3 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLONRAD3,XLONRAD3)
+ print *,' VALEUR XLONRAD3 FOURNIE : ',XLONRAD3
+ENDIF
+IF(INDXLONRAD4 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLONRAD4,XLONRAD4)
+ print *,' VALEUR XLONRAD4 FOURNIE : ',XLONRAD4
+ENDIF
+IF(INDXSPVAL /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSPVAL,XSPVAL)
+ print *,' VALEUR XSPVAL FOURNIE : ',XSPVAL
+ENDIF
+IF(INDXSPVALT /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSPVALT,XSPVALT)
+ print *,' VALEUR XSPVALT FOURNIE : ',XSPVALT
+ENDIF
+IF(INDXISOMIN /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXISOMIN,XISOMIN)
+ print *,' VALEUR XISOMIN FOURNIE : ',XISOMIN
+ENDIF
+IF(INDXISOMAX /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXISOMAX,XISOMAX)
+ print *,' VALEUR XISOMAX FOURNIE : ',XISOMAX
+ENDIF
+IF(INDXISOMIN_ /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXISOMIN_,ZISO)
+ CALL LOADMNMXINT_ISO(YCARIN(1:LEN_TRIM(YCARIN)),INDXISOMIN_,ZISO,1)
+ print *,' VALEUR XISOMIN_ FOURNIE : ',ZISO
+ENDIF
+IF(INDXISOMAX_ /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXISOMAX_,ZISO)
+ CALL LOADMNMXINT_ISO(YCARIN(1:LEN_TRIM(YCARIN)),INDXISOMAX_,ZISO,2)
+ print *,' VALEUR XISOMAX_ FOURNIE : ',ZISO
+ENDIF
+IF(INDXDIAINT /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXDIAINT,XDIAINT)
+ print *,' VALEUR XDIAINT FOURNIE : ',XDIAINT
+ENDIF
+IF(INDXDIAINT_ /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXDIAINT_,ZISO)
+ CALL LOADMNMXINT_ISO(YCARIN(1:LEN_TRIM(YCARIN)),INDXDIAINT_,ZISO,3)
+ print *,' VALEUR XDIAINT_ FOURNIE : ',ZISO
+ENDIF
+IF(INDXISOREF /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXISOREF,XISOREF)
+ print *,' VALEUR XISOREF FOURNIE : ',XISOREF
+ENDIF
+IF(INDXISOREF_ /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXISOREF_,ZISO)
+ CALL LOADMNMXINT_ISO(YCARIN(1:LEN_TRIM(YCARIN)),INDXISOREF_,ZISO,4)
+ print *,' VALEUR XISOREF_ FOURNIE : ',ZISO
+ENDIF
+IF(INDNLANGLE /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNLANGLE,NLANGLE)
+ IF(NLANGLE /= 999999999)THEN
+ PRINT *,' NLANGLE FOURNI ',NLANGLE
+ ENDIF
+ENDIF
+IF(INDNLMAX /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNLMAX,NLMAX)
+ IF(NLMAX /= 999999999)THEN
+ PRINT *,' NLMAX FOURNI ',NLMAX
+ ENDIF
+ENDIF
+IF(INDNZSTR /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNZSTR,NZSTR)
+ IF(NZSTR /= 999999999)THEN
+ PRINT *,' NZSTR FOURNI ',NZSTR
+ ENDIF
+ENDIF
+IF(INDNARSTR /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNARSTR,NARSTR)
+ IF(NARSTR /= 999999999)THEN
+ PRINT *,' NARSTR FOURNI ',NARSTR
+ ENDIF
+ENDIF
+IF(INDNIOFFD /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNIOFFD,NIOFFD)
+ IF(NIOFFD /= 999999999)THEN
+ PRINT *,' NIOFFD FOURNI ',NIOFFD
+ ENDIF
+ENDIF
+IF(INDNSD /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNSD,NSD)
+ IF(NSD /= 999999999)THEN
+ PRINT *,' NSD FOURNI ',NSD
+ ENDIF
+ENDIF
+!*JD* Mars 2009
+IF(INDNSTYLINZEROPV /=0)THEN
+ if(nverbia >0)then
+ print *,' **caresolv INDNSTYLINZEROPV,YCARIN ',INDNSTYLINZEROPV,YCARIN(1:LEN_TRIM(YCARIN))
+ endif
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNSTYLINZEROPV,NSTYLINZEROPV)
+ print *,' VALEUR NSTYLINZEROPV FOURNIE : ',NSTYLINZEROPV
+ENDIF
+!*JD* Mars 2009
+IF(INDNULBLL /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNULBLL,NULBLL)
+ IF(NULBLL /= 999999999)THEN
+ PRINT *,' NULBLL FOURNI ',NULBLL
+ ENDIF
+ENDIF
+IF(INDNDOT /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNDOT,NDOT)
+ IF(NDOT /= 999999999)THEN
+ PRINT *,' NDOT FOURNI ',NDOT
+ ENDIF
+ENDIF
+IF(INDNISKIP /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNISKIP,NISKIP)
+ IF(NISKIP /= 999999999)THEN
+ PRINT *,' NISKIP FOURNI ',NISKIP
+ ENDIF
+ENDIF
+IF(INDNCOLSEGM /= 0)THEN
+ CALL RESOLVIARRAY(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLSEGM,NCOLSEGMS,NCOLSEGM)
+ PRINT *,' NCOLSEGMS FOURNI ',NCOLSEGMS(1:NCOLSEGM)
+ DO J=NCOLSEGM+1,SIZE(NCOLSEGMS)
+ NCOLSEGMS(J)=1
+ ENDDO
+ if(nverbia > 0)THEN
+ print *,' ** NCOLSEGMS ',NCOLSEGMS
+ endif
+ENDIF
+!IF(INDNCOLSEGM /= 0)THEN
+! CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLSEGM,NCOLSEGM)
+! PRINT *,' NCOLSEGM FOURNI ',NCOLSEGM
+!ENDIF
+IF(INDNISKIPVY /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNISKIPVY,NISKIPVY)
+ IF(NISKIPVY /= 999999999)THEN
+ PRINT *,' NISKIPVY FOURNI ',NISKIPVY
+ ENDIF
+ENDIF
+IF(INDNISKIPVX /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNISKIPVX,NISKIPVX)
+ IF(NISKIPVX /= 999999999)THEN
+ PRINT *,' NISKIPVX FOURNI ',NISKIPVX
+ ENDIF
+ENDIF
+IF(INDNHI /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNHI,NHI)
+ IF(NHI /= 999999999)THEN
+ PRINT *,' NHI FOURNI ',NHI
+ ENDIF
+ENDIF
+IF(INDNIMNMX /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNIMNMX,NIMNMX)
+ IF(NIMNMX /= 999999999)THEN
+ PRINT *,' NIMNMX FOURNI ',NIMNMX
+ ENDIF
+ENDIF
+IF(INDNFT1ITVXMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1ITVXMJ,NFT1ITVXMJ)
+ IF(NFT1ITVXMJ /= 999999999)THEN
+ PRINT *,' NFT1ITVXMJ FOURNI ',NFT1ITVXMJ
+ ENDIF
+ENDIF
+IF(INDNFT1ITVXMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1ITVXMN,NFT1ITVXMN)
+ IF(NFT1ITVXMN /= 999999999)THEN
+ PRINT *,' NFT1ITVXMN FOURNI ',NFT1ITVXMN
+ ENDIF
+ENDIF
+IF(INDNFT1ITVYMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1ITVYMJ,NFT1ITVYMJ)
+ IF(NFT1ITVYMJ /= 999999999)THEN
+ PRINT *,' NFT1ITVYMJ FOURNI ',NFT1ITVYMJ
+ ENDIF
+ENDIF
+IF(INDNFT1ITVYMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1ITVYMN,NFT1ITVYMN)
+ IF(NFT1ITVYMN /= 999999999)THEN
+ PRINT *,' NFT1ITVYMN FOURNI ',NFT1ITVYMN
+ ENDIF
+ENDIF
+IF(INDNFTITVXMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFTITVXMJ,NFTITVXMJ)
+ IF(NFTITVXMJ /= 999999999)THEN
+ PRINT *,' NFTITVXMJ FOURNI ',NFTITVXMJ
+ ENDIF
+ENDIF
+IF(INDNFTITVXMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFTITVXMN,NFTITVXMN)
+ IF(NFTITVXMN /= 999999999)THEN
+ PRINT *,' NFTITVXMN FOURNI ',NFTITVXMN
+ ENDIF
+ENDIF
+IF(INDNFTITVYMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFTITVYMJ,NFTITVYMJ)
+ IF(NFTITVYMJ /= 999999999)THEN
+ PRINT *,' NFTITVYMJ FOURNI ',NFTITVYMJ
+ ENDIF
+ENDIF
+IF(INDNFTITVYMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFTITVYMN,NFTITVYMN)
+ IF(NFTITVYMN /= 999999999)THEN
+ PRINT *,' NFTITVYMN FOURNI ',NFTITVYMN
+ ENDIF
+ENDIF
+IF(INDNCHITVXMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCHITVXMJ,NCHITVXMJ)
+ IF(NCHITVXMJ /= 999999999)THEN
+ PRINT *,' NCHITVXMJ FOURNI ',NCHITVXMJ
+ ENDIF
+ENDIF
+IF(INDNCHITVXMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCHITVXMN,NCHITVXMN)
+ IF(NCHITVXMN /= 999999999)THEN
+ PRINT *,' NCHITVXMN FOURNI ',NCHITVXMN
+ ENDIF
+ENDIF
+IF(INDNCHITVYMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCHITVYMJ,NCHITVYMJ)
+ IF(NCHITVYMJ /= 999999999)THEN
+ PRINT *,' NCHITVYMJ FOURNI ',NCHITVYMJ
+ ENDIF
+ENDIF
+IF(INDNCHITVYMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCHITVYMN,NCHITVYMN)
+ IF(NCHITVYMN /= 999999999)THEN
+ PRINT *,' NCHITVYMN FOURNI ',NCHITVYMN
+ ENDIF
+ENDIF
+IF(INDNCHPCITVXMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCHPCITVXMJ,NCHPCITVXMJ)
+ IF(NCHPCITVXMJ /= 999999999)THEN
+ PRINT *,' NCHPCITVXMJ FOURNI ',NCHPCITVXMJ
+ ENDIF
+ENDIF
+IF(INDNCHPCITVXMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCHPCITVXMN,NCHPCITVXMN)
+ IF(NCHPCITVXMN /= 999999999)THEN
+ PRINT *,' NCHPCITVXMN FOURNI ',NCHPCITVXMN
+ ENDIF
+ENDIF
+IF(INDNCHPCITVYMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCHPCITVYMJ,NCHPCITVYMJ)
+ IF(NCHPCITVYMJ /= 999999999)THEN
+ PRINT *,' NCHPCITVYMJ FOURNI ',NCHPCITVYMJ
+ ENDIF
+ENDIF
+IF(INDNCHPCITVYMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCHPCITVYMN,NCHPCITVYMN)
+ IF(NCHPCITVYMN /= 999999999)THEN
+ PRINT *,' NCHPCITVYMN FOURNI ',NCHPCITVYMN
+ ENDIF
+ENDIF
+IF(INDNCVITVXMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCVITVXMJ,NCVITVXMJ)
+ IF(NCVITVXMJ /= 999999999)THEN
+ PRINT *,' NCVITVXMJ FOURNI ',NCVITVXMJ
+ ENDIF
+ENDIF
+IF(INDNCVITVXMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCVITVXMN,NCVITVXMN)
+ IF(NCVITVXMN /= 999999999)THEN
+ PRINT *,' NCVITVXMN FOURNI ',NCVITVXMN
+ ENDIF
+ENDIF
+IF(INDNCVITVYMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCVITVYMJ,NCVITVYMJ)
+ IF(NCVITVYMJ /= 999999999)THEN
+ PRINT *,' NCVITVYMJ FOURNI ',NCVITVYMJ
+ ENDIF
+ENDIF
+IF(INDNCVITVYMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCVITVYMN,NCVITVYMN)
+ IF(NCVITVYMN /= 999999999)THEN
+ PRINT *,' NCVITVYMN FOURNI ',NCVITVYMN
+ ENDIF
+ENDIF
+IF(INDNPVITVXMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPVITVXMJ,NPVITVXMJ)
+ IF(NPVITVXMJ /= 999999999)THEN
+ PRINT *,' NPVITVXMJ FOURNI ',NPVITVXMJ
+ ENDIF
+ENDIF
+IF(INDNPVITVXMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPVITVXMN,NPVITVXMN)
+ IF(NPVITVXMN /= 999999999)THEN
+ PRINT *,' NPVITVXMN FOURNI ',NPVITVXMN
+ ENDIF
+ENDIF
+IF(INDNPVITVYMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPVITVYMJ,NPVITVYMJ)
+ IF(NPVITVYMJ /= 999999999)THEN
+ PRINT *,' NPVITVYMJ FOURNI ',NPVITVYMJ
+ ENDIF
+ENDIF
+IF(INDNPVITVYMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPVITVYMN,NPVITVYMN)
+ IF(NPVITVYMN /= 999999999)THEN
+ PRINT *,' NPVITVYMN FOURNI ',NPVITVYMN
+ ENDIF
+ENDIF
+IF(INDNXYITVXMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNXYITVXMJ,NXYITVXMJ)
+ IF(NXYITVXMJ /= 999999999)THEN
+ PRINT *,' NXYITVXMJ FOURNI ',NXYITVXMJ
+ ENDIF
+ENDIF
+IF(INDNXYITVXMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNXYITVXMN,NXYITVXMN)
+ IF(NXYITVXMN /= 999999999)THEN
+ PRINT *,' NXYITVXMN FOURNI ',NXYITVXMN
+ ENDIF
+ENDIF
+IF(INDNXYITVYMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNXYITVYMJ,NXYITVYMJ)
+ IF(NXYITVYMJ /= 999999999)THEN
+ PRINT *,' NXYITVYMJ FOURNI ',NXYITVYMJ
+ ENDIF
+ENDIF
+IF(INDNXYITVYMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNXYITVYMN,NXYITVYMN)
+ IF(NXYITVYMN /= 999999999)THEN
+ PRINT *,' NXYITVYMN FOURNI ',NXYITVYMN
+ ENDIF
+ENDIF
+IF(INDNMASKITVXMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNMASKITVXMJ,NMASKITVXMJ)
+ IF(NMASKITVXMJ /= 999999999)THEN
+ PRINT *,' NMASKITVXMJ FOURNI ',NMASKITVXMJ
+ ENDIF
+ENDIF
+IF(INDNMASKITVXMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNMASKITVXMN,NMASKITVXMN)
+ IF(NMASKITVXMN /= 999999999)THEN
+ PRINT *,' NMASKITVXMN FOURNI ',NMASKITVXMN
+ ENDIF
+ENDIF
+IF(INDNMASKITVYMJ /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNMASKITVYMJ,NMASKITVYMJ)
+ IF(NMASKITVYMJ /= 999999999)THEN
+ PRINT *,' NMASKITVYMJ FOURNI ',NMASKITVYMJ
+ ENDIF
+ENDIF
+IF(INDNMASKITVYMN /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNMASKITVYMN,NMASKITVYMN)
+ IF(NMASKITVYMN /= 999999999)THEN
+ PRINT *,' NMASKITVYMN FOURNI ',NMASKITVYMN
+ ENDIF
+ENDIF
+!!!!!!!!!!!
+IF(INDLINZEROPV /= 0)THEN
+ if(nverbia >0)then
+ print *,' ++caresolv AV RESOLVL(INDLINZEROPV ',INDLINZEROPV
+ endif
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLINZEROPV,LINZEROPV)
+ENDIF
+IF(INDLVARNPVUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLVARNPVUSER,LVARNPVUSER)
+ENDIF
+IF(INDLVARNPHUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLVARNPHUSER,LVARNPHUSER)
+ENDIF
+
+IF(INDLVPTFT1USER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLVPTFT1USER,LVPTFT1USER)
+ENDIF
+!!!!!!!!!!!
+IF(INDLM5S3 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLM5S3,LM5S3)
+ENDIF
+IF(INDLCVZOOM /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCVZOOM,LCVZOOM)
+ENDIF
+IF(INDLVST /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLVST,LVST)
+ENDIF
+IF(INDLDILW /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLDILW,LDILW)
+ENDIF
+IF(INDLXYNVARTOP /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLXYNVARTOP,LXYNVARTOP)
+ENDIF
+IF(INDLXYSTYLTOP /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLXYSTYLTOP,LXYSTYLTOP)
+ENDIF
+IF(INDLXYWINCUR /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLXYWINCUR,LXYWINCUR)
+ENDIF
+IF(INDLVSUPSCA /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLVSUPSCA,LVSUPSCA)
+ENDIF
+IF(INDLSYMB /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLSYMB,LSYMB)
+ENDIF
+IF(INDLSYMBTEXTG /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLSYMBTEXTG,LSYMBTEXTG)
+ENDIF
+IF(INDLTEXTG /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLTEXTG,LTEXTG)
+ENDIF
+IF(INDLSTI /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLSTI,LSTI)
+ENDIF
+IF(INDLTEXTIT /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLTEXTIT,LTEXTIT)
+ENDIF
+IF(INDLTRACECV /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLTRACECV,LTRACECV)
+ENDIF
+IF(INDLSEGM /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLSEGM,LSEGM)
+ENDIF
+IF(INDLXY /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLXY,LXY)
+ENDIF
+IF(INDLXZ /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLXZ,LXZ)
+ENDIF
+IF(INDLISO /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLISO,LISO)
+ENDIF
+IF(INDLANIMK /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLANIMK,LANIMK)
+ENDIF
+IF(INDLANIMT /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLANIMT,LANIMT)
+ENDIF
+IF(INDLMINMAX /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLMINMAX,LMINMAX)
+ENDIF
+IF(INDATFILE /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDATFILE,LDATFILE)
+ENDIF
+IF(INDLINTERPTOP /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLINTERPTOP,LINTERPTOP)
+ENDIF
+IF(INDLRADAR /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLRADAR,LRADAR)
+ENDIF
+IF(INDLRADRAY /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLRADRAY,LRADRAY)
+ENDIF
+IF(INDLRADIST /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLRADIST,LRADIST)
+ENDIF
+IF(INDLFTBAUTO /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFTBAUTO,LFTBAUTO)
+ENDIF
+IF(INDLFT1BAUTO /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFT1BAUTO,LFT1BAUTO)
+ENDIF
+IF(INDLCOLAREA /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCOLAREA,LCOLAREA)
+! IF(.NOT.LCOLAREA)CALL TABCOL_FORDIACHRO
+ENDIF
+IF(INDLEGVECT /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLEGVECT,LEGVECT)
+ENDIF
+IF(INDLSTREAM /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLSTREAM,LSTREAM)
+ENDIF
+IF(INDLINTERPOLSTR /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLINTERPOLSTR,LINTERPOLSTR)
+ENDIF
+IF(INDLNOLBLBAR /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLNOLBLBAR,LNOLBLBAR)
+ENDIF
+IF(INDLNOLABELX /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLNOLABELX,LNOLABELX)
+ENDIF
+IF(INDLNOLABELY /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLNOLABELY,LNOLABELY)
+ENDIF
+IF(INDLPRESY /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLPRESY,LPRESY)
+ENDIF
+IF(INDLSPSECT /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLSPSECT,LSPSECT)
+ENDIF
+IF(INDLSPVALT /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLSPVALT,LSPVALT)
+ENDIF
+IF(INDLXABSC /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLXABSC,LXABSC)
+ENDIF
+IF(INDLTITFTUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLTITFTUSER,LTITFTUSER)
+ENDIF
+IF(INDLPHCOLUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLPHCOLUSER,LPHCOLUSER)
+ENDIF
+IF(INDLPHSTYUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLPHSTYUSER,LPHSTYUSER)
+ENDIF
+IF(INDLXMINTOP /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLXMINTOP,LXMINTOP)
+ENDIF
+IF(INDLABEL1 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLABEL1,LABEL1)
+ENDIF
+IF(INDLDEFCV2 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLDEFCV2,LDEFCV2)
+ IF(LDEFCV2)THEN
+ LDEFCV2LL=.FALSE.
+ LDEFCV2IND=.FALSE.
+ ENDIF
+ENDIF
+IF(INDLDEFCV2LL /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLDEFCV2LL,LDEFCV2LL)
+ IF(LDEFCV2LL)THEN
+ LDEFCV2=.FALSE.
+ LDEFCV2IND=.FALSE.
+ ENDIF
+ENDIF
+IF(INDLDEFCV2IND /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLDEFCV2IND,LDEFCV2IND)
+ IF(LDEFCV2IND)THEN
+ LDEFCV2=.FALSE.
+ LDEFCV2LL=.FALSE.
+ ENDIF
+ENDIF
+! NOV 2009 G. TANGUY
+IF(INDL90TITYT /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDL90TITYT,L90TITYT)
+ENDIF
+IF(INDL90TITYM /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDL90TITYM,L90TITYM)
+ENDIF
+IF(INDL90TITYB /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDL90TITYB,L90TITYB)
+ENDIF
+IF(INDLPATCH /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLPATCH,LPATCH)
+ENDIF
+
+!!! NOV 2009
+IF(NVERBIA > 0)THEN
+print *,' CARESOLV LDEFCV2,LDEFCV2LL,LDEFCV2IND,LDEFCV2CC ',LDEFCV2,LDEFCV2LL,LDEFCV2IND,LDEFCV2CC
+ENDIF
+IF(LDEFCV2 .OR. LDEFCV2LL .OR. LDEFCV2IND)THEN
+ LDEFCV2CC=.TRUE.
+ELSE
+ LDEFCV2CC=.FALSE.
+ENDIF
+IF(INDLBLUSER1 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLBLUSER1,LBLUSER1)
+ IF(LBLUSER1)THEN
+ IF(ALLOCATED(XLBLUSER1))THEN
+ DEALLOCATE(XLBLUSER1)
+ ENDIF
+ PRINT *,'Indiquez le nombre de isolignes à labeller'
+ READ(5,*)NLBL1
+ YCAR80(1:80)=' '
+ ! WRITE(YCAR80,*)NLBL1
+ ! YCAR80=ADJUSTL(ADJUSTR(YCAR80))
+ !WRITE(NDIR,*)YCAR80
+ CALL WRITEDIR(NDIR,NLBL1)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ YCAR80(1:80)=' '
+ ALLOCATE(XLBLUSER1(NLBL1))
+ PRINT *,'Indiquez les ',NLBL1,' valeurs'
+ READ(5,*)XLBLUSER1
+ !WRITE(YCAR80,*)XLBLUSER1(1:NLBL1)
+ !YCAR80=ADJUSTL(ADJUSTR(YCAR80))
+ !WRITE(NDIR,*)YCAR80
+ CALL WRITEDIR(NDIR,XLBLUSER1(1:NLBL1))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ENDIF
+ENDIF
+IF(INDLBLUSER2 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLBLUSER2,LBLUSER2)
+ IF(LBLUSER2)THEN
+ IF(ALLOCATED(XLBLUSER2))THEN
+ DEALLOCATE(XLBLUSER2)
+ ENDIF
+ PRINT *,'Indiquez le nombre de isolignes à labeller'
+ READ(5,*)NLBL2
+ !YCAR80(1:80)=' '
+ ! WRITE(YCAR80,*)NLBL2
+ ! YCAR80=ADJUSTL(ADJUSTR(YCAR80))
+ !WRITE(NDIR,*)YCAR80
+ CALL WRITEDIR(NDIR,NLBL2)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ YCAR80(1:80)=' '
+ ALLOCATE(XLBLUSER2(NLBL2))
+ PRINT *,'Indiquez les ',NLBL2,' valeurs'
+ READ(5,*)XLBLUSER2
+ ! WRITE(YCAR80,*)XLBLUSER2(1:NLBL2)
+ ! YCAR80=ADJUSTL(ADJUSTR(YCAR80))
+ !WRITE(NDIR,*)YCAR80
+ CALL WRITEDIR(NDIR,XLBLUSER2(1:NLBL2))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ENDIF
+ENDIF
+IF(INDLBLUSER3 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLBLUSER3,LBLUSER3)
+ IF(LBLUSER3)THEN
+ IF(ALLOCATED(XLBLUSER3))THEN
+ DEALLOCATE(XLBLUSER3)
+ ENDIF
+ PRINT *,'Indiquez le nombre de isolignes à labeller'
+ READ(5,*)NLBL3
+ ! YCAR80(1:80)=' '
+ ! WRITE(YCAR80,*)NLBL3
+ ! YCAR80=ADJUSTL(ADJUSTR(YCAR80))
+ !WRITE(NDIR,*)YCAR80
+ CALL WRITEDIR(NDIR,NLBL3)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ YCAR80(1:80)=' '
+ ALLOCATE(XLBLUSER3(NLBL3))
+ PRINT *,'Indiquez les ',NLBL3,' valeurs'
+ READ(5,*)XLBLUSER3
+ !WRITE(YCAR80,*)XLBLUSER3(1:NLBL3)
+ !YCAR80=ADJUSTL(ADJUSTR(YCAR80))
+ !WRITE(NDIR,*)YCAR80
+ CALL WRITEDIR(NDIR,XLBLUSER3(1:NLBL3))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ENDIF
+ENDIF
+IF(INDLBLUSER4 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLBLUSER4,LBLUSER4)
+ IF(LBLUSER4)THEN
+ IF(ALLOCATED(XLBLUSER4))THEN
+ DEALLOCATE(XLBLUSER4)
+ ENDIF
+ PRINT *,'Indiquez le nombre de isolignes à labeller'
+ READ(5,*)NLBL4
+ YCAR80(1:80)=' '
+ !WRITE(YCAR80,*)NLBL4
+ !YCAR80=ADJUSTL(ADJUSTR(YCAR80))
+ !WRITE(NDIR,*)YCAR80
+ CALL WRITEDIR(NDIR,NLBL4)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ YCAR80(1:80)=' '
+ ALLOCATE(XLBLUSER4(NLBL4))
+ PRINT *,'Indiquez les ',NLBL4,' valeurs'
+ READ(5,*)XLBLUSER4
+ !WRITE(YCAR80,*)XLBLUSER4(1:NLBL4)
+ !YCAR80=ADJUSTL(ADJUSTR(YCAR80))
+ !WRITE(NDIR,*)YCAR80
+ CALL WRITEDIR(NDIR,XLBLUSER4(1:NLBL4))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ENDIF
+ENDIF
+IF(INDLINDSP /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLINDSP,LINDSP)
+ENDIF
+IF(INDLINDAX /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLINDAX,LINDAX)
+ENDIF
+IF(INDLCHREEL /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCHREEL,LCHREEL)
+ENDIF
+IF(INDLOGNEP /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLOGNEP,LOGNEP)
+ENDIF
+IF(INDLCOLISONE /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCOLISONE,LCOLISONE)
+ENDIF
+IF(INDLCOLRSONE /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCOLRSONE,LCOLRSONE)
+ENDIF
+IF(INDLCOLRS1ONE /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCOLRS1ONE,LCOLRS1ONE)
+ENDIF
+IF(INDLCOLINE /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCOLINE,LCOLINE)
+ENDIF
+IF(INDL24H /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDL24H,L24H)
+ENDIF
+IF(INDLCONT /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCONT,LCONT)
+ENDIF
+IF(INDL2CONT /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDL2CONT,L2CONT)
+ENDIF
+IF(INDLRELIEF /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLRELIEF,LRELIEF)
+ENDIF
+IF(INDLCONV2XY /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCONV2XY,LCONV2XY)
+ENDIF
+IF(INDLCONVG2MASS /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCONVG2MASS,LCONVG2MASS)
+ENDIF
+IF(INDLCOLZERO /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCOLZERO,LCOLZERO)
+ENDIF
+IF(INDL3D /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDL3D,L3D)
+ENDIF
+IF(INDLMARKER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLMARKER,LMARKER)
+ENDIF
+IF(INDLSPOT /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLSPOT,LSPOT)
+ENDIF
+IF(INDLHEURX /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLHEURX,LHEURX)
+ENDIF
+IF(INDLMYHEURX /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLMYHEURX,LMYHEURX)
+ENDIF
+IF(INDLNOUVRS /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLNOUVRS,LNOUVRS)
+ENDIF
+IF(INDLHACH1 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLHACH1,LHACH1)
+ENDIF
+IF(INDLHACH2 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLHACH2,LHACH2)
+ENDIF
+IF(INDLHACH3 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLHACH3,LHACH3)
+ENDIF
+IF(INDLHACH4 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLHACH4,LHACH4)
+ENDIF
+IF(INDLHACHSEL /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLHACHSEL,LHACHSEL)
+ENDIF
+IF(INDLGREY /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLGREY,LGREY)
+ENDIF
+IF(INDLPRDAT /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLPRDAT,LPRDAT)
+ENDIF
+IF(INDLPRINT /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLPRINT,LPRINT)
+ENDIF
+IF(INDLPRINTXY /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLPRINTXY,LPRINTXY)
+ENDIF
+IF(INDLPOINTG /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLPOINTG,LPOINTG)
+ENDIF
+IF(INDLXYO /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLXYO,LXYO)
+ENDIF
+IF(INDL2DBX /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDL2DBX,L2DBX)
+ENDIF
+IF(INDL2DBY /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDL2DBY,L2DBY)
+ENDIF
+IF(INDLCOLUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCOLUSER,LCOLUSER)
+ENDIF
+IF(INDLTIMEUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLTIMEUSER,LTIMEUSER)
+ENDIF
+IF(INDLCOLUSERUV /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCOLUSERUV,LCOLUSERUV)
+ENDIF
+IF(INDLVECTMNMX /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLVECTMNMX,LVECTMNMX)
+ENDIF
+IF(INDLISOWHI /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLISOWHI,LISOWHI)
+ENDIF
+IF(INDLISOWHI2 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLISOWHI2,LISOWHI2)
+ENDIF
+IF(INDLISOWHI3 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLISOWHI3,LISOWHI3)
+ENDIF
+IF(INDLCOLBR /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCOLBR,LCOLBR)
+ENDIF
+IF(INDLINVWB /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLINVWB,LINVWB)
+ENDIF
+IF(INDLINVPTIR /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLINVPTIR,LINVPTIR)
+ENDIF
+IF(INDLDOMAIN /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLDOMAIN,LDOMAIN)
+ENDIF
+IF(INDLGEOG /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLGEOG,LGEOG)
+ENDIF
+IF(INDLBLFT1SUP /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLBLFT1SUP,LBLFT1SUP)
+ENDIF
+IF(INDLXYZ00 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLXYZ00,LXYZ00)
+ENDIF
+IF(INDLFT1LUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFT1LUSER,LFT1LUSER)
+ENDIF
+! Si LMASK3D_XY=T ou LMASK3D_XZ=T ou LMASK3D_YZ=T -> LMASK3D=T
+IF(INDLMASK3D_XY /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLMASK3D_XY,LMASK3D_XY)
+! IF(LMASK3D_XY)THEN
+! LMASK3D=.TRUE.
+! ENDIF
+ENDIF
+IF(INDLMASK3D_XZ /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLMASK3D_XZ,LMASK3D_XZ)
+! IF(LMASK3D_XZ)THEN
+! LMASK3D=.TRUE.
+! ENDIF
+ENDIF
+IF(INDLMASK3D_YZ /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLMASK3D_YZ,LMASK3D_YZ)
+! IF(LMASK3D_YZ)THEN
+! LMASK3D=.TRUE.
+! ENDIF
+ENDIF
+!IF(INDLMASK3D /= 0 .OR. LMASK3D)THEN
+IF(INDLMASK3D /= 0 )THEN
+! IF(.NOT.LMASK3D)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLMASK3D,LMASK3D)
+ IF(LMASK3D)THEN
+ LMASK3D_XY=.TRUE.
+ LMASK3D_XZ=.TRUE.
+ LMASK3D_YZ=.TRUE.
+ ENDIF
+ENDIF
+ IF(LMASK3D .OR. LMASK3D_XY .OR. LMASK3D_XZ .OR. LMASK3D_YZ)THEN
+ IF(XXL == 0. .AND. XXH == 0. .AND. XYL == 0. .AND. XYH == 0. &
+ .AND. XZL == 0. .AND. XZH == 0.)THEN
+ print *,' Definissez une fenetre (en metres) dans XXL= XXH= XYL= XYH= XZL= XZH='
+ print *,' Et rentrez a nouveau votre directive '
+ IF(LMASK3D)THEN
+ LMASK3D=.FALSE.
+ LMASK3D_XY=.FALSE.
+ LMASK3D_XZ=.FALSE.
+ LMASK3D_YZ=.FALSE.
+ ENDIF
+! Septembre 2000
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ RETURN
+ ELSE
+ CALL TRAMASK3D
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ ENDIF
+! IF(.NOT.LMASK3D_XY .AND. .NOT.LMASK3D_XZ .AND. .NOT.LMASK3D_YZ)THEN
+ IF(LMASK3D)THEN
+ LMASK3D=.FALSE.
+ print *,' LMASK3D remis a .FALSE. Pour une nouvelle visualisation du masque'
+ print *,' Rentrez a nouveau la directive LMASK3D=T . '
+ LMASK3D_XY=.FALSE.
+ LMASK3D_XZ=.FALSE.
+ LMASK3D_YZ=.FALSE.
+ ELSE IF(LMASK3D_XY)THEN
+ LMASK3D_XY=.FALSE.
+ print *,' LMASK3D_XY remis a .FALSE. '
+! LMASK3D=.FALSE.
+ ELSE IF(LMASK3D_XZ)THEN
+ LMASK3D_XZ=.FALSE.
+ print *,' LMASK3D_XZ remis a .FALSE. '
+! LMASK3D=.FALSE.
+ ELSE IF(LMASK3D_YZ)THEN
+ LMASK3D_YZ=.FALSE.
+! LMASK3D=.FALSE.
+ print *,' LMASK3D_YZ remis a .FALSE. '
+ ENDIF
+! ENDIF
+ ENDIF
+ENDIF
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!
+IF(INDLTRAJ_GROUP /= 0 )THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLTRAJ_GROUP,LTRAJ_GROUP)
+ENDIF
+!
+IF(INDLFLUX3D /= 0 )THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFLUX3D,LFLUX3D)
+ENDIF
+IF (LFLUX3D) THEN
+ IF(XXPART(1) == -999.)THEN
+ print *,' Definissez d abord les positions initiales de vos particules'
+ print *,' par des tableaux XXPART= ....,9999. '
+ print *,' XYPART= ....,9999. '
+ print *,' et XZPART= ....,9999. '
+ print *,' Et rentrez a nouveau votre directive '
+! Septembre 2000
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ RETURN
+ ELSE
+ CALL TRAFLUX3D
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ ENDIF
+ IF(LFLUX3D)THEN
+ LFLUX3D=.FALSE.
+ print *,' LFLUX3D remis a .FALSE. Pour une nouvelle visualisation '
+ print *,' de lignes de flux'
+ print *,' Rentrez a nouveau la directive LFLUX3D=T . '
+ ENDIF
+ ENDIF
+ENDIF
+!
+IF(INDLTRAJ3D /= 0 )THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLTRAJ3D,LTRAJ3D)
+ENDIF
+IF(LTRAJ3D) THEN
+ IF(XXPART(1) == -999.)THEN
+ print *,' Definissez d abord les positions initiales de vos particules'
+ print *,' par des tableaux XXPART= ....,9999. '
+ print *,' XYPART= ....,9999. '
+ print *,' et XZPART= ....,9999. '
+ print *,' Et rentrez a nouveau votre directive '
+! Septembre 2000
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ RETURN
+ ELSE
+ CALL TRATRAJ3D
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ ENDIF
+ IF(LTRAJ3D)THEN
+ LTRAJ3D=.FALSE.
+ print *,' LTRAJ3D remis a .FALSE. Pour une nouvelle visualisation '
+ print *,' de particules'
+ print *,' Rentrez a nouveau la directive LTRAJ3D=T . '
+ ENDIF
+ ENDIF
+ENDIF
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+IF(INDLFT3C /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFT3C,LFT3C)
+ENDIF
+IF(INDLFT4C /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFT4C,LFT4C)
+ENDIF
+IF(INDLFTCLIP /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFTCLIP,LFTCLIP)
+ENDIF
+IF(INDLFT1STYLUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFT1STYLUSER,LFT1STYLUSER)
+ENDIF
+IF(INDLFTSTYLUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFTSTYLUSER,LFTSTYLUSER)
+ENDIF
+IF(INDLCOLAREASEL /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCOLAREASEL,LCOLAREASEL)
+ENDIF
+IF(INDLCOLINESEL /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLCOLINESEL,LCOLINESEL)
+ENDIF
+IF(INDLTABCOLDEF /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLTABCOLDEF,LTABCOLDEF)
+ENDIF
+IF(INDLTABCOLDEF2 /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLTABCOLDEF2,LTABCOLDEF2)
+ENDIF
+IF(INDLMNMXUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLMNMXUSER,LMNMXUSER)
+ENDIF
+IF(INDLMNMXLOC /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLMNMXLOC,LMNMXLOC)
+ENDIF
+IF(INDLULMVTMOLD /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLULMVTMOLD,LULMVTMOLD)
+ENDIF
+IF(INDLVPTUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLVPTUSER,LVPTUSER)
+ENDIF
+IF(INDLVPTVUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLVPTVUSER,LVPTVUSER)
+ENDIF
+IF(INDLVPTPVUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLVPTPVUSER,LVPTPVUSER)
+ENDIF
+IF(INDLVPTXYUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLVPTXYUSER,LVPTXYUSER)
+ENDIF
+IF(INDLFACTIMP /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFACTIMP,LFACTIMP)
+ENDIF
+IF(INDLFACTAXEX /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFACTAXEX,LFACTAXEX)
+ENDIF
+IF(INDLFACTAXEY /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFACTAXEY,LFACTAXEY)
+ENDIF
+IF(INDLAXEXUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLAXEXUSER,LAXEXUSER)
+ENDIF
+IF(INDLAXEYUSER /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLAXEYUSER,LAXEYUSER)
+ENDIF
+IF(INDLFMTAXEX /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFMTAXEX,LFMTAXEX)
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!! pour les retrotrajectoires !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF(INDLFMTRTRAJ /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFMTRTRAJ,LFMTRTRAJ)
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF(INDLFMTAXEY /= 0)THEN
+ CALL RESOLVL(YCARIN(1:LEN_TRIM(YCARIN)),INDLFMTAXEY,LFMTAXEY)
+ENDIF
+IF(INDNIFDC /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNIFDC,NIFDC)
+ IF(NIFDC /= 999999999)THEN
+ PRINT *,' NIFDC FOURNI ',NIFDC
+ ENDIF
+ENDIF
+IF(INDNDOMAINL /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNDOMAINL,NDOMAINL)
+ IF(NDOMAINL /= 999999999)THEN
+ PRINT *,' NDOMAINL FOURNI ',NDOMAINL
+ ENDIF
+ENDIF
+IF(INDNDOMAINR /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNDOMAINR,NDOMAINR)
+ IF(NDOMAINR /= 999999999)THEN
+ PRINT *,' NDOMAINR FOURNI ',NDOMAINR
+ ENDIF
+ENDIF
+IF(INDNDOMAINB /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNDOMAINB,NDOMAINB)
+ IF(NDOMAINB /= 999999999)THEN
+ PRINT *,' NDOMAINB FOURNI ',NDOMAINB
+ ENDIF
+ENDIF
+IF(INDNDOMAINT /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNDOMAINT,NDOMAINT)
+ IF(NDOMAINT /= 999999999)THEN
+ PRINT *,' NDOMAINT FOURNI ',NDOMAINT
+ ENDIF
+ENDIF
+IF(INDNIGRNC /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNIGRNC,NIGRNC)
+ IF(NIGRNC /= 999999999)THEN
+ PRINT *,' NIGRNC FOURNI ',NIGRNC
+ ENDIF
+ENDIF
+IF(INDNPROFILE /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPROFILE,NPROFILE)
+ IF(NPROFILE /= 999999999)THEN
+ PRINT *,' PROFILE FOURNI ',NPROFILE
+ ENDIF
+ENDIF
+IF(INDNIRS /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNIRS,NIRS)
+ IF(NIRS /= 999999999)THEN
+ PRINT *,' NIRS FOURNI ',NIRS
+ XIRS=-999.
+ ENDIF
+ENDIF
+IF(INDNJRS /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNJRS,NJRS)
+ IF(NJRS /= 999999999)THEN
+ PRINT *,' NJRS FOURNI ',NJRS
+ XJRS=-999.
+ ENDIF
+ENDIF
+IF(INDNCOLUV1 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLUV1,NCOLUV1)
+ PRINT *,' NCOLUV1 FOURNI ',NCOLUV1
+ENDIF
+IF(INDNCOLUV2 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLUV2,NCOLUV2)
+ PRINT *,' NCOLUV2 FOURNI ',NCOLUV2
+ENDIF
+IF(INDNCOLUV3 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLUV3,NCOLUV3)
+ PRINT *,' NCOLUV3 FOURNI ',NCOLUV3
+ENDIF
+IF(INDNCOLUV4 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLUV4,NCOLUV4)
+ PRINT *,' NCOLUV4 FOURNI ',NCOLUV4
+ENDIF
+IF(INDNCOLUV5 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLUV5,NCOLUV5)
+ PRINT *,' NCOLUV5 FOURNI ',NCOLUV5
+ENDIF
+IF(INDNCOLISONE1 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLISONE1,NCOLISONE1)
+ PRINT *,' NCOLISONE1 FOURNI ',NCOLISONE1
+ENDIF
+IF(INDNCOLISONE2 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLISONE2,NCOLISONE2)
+ PRINT *,' NCOLISONE2 FOURNI ',NCOLISONE2
+ENDIF
+IF(INDNCOLISONE3 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLISONE3,NCOLISONE3)
+ PRINT *,' NCOLISONE3 FOURNI ',NCOLISONE3
+ENDIF
+IF(INDNCOLISONE4 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLISONE4,NCOLISONE4)
+ PRINT *,' NCOLISONE4 FOURNI ',NCOLISONE4
+ENDIF
+IF(INDNCOLISONE5 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLISONE5,NCOLISONE5)
+ PRINT *,' NCOLISONE5 FOURNI ',NCOLISONE5
+ENDIF
+IF(INDNCOLRS1ONE1 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLRS1ONE1,NCOLRS1ONE1)
+ PRINT *,' NCOLRS1ONE1 FOURNI ',NCOLRS1ONE1
+ENDIF
+IF(INDNCOLRS1ONE2 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLRS1ONE2,NCOLRS1ONE2)
+ PRINT *,' NCOLRS1ONE2 FOURNI ',NCOLRS1ONE2
+ENDIF
+IF(INDNCOLRS1ONE3 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLRS1ONE3,NCOLRS1ONE3)
+ PRINT *,' NCOLRS1ONE3 FOURNI ',NCOLRS1ONE3
+ENDIF
+IF(INDNCOLRS1ONE4 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLRS1ONE4,NCOLRS1ONE4)
+ PRINT *,' NCOLRS1ONE4 FOURNI ',NCOLRS1ONE4
+ENDIF
+IF(INDNCOLRS1ONE5 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLRS1ONE5,NCOLRS1ONE5)
+ PRINT *,' NCOLRS1ONE5 FOURNI ',NCOLRS1ONE5
+ENDIF
+IF(INDNCOLRSONE /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLRSONE,NCOLRSONE)
+ PRINT *,' NCOLRSONE FOURNI ',NCOLRSONE
+ENDIF
+IF(INDNCOLZERO /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNCOLZERO,NCOLZERO)
+ PRINT *,' NCOLZERO FOURNI ',NCOLZERO
+ENDIF
+IF(INDNVERBIA /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNVERBIA,NVERBIA)
+ PRINT *,' NVERBIA FOURNI ',NVERBIA
+ENDIF
+!
+IF(INDNFT1STY1 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY1,NFT1STY1)
+ PRINT *,' NFT1STY1 FOURNI ',NFT1STY1
+ENDIF
+IF(INDNFT1STY2 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY2,NFT1STY2)
+ PRINT *,' NFT1STY2 FOURNI ',NFT1STY2
+ENDIF
+IF(INDNFT1STY3 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY3,NFT1STY3)
+ PRINT *,' NFT1STY3 FOURNI ',NFT1STY3
+ENDIF
+IF(INDNFT1STY4 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY4,NFT1STY4)
+ PRINT *,' NFT1STY4 FOURNI ',NFT1STY4
+ENDIF
+IF(INDNFT1STY5 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY5,NFT1STY5)
+ PRINT *,' NFT1STY5 FOURNI ',NFT1STY5
+ENDIF
+IF(INDNFT1STY6 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY6,NFT1STY6)
+ PRINT *,' NFT1STY6 FOURNI ',NFT1STY6
+ENDIF
+IF(INDNFT1STY7 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY7,NFT1STY7)
+ PRINT *,' NFT1STY7 FOURNI ',NFT1STY7
+ENDIF
+IF(INDNFT1STY8 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY8,NFT1STY8)
+ PRINT *,' NFT1STY8 FOURNI ',NFT1STY8
+ENDIF
+IF(INDNFT1STY9 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY9,NFT1STY9)
+ PRINT *,' NFT1STY9 FOURNI ',NFT1STY9
+ENDIF
+IF(INDNFT1STY10 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY10,NFT1STY10)
+ PRINT *,' NFT1STY10 FOURNI ',NFT1STY10
+ENDIF
+IF(INDNFT1STY11 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY11,NFT1STY11)
+ PRINT *,' NFT1STY11 FOURNI ',NFT1STY11
+ENDIF
+IF(INDNFT1STY12 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY12,NFT1STY12)
+ PRINT *,' NFT1STY12 FOURNI ',NFT1STY12
+ENDIF
+IF(INDNFT1STY13 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY13,NFT1STY13)
+ PRINT *,' NFT1STY13 FOURNI ',NFT1STY13
+ENDIF
+IF(INDNFT1STY14 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY14,NFT1STY14)
+ PRINT *,' NFT1STY14 FOURNI ',NFT1STY14
+ENDIF
+IF(INDNFT1STY15 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1STY15,NFT1STY15)
+ PRINT *,' NFT1STY15 FOURNI ',NFT1STY15
+ENDIF
+!
+IF(INDNFT1COL1 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL1,NFT1COL1)
+ PRINT *,' NFT1COL1 FOURNI ',NFT1COL1
+ENDIF
+IF(INDNFT1COL2 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL2,NFT1COL2)
+ PRINT *,' NFT1COL2 FOURNI ',NFT1COL2
+ENDIF
+IF(INDNFT1COL3 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL3,NFT1COL3)
+ PRINT *,' NFT1COL3 FOURNI ',NFT1COL3
+ENDIF
+IF(INDNFT1COL4 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL4,NFT1COL4)
+ PRINT *,' NFT1COL4 FOURNI ',NFT1COL4
+ENDIF
+IF(INDNFT1COL5 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL5,NFT1COL5)
+ PRINT *,' NFT1COL5 FOURNI ',NFT1COL5
+ENDIF
+IF(INDNFT1COL6 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL6,NFT1COL6)
+ PRINT *,' NFT1COL6 FOURNI ',NFT1COL6
+ENDIF
+IF(INDNFT1COL7 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL7,NFT1COL7)
+ PRINT *,' NFT1COL7 FOURNI ',NFT1COL7
+ENDIF
+IF(INDNFT1COL8 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL8,NFT1COL8)
+ PRINT *,' NFT1COL8 FOURNI ',NFT1COL8
+ENDIF
+IF(INDNFT1COL9 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL9,NFT1COL9)
+ PRINT *,' NFT1COL9 FOURNI ',NFT1COL9
+ENDIF
+IF(INDNFT1COL10 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL10,NFT1COL10)
+ PRINT *,' NFT1COL10 FOURNI ',NFT1COL10
+ENDIF
+IF(INDNFT1COL11 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL11,NFT1COL11)
+ PRINT *,' NFT1COL11 FOURNI ',NFT1COL11
+ENDIF
+IF(INDNFT1COL12 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL12,NFT1COL12)
+ PRINT *,' NFT1COL12 FOURNI ',NFT1COL12
+ENDIF
+IF(INDNFT1COL13 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL13,NFT1COL13)
+ PRINT *,' NFT1COL13 FOURNI ',NFT1COL13
+ENDIF
+IF(INDNFT1COL14 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL14,NFT1COL14)
+ PRINT *,' NFT1COL14 FOURNI ',NFT1COL14
+ENDIF
+IF(INDNFT1COL15 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNFT1COL15,NFT1COL15)
+ PRINT *,' NFT1COL15 FOURNI ',NFT1COL15
+ENDIF
+!
+IF(INDNPHCOL1 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHCOL1,NPHCOL1)
+ PRINT *,' NPHCOL1 FOURNI ',NPHCOL1
+ENDIF
+IF(INDNPHCOL2 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHCOL2,NPHCOL2)
+ PRINT *,' NPHCOL2 FOURNI ',NPHCOL2
+ENDIF
+IF(INDNPHCOL3 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHCOL3,NPHCOL3)
+ PRINT *,' NPHCOL3 FOURNI ',NPHCOL3
+ENDIF
+IF(INDNPHCOL4 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHCOL4,NPHCOL4)
+ PRINT *,' NPHCOL4 FOURNI ',NPHCOL4
+ENDIF
+IF(INDNPHCOL5 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHCOL5,NPHCOL5)
+ PRINT *,' NPHCOL5 FOURNI ',NPHCOL5
+ENDIF
+IF(INDNPHCOL6 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHCOL6,NPHCOL6)
+ PRINT *,' NPHCOL6 FOURNI ',NPHCOL6
+ENDIF
+IF(INDNPHCOL7 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHCOL7,NPHCOL7)
+ PRINT *,' NPHCOL7 FOURNI ',NPHCOL7
+ENDIF
+IF(INDNPHCOL8 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHCOL8,NPHCOL8)
+ PRINT *,' NPHCOL8 FOURNI ',NPHCOL8
+ENDIF
+!
+IF(INDNPHSTY1 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHSTY1,NPHSTY1)
+ PRINT *,' NPHSTY1 FOURNI ',NPHSTY1
+ENDIF
+IF(INDNPHSTY2 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHSTY2,NPHSTY2)
+ PRINT *,' NPHSTY2 FOURNI ',NPHSTY2
+ENDIF
+IF(INDNPHSTY3 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHSTY3,NPHSTY3)
+ PRINT *,' NPHSTY3 FOURNI ',NPHSTY3
+ENDIF
+IF(INDNPHSTY4 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHSTY4,NPHSTY4)
+ PRINT *,' NPHSTY4 FOURNI ',NPHSTY4
+ENDIF
+IF(INDNPHSTY5 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHSTY5,NPHSTY5)
+ PRINT *,' NPHSTY5 FOURNI ',NPHSTY5
+ENDIF
+IF(INDNPHSTY6 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHSTY6,NPHSTY6)
+ PRINT *,' NPHSTY6 FOURNI ',NPHSTY6
+ENDIF
+IF(INDNPHSTY7 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHSTY7,NPHSTY7)
+ PRINT *,' NPHSTY7 FOURNI ',NPHSTY7
+ENDIF
+IF(INDNPHSTY8 /= 0)THEN
+ CALL RESOLVI(YCARIN(1:LEN_TRIM(YCARIN)),INDNPHSTY8,NPHSTY8)
+ PRINT *,' NPHSTY8 FOURNI ',NPHSTY8
+ENDIF
+!
+!
+IF(INDVISU /=0 .AND. INDNOVISU == 0)THEN
+ CALL GQOPS(ISTA)
+ IF(ISTA == 0)THEN
+ CALL OPNGKS
+ ENDIF
+ CALL GOPWK(2,0,8)
+ CALL GACWK(2)
+ CALL TABCOL_FORDIACHRO
+ENDIF
+IF(INDNOVISU/=0)THEN
+ CALL GDAWK(2)
+ CALL GCLWK(2)
+ENDIF
+IF(INDXSIZEL /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSIZEL,XSIZEL)
+ print *,' VALEUR XSIZEL FOURNIE : ',XSIZEL
+ENDIF
+IF(INDXSZTITXL /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITXL,XSZTITXL)
+ print *,' VALEUR XSZTITXL FOURNIE : ',XSZTITXL
+ENDIF
+IF(INDXSZTITXM /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITXM,XSZTITXM)
+ print *,' VALEUR XSZTITXM FOURNIE : ',XSZTITXM
+ENDIF
+IF(INDXSZTITXR /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITXR,XSZTITXR)
+ print *,' VALEUR XSZTITXR FOURNIE : ',XSZTITXR
+ENDIF
+IF(INDXSZTITT1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITT1,XSZTITT1)
+ print *,' VALEUR XSZTITT1 FOURNIE : ',XSZTITT1
+ENDIF
+IF(INDXSZTITT2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITT2,XSZTITT2)
+ print *,' VALEUR XSZTITT2 FOURNIE : ',XSZTITT2
+ENDIF
+IF(INDXSZTITT3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITT3,XSZTITT3)
+ print *,' VALEUR XSZTITT3 FOURNIE : ',XSZTITT3
+ENDIF
+IF(INDXSZTITYT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITYT,XSZTITYT)
+ print *,' VALEUR XSZTITYT FOURNIE : ',XSZTITYT
+ENDIF
+IF(INDXSZTITYM /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITYM,XSZTITYM)
+ print *,' VALEUR XSZTITYM FOURNIE : ',XSZTITYM
+ENDIF
+IF(INDXSZTITYB /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITYB,XSZTITYB)
+ print *,' VALEUR XSZTITYB FOURNIE : ',XSZTITYB
+ENDIF
+IF(INDXPOSTITYT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITYT,XPOSTITYT)
+ print *,' VALEUR XPOSTITYT FOURNIE : ',XPOSTITYT
+ENDIF
+IF(INDXPOSTITYM /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITYM,XPOSTITYM)
+ print *,' VALEUR XPOSTITYM FOURNIE : ',XPOSTITYM
+ENDIF
+IF(INDXPOSTITYB /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITYB,XPOSTITYB)
+ print *,' VALEUR XPOSTITYB FOURNIE : ',XPOSTITYB
+ENDIF
+IF(INDXPOSTITT1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITT1,XPOSTITT1)
+ print *,' VALEUR XPOSTITT1 FOURNIE : ',XPOSTITT1
+ENDIF
+IF(INDXPOSTITT2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITT2,XPOSTITT2)
+ print *,' VALEUR XPOSTITT2 FOURNIE : ',XPOSTITT2
+ENDIF
+IF(INDXPOSTITT3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITT3,XPOSTITT3)
+ print *,' VALEUR XPOSTITT3 FOURNIE : ',XPOSTITT3
+ENDIF
+IF(INDXYPOSTITT1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITT1,XYPOSTITT1)
+ print *,' VALEUR XYPOSTITT1 FOURNIE : ',XYPOSTITT1
+ENDIF
+IF(INDXYPOSTITT2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITT2,XYPOSTITT2)
+ print *,' VALEUR XYPOSTITT2 FOURNIE : ',XYPOSTITT2
+ENDIF
+IF(INDXYPOSTITT3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITT3,XYPOSTITT3)
+ print *,' VALEUR XYPOSTITT3 FOURNIE : ',XYPOSTITT3
+ENDIF
+IF(INDXSZTITB1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITB1,XSZTITB1)
+ print *,' VALEUR XSZTITB1 FOURNIE : ',XSZTITB1
+ENDIF
+IF(INDXSZTITB2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITB2,XSZTITB2)
+ print *,' VALEUR XSZTITB2 FOURNIE : ',XSZTITB2
+ENDIF
+IF(INDXSZTITB3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITB3,XSZTITB3)
+ print *,' VALEUR XSZTITB3 FOURNIE : ',XSZTITB3
+ENDIF
+IF(INDXPOSTITB1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITB1,XPOSTITB1)
+ print *,' VALEUR XPOSTITB1 FOURNIE : ',XPOSTITB1
+ENDIF
+IF(INDXPOSTITB2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITB2,XPOSTITB2)
+ print *,' VALEUR XPOSTITB2 FOURNIE : ',XPOSTITB2
+ENDIF
+IF(INDXPOSTITB3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITB3,XPOSTITB3)
+ print *,' VALEUR XPOSTITB3 FOURNIE : ',XPOSTITB3
+ENDIF
+IF(INDXYPOSTITYT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITYT,XYPOSTITYT)
+ print *,' VALEUR XYPOSTITYT FOURNIE : ',XYPOSTITYT
+ENDIF
+IF(INDXYPOSTITYM /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITYM,XYPOSTITYM)
+ print *,' VALEUR XYPOSTITYM FOURNIE : ',XYPOSTITYM
+ENDIF
+IF(INDXYPOSTITYB /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITYB,XYPOSTITYB)
+ print *,' VALEUR XYPOSTITYB FOURNIE : ',XYPOSTITYB
+ENDIF
+IF(INDXYPOSTITB1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITB1,XYPOSTITB1)
+ print *,' VALEUR XYPOSTITB1 FOURNIE : ',XYPOSTITB1
+ENDIF
+IF(INDXYPOSTITB2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITB2,XYPOSTITB2)
+ print *,' VALEUR XYPOSTITB2 FOURNIE : ',XYPOSTITB2
+ENDIF
+IF(INDXYPOSTITB3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITB3,XYPOSTITB3)
+ print *,' VALEUR XYPOSTITB3 FOURNIE : ',XYPOSTITB3
+ENDIF
+IF(INDXSZTITVAR1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITVAR1,XSZTITVAR1)
+ print *,' VALEUR XSZTITVAR1 FOURNIE : ',XSZTITVAR1
+ENDIF
+IF(INDXSZTITVAR2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITVAR2,XSZTITVAR2)
+ print *,' VALEUR XSZTITVAR2 FOURNIE : ',XSZTITVAR2
+ENDIF
+IF(INDXSZTITVAR3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITVAR3,XSZTITVAR3)
+ print *,' VALEUR XSZTITVAR3 FOURNIE : ',XSZTITVAR3
+ENDIF
+IF(INDXSZTITVAR4 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITVAR4,XSZTITVAR4)
+ print *,' VALEUR XSZTITVAR4 FOURNIE : ',XSZTITVAR4
+ENDIF
+IF(INDXSZTITVAR5 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITVAR5,XSZTITVAR5)
+ print *,' VALEUR XSZTITVAR5 FOURNIE : ',XSZTITVAR5
+ENDIF
+IF(INDXSZTITVAR6 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITVAR6,XSZTITVAR6)
+ print *,' VALEUR XSZTITVAR6 FOURNIE : ',XSZTITVAR6
+ENDIF
+IF(INDXSZTITVAR7 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITVAR7,XSZTITVAR7)
+ print *,' VALEUR XSZTITVAR7 FOURNIE : ',XSZTITVAR7
+ENDIF
+IF(INDXSZTITVAR8 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZTITVAR8,XSZTITVAR8)
+ print *,' VALEUR XSZTITVAR8 FOURNIE : ',XSZTITVAR8
+ENDIF
+IF(INDXPOSTITVAR1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITVAR1,XPOSTITVAR1)
+ print *,' VALEUR XPOSTITVAR1 FOURNIE : ',XPOSTITVAR1
+ENDIF
+IF(INDXPOSTITVAR2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITVAR2,XPOSTITVAR2)
+ print *,' VALEUR XPOSTITVAR2 FOURNIE : ',XPOSTITVAR2
+ENDIF
+IF(INDXPOSTITVAR3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITVAR3,XPOSTITVAR3)
+ print *,' VALEUR XPOSTITVAR3 FOURNIE : ',XPOSTITVAR3
+ENDIF
+IF(INDXYPOSTITVAR1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITVAR1,XYPOSTITVAR1)
+ print *,' VALEUR XYPOSTITVAR1 FOURNIE : ',XYPOSTITVAR1
+ENDIF
+IF(INDXYPOSTITVAR2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITVAR2,XYPOSTITVAR2)
+ print *,' VALEUR XYPOSTITVAR2 FOURNIE : ',XYPOSTITVAR2
+ENDIF
+IF(INDXYPOSTITVAR3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITVAR3,XYPOSTITVAR3)
+ print *,' VALEUR XYPOSTITVAR3 FOURNIE : ',XYPOSTITVAR3
+ENDIF
+IF(INDXPOSTITVAR4 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITVAR4,XPOSTITVAR4)
+ print *,' VALEUR XPOSTITVAR4 FOURNIE : ',XPOSTITVAR4
+ENDIF
+IF(INDXPOSTITVAR5 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITVAR5,XPOSTITVAR5)
+ print *,' VALEUR XPOSTITVAR5 FOURNIE : ',XPOSTITVAR5
+ENDIF
+IF(INDXPOSTITVAR6 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITVAR6,XPOSTITVAR6)
+ print *,' VALEUR XPOSTITVAR6 FOURNIE : ',XPOSTITVAR6
+ENDIF
+IF(INDXYPOSTITVAR4 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITVAR4,XYPOSTITVAR4)
+ print *,' VALEUR XYPOSTITVAR4 FOURNIE : ',XYPOSTITVAR4
+ENDIF
+IF(INDXYPOSTITVAR5 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITVAR5,XYPOSTITVAR5)
+ print *,' VALEUR XYPOSTITVAR5 FOURNIE : ',XYPOSTITVAR5
+ENDIF
+IF(INDXYPOSTITVAR6 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITVAR6,XYPOSTITVAR6)
+ print *,' VALEUR XYPOSTITVAR6 FOURNIE : ',XYPOSTITVAR6
+ENDIF
+IF(INDXPOSTITVAR7 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITVAR7,XPOSTITVAR7)
+ print *,' VALEUR XPOSTITVAR7 FOURNIE : ',XPOSTITVAR7
+ENDIF
+IF(INDXPOSTITVAR8 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSTITVAR8,XPOSTITVAR8)
+ print *,' VALEUR XPOSTITVAR8 FOURNIE : ',XPOSTITVAR8
+ENDIF
+IF(INDXYPOSTITVAR7 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITVAR7,XYPOSTITVAR7)
+ print *,' VALEUR XYPOSTITVAR7 FOURNIE : ',XYPOSTITVAR7
+ENDIF
+IF(INDXYPOSTITVAR8 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPOSTITVAR8,XYPOSTITVAR8)
+ print *,' VALEUR XYPOSTITVAR8 FOURNIE : ',XYPOSTITVAR8
+ENDIF
+!*JD* Mars 2009
+IF(INDXPOSXVARNPV1TOP /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSXVARNPV1TOP,XPOSXVARNPV1TOP)
+ print *,' VALEUR XPOSXVARNPV1TOP FOURNIE : ',XPOSXVARNPV1TOP
+ENDIF
+IF(INDXPOSYVARNPV1TOP /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSYVARNPV1TOP,XPOSYVARNPV1TOP)
+ print *,' VALEUR XPOSYVARNPV1TOP FOURNIE : ',XPOSYVARNPV1TOP
+ENDIF
+IF(INDXPOSXVARNPV5BOT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSXVARNPV5BOT,XPOSXVARNPV5BOT)
+ print *,' VALEUR XPOSXVARNPV5BOT FOURNIE : ',XPOSXVARNPV5BOT
+ENDIF
+IF(INDXPOSYVARNPV5BOT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSYVARNPV5BOT,XPOSYVARNPV5BOT)
+ print *,' VALEUR XPOSYVARNPV5BOT FOURNIE : ',XPOSYVARNPV5BOT
+ENDIF
+IF(INDXSZVARNPVTOP /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZVARNPVTOP,XSZVARNPVTOP)
+ print *,' VALEUR XSZVARNPVTOP FOURNIE : ',XSZVARNPVTOP
+ENDIF
+IF(INDXSZVARNPVBOT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZVARNPVBOT,XSZVARNPVBOT)
+ print *,' VALEUR XSZVARNPVBOT FOURNIE : ',XSZVARNPVBOT
+ENDIF
+IF(INDXAMX /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXAMX,XAMX)
+ print *,' VALEUR XAMX FOURNIE : ',XAMX
+ENDIF
+IF(INDXLWTRACECV /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWTRACECV,XLWTRACECV)
+ print *,' VALEUR XLWTRACECV FOURNIE : ',XLWTRACECV
+ENDIF
+IF(INDXLWDOMAIN /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWDOMAIN,XLWDOMAIN)
+ print *,' VALEUR XLWDOMAIN FOURNIE : ',XLWDOMAIN
+ENDIF
+IF(INDXLWSEGM /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWSEGM,XLWSEGM)
+ print *,' VALEUR XLWSEGM FOURNIE : ',XLWSEGM
+ENDIF
+IF(INDXLWFTALL /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWFTALL,XLWFTALL)
+ print *,' VALEUR XLWFTALL FOURNIE : ',XLWFTALL
+ENDIF
+IF(INDXLWV /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWV,XLWV)
+ print *,' VALEUR XLWV FOURNIE : ',XLWV
+ENDIF
+IF(INDXLW /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLW,XLW)
+ print *,' VALEUR XLW FOURNIE : ',XLW
+ENDIF
+IF(INDXLW1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLW1,XLW1)
+ print *,' VALEUR XLW1 FOURNIE : ',XLW1
+ENDIF
+IF(INDXLW2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLW2,XLW2)
+ print *,' VALEUR XLW2 FOURNIE : ',XLW2
+ENDIF
+IF(INDXLW3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLW3,XLW3)
+ print *,' VALEUR XLW3 FOURNIE : ',XLW3
+ENDIF
+IF(INDXLW4 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLW4,XLW4)
+ print *,' VALEUR XLW4 FOURNIE : ',XLW4
+ENDIF
+IF(INDXLWPV1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV1,XLWPV1)
+ print *,' VALEUR XLWPV1 FOURNIE : ',XLWPV1
+ENDIF
+IF(INDXLWPV2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV2,XLWPV2)
+ print *,' VALEUR XLWPV2 FOURNIE : ',XLWPV2
+ENDIF
+IF(INDXLWPV3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV3,XLWPV3)
+ print *,' VALEUR XLWPV3 FOURNIE : ',XLWPV3
+ENDIF
+IF(INDXLWPV4 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV4,XLWPV4)
+ print *,' VALEUR XLWPV4 FOURNIE : ',XLWPV4
+ENDIF
+IF(INDXLWPV5 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV5,XLWPV5)
+ print *,' VALEUR XLWPV5 FOURNIE : ',XLWPV5
+ENDIF
+IF(INDXLWPV6 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV6,XLWPV6)
+ print *,' VALEUR XLWPV6 FOURNIE : ',XLWPV6
+ENDIF
+IF(INDXLWPV7 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV7,XLWPV7)
+ print *,' VALEUR XLWPV7 FOURNIE : ',XLWPV7
+ENDIF
+IF(INDXLWPV8 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV8,XLWPV8)
+ print *,' VALEUR XLWPV8 FOURNIE : ',XLWPV8
+ENDIF
+IF(INDXLWPV9 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV9,XLWPV9)
+ print *,' VALEUR XLWPV9 FOURNIE : ',XLWPV9
+ENDIF
+IF(INDXLWPV10 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV10,XLWPV10)
+ print *,' VALEUR XLWPV10 FOURNIE : ',XLWPV10
+ENDIF
+IF(INDXLWPV11 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV11,XLWPV11)
+ print *,' VALEUR XLWPV11 FOURNIE : ',XLWPV11
+ENDIF
+IF(INDXLWPV12 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV12,XLWPV12)
+ print *,' VALEUR XLWPV12 FOURNIE : ',XLWPV12
+ENDIF
+IF(INDXLWPV13 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV13,XLWPV13)
+ print *,' VALEUR XLWPV13 FOURNIE : ',XLWPV13
+ENDIF
+IF(INDXLWPV14 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV14,XLWPV14)
+ print *,' VALEUR XLWPV14 FOURNIE : ',XLWPV14
+ENDIF
+IF(INDXLWPV15 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPV15,XLWPV15)
+ print *,' VALEUR XLWPV15 FOURNIE : ',XLWPV15
+ENDIF
+IF(INDXSTYLPV1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV1,XSTYLPV1)
+ print *,' VALEUR XSTYLPV1 FOURNIE : ',XSTYLPV1
+ENDIF
+IF(INDXSTYLPV2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV2,XSTYLPV2)
+ print *,' VALEUR XSTYLPV2 FOURNIE : ',XSTYLPV2
+ENDIF
+IF(INDXSTYLPV3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV3,XSTYLPV3)
+ print *,' VALEUR XSTYLPV3 FOURNIE : ',XSTYLPV3
+ENDIF
+IF(INDXSTYLPV4 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV4,XSTYLPV4)
+ print *,' VALEUR XSTYLPV4 FOURNIE : ',XSTYLPV4
+ENDIF
+IF(INDXSTYLPV5 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV5,XSTYLPV5)
+ print *,' VALEUR XSTYLPV5 FOURNIE : ',XSTYLPV5
+ENDIF
+IF(INDXSTYLPV6 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV6,XSTYLPV6)
+ print *,' VALEUR XSTYLPV6 FOURNIE : ',XSTYLPV6
+ENDIF
+IF(INDXSTYLPV7 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV7,XSTYLPV7)
+ print *,' VALEUR XSTYLPV7 FOURNIE : ',XSTYLPV7
+ENDIF
+IF(INDXSTYLPV8 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV8,XSTYLPV8)
+ print *,' VALEUR XSTYLPV8 FOURNIE : ',XSTYLPV8
+ENDIF
+IF(INDXSTYLPV9 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV9,XSTYLPV9)
+ print *,' VALEUR XSTYLPV9 FOURNIE : ',XSTYLPV9
+ENDIF
+IF(INDXSTYLPV11 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV11,XSTYLPV11)
+ print *,' VALEUR XSTYLPV11 FOURNIE : ',XSTYLPV11
+ENDIF
+IF(INDXSTYLPV12 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV12,XSTYLPV12)
+ print *,' VALEUR XSTYLPV12 FOURNIE : ',XSTYLPV12
+ENDIF
+IF(INDXSTYLPV13 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV13,XSTYLPV13)
+ print *,' VALEUR XSTYLPV13 FOURNIE : ',XSTYLPV13
+ENDIF
+IF(INDXSTYLPV14 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV14,XSTYLPV14)
+ print *,' VALEUR XSTYLPV14 FOURNIE : ',XSTYLPV14
+ENDIF
+IF(INDXSTYLPV15 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXSTYLPV15,XSTYLPV15)
+ print *,' VALEUR XSTYLPV15 FOURNIE : ',XSTYLPV15
+ENDIF
+IF(INDXXL /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXXL,XXL)
+ print *,' VALEUR XXL FOURNIE : ',XXL
+ENDIF
+IF(INDXXH /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXXH,XXH)
+ print *,' VALEUR XXH FOURNIE : ',XXH
+ENDIF
+IF(INDXYL /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYL,XYL)
+ print *,' VALEUR XYL FOURNIE : ',XYL
+ENDIF
+IF(INDXYH /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXYH,XYH)
+ print *,' VALEUR XYH FOURNIE : ',XYH
+ENDIF
+IF(INDXZL /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXZL,XZL)
+ print *,' VALEUR XZL FOURNIE : ',XZL
+ENDIF
+IF(INDXZH /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXZH,XZH)
+ print *,' VALEUR XZH FOURNIE : ',XZH
+ENDIF
+IF(INDXLWVDEF /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWVDEF,XLWVDEF)
+ print *,' VALEUR XLWVDEF FOURNIE : ',XLWVDEF
+ENDIF
+IF(INDXLWDEF /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWDEF,XLWDEF)
+ print *,' VALEUR XLWDEF FOURNIE : ',XLWDEF
+ENDIF
+IF(INDXLWCONT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWCONT,XLWCONT)
+ print *,' VALEUR XLWCONT FOURNIE : ',XLWCONT
+ENDIF
+IF(INDXLWPH1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPH1,XLWPH1)
+ print *,' VALEUR XLWPH1 FOURNIE : ',XLWPH1
+ENDIF
+IF(INDXLWPH2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPH2,XLWPH2)
+ print *,' VALEUR XLWPH2 FOURNIE : ',XLWPH2
+ENDIF
+IF(INDXLWPH3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPH3,XLWPH3)
+ print *,' VALEUR XLWPH3 FOURNIE : ',XLWPH3
+ENDIF
+IF(INDXLWPH4 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPH4,XLWPH4)
+ print *,' VALEUR XLWPH4 FOURNIE : ',XLWPH4
+ENDIF
+IF(INDXLWPH5 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPH5,XLWPH5)
+ print *,' VALEUR XLWPH5 FOURNIE : ',XLWPH5
+ENDIF
+IF(INDXLWPH6 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPH6,XLWPH6)
+ print *,' VALEUR XLWPH6 FOURNIE : ',XLWPH6
+ENDIF
+IF(INDXLWPH7 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPH7,XLWPH7)
+ print *,' VALEUR XLWPH7 FOURNIE : ',XLWPH7
+ENDIF
+IF(INDXLWPH8 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWPH8,XLWPH8)
+ print *,' VALEUR XLWPH8 FOURNIE : ',XLWPH8
+ENDIF
+IF(INDXVHC /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVHC,XVHC)
+ print *,' VALEUR XVHC FOURNIE : ',XVHC
+ENDIF
+IF(INDXVHCPH /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVHCPH,XVHCPH)
+ print *,' VALEUR XVHCPH FOURNIE : ',XVHCPH
+ENDIF
+IF(INDXVLC /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVLC,XVLC)
+ print *,' VALEUR XVLC FOURNIE : ',XVLC
+ENDIF
+IF(INDXVRL /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVRL,XVRL)
+ print *,' VALEUR XVRL FOURNIE : ',XVRL
+ENDIF
+IF(INDXVRLPH /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVRLPH,XVRLPH)
+ print *,' VALEUR XVRLPH FOURNIE : ',XVRLPH
+ENDIF
+IF(INDXIRS /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXIRS,XIRS)
+ print *,' VALEUR XIRS FOURNIE : ',XIRS
+ GXI=.TRUE.
+ENDIF
+IF(INDXJRS /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXJRS,XJRS)
+ print *,' VALEUR XJRS FOURNIE : ',XJRS
+ GXJ=.TRUE.
+ENDIF
+!
+IF(INDXFT1LW1 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW1,XFT1LW1)
+ PRINT *,' XFT1LW1 FOURNI ',XFT1LW1
+ENDIF
+IF(INDXFT1LW2 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW2,XFT1LW2)
+ PRINT *,' XFT1LW2 FOURNI ',XFT1LW2
+ENDIF
+IF(INDXFT1LW3 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW3,XFT1LW3)
+ PRINT *,' XFT1LW3 FOURNI ',XFT1LW3
+ENDIF
+IF(INDXFT1LW4 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW4,XFT1LW4)
+ PRINT *,' XFT1LW4 FOURNI ',XFT1LW4
+ENDIF
+IF(INDXFT1LW5 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW5,XFT1LW5)
+ PRINT *,' XFT1LW5 FOURNI ',XFT1LW5
+ENDIF
+IF(INDXFT1LW6 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW6,XFT1LW6)
+ PRINT *,' XFT1LW6 FOURNI ',XFT1LW6
+ENDIF
+IF(INDXFT1LW7 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW7,XFT1LW7)
+ PRINT *,' XFT1LW7 FOURNI ',XFT1LW7
+ENDIF
+IF(INDXFT1LW8 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW8,XFT1LW8)
+ PRINT *,' XFT1LW8 FOURNI ',XFT1LW8
+ENDIF
+IF(INDXFT1LW9 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW9,XFT1LW9)
+ PRINT *,' XFT1LW9 FOURNI ',XFT1LW9
+ENDIF
+IF(INDXFT1LW10 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW10,XFT1LW10)
+ PRINT *,' XFT1LW10 FOURNI ',XFT1LW10
+ENDIF
+IF(INDXFT1LW11 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW11,XFT1LW11)
+ PRINT *,' XFT1LW11 FOURNI ',XFT1LW11
+ENDIF
+IF(INDXFT1LW12 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW12,XFT1LW12)
+ PRINT *,' XFT1LW12 FOURNI ',XFT1LW12
+ENDIF
+IF(INDXFT1LW13 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW13,XFT1LW13)
+ PRINT *,' XFT1LW13 FOURNI ',XFT1LW13
+ENDIF
+IF(INDXFT1LW14 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW14,XFT1LW14)
+ PRINT *,' XFT1LW14 FOURNI ',XFT1LW14
+ENDIF
+IF(INDXFT1LW15 /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1LW15,XFT1LW15)
+ PRINT *,' XFT1LW15 FOURNI ',XFT1LW15
+ENDIF
+!
+IF(GXI .AND. GXJ)THEN
+ CALL SM_XYHAT_S(XLATORI,XLONORI,XIRS,XJRS,ZX,ZY)
+! Modif 19/4/99 !!!!!!!!!!!!
+ XIRSCC=ZX
+ XJRSCC=ZY
+
+! DO J=2,SIZE(XXHAT)
+! IF(ZX >= XXX(j-1,1) .AND. ZX <XXX(J,1))EXIT
+! ENDDO
+! JJ=J
+! IF(ABS(ZX-XXX(JJ-1,1)) <= ABS(ZX-XXX(JJ,1)))THEN
+! NIRS=JJ-1
+! ELSE
+! NIRS=JJ
+! ENDIF
+! DO J=2,SIZE(XYHAT)
+! IF(ZY >= XXY(J-1,1) .AND. ZY <XXY(J,1))EXIT
+! ENDDO
+! JJ=J
+! IF(ABS(ZY-XXY(JJ-1,1)) <= ABS(ZY-XXY(JJ,1)))THEN
+! NJRS=JJ-1
+! ELSE
+! NJRS=JJ
+! ENDIF
+ print *,' Conversion lat,long:',XIRS,',',XJRS,' origine du profil en coordonnees conformes :'
+ print *,' CCX=',XIRSCC,' CCY=',XJRSCC
+
+! print *,' Conversion lat,long:',XIRS,',',XJRS,' origine du profil en points de grille : '
+! print *,' NIRS=',NIRS,' NJRS=',NJRS,' (valeurs anterieures ecrasees)'
+! Modif 19/4/99 !!!!!!!!!!!!
+ GXI=.FALSE.; GXJ=.FALSE.
+ENDIF
+IF(INDXPVMIN /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPVMIN,XPVMINTRUE)
+ print *,' VALEUR XPVMIN FOURNIE : ',XPVMINTRUE
+ CALL LOADMNMX_FT_PVKT(YCARIN(1:LEN_TRIM(YCARIN)),INDXPVMIN,XPVMINTRUE,1)
+ENDIF
+IF(INDXPVMAX /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPVMAX,XPVMAXTRUE)
+ print *,' VALEUR XPVMAX FOURNIE : ',XPVMAXTRUE
+ CALL LOADMNMX_FT_PVKT(YCARIN(1:LEN_TRIM(YCARIN)),INDXPVMAX,XPVMAXTRUE,2)
+ENDIF
+IF(INDXPVMINT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPVMINT,XPVMINT)
+ print *,' VALEUR XPVMINT FOURNIE : ',XPVMINT
+ENDIF
+IF(INDXPVMAXT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPVMAXT,XPVMAXT)
+ print *,' VALEUR XPVMAXT FOURNIE : ',XPVMAXT
+ENDIF
+IF(INDXFT_ADTIM1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT_ADTIM1,XFT_ADTIM1)
+ print *,' VALEUR XFT_ADTIM1 FOURNIE : ',XFT_ADTIM1
+ENDIF
+IF(INDXFT_ADTIM2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT_ADTIM2,XFT_ADTIM2)
+ print *,' VALEUR XFT_ADTIM2 FOURNIE : ',XFT_ADTIM2
+ENDIF
+IF(INDXFT_ADTIM3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT_ADTIM3,XFT_ADTIM3)
+ print *,' VALEUR XFT_ADTIM3 FOURNIE : ',XFT_ADTIM3
+ENDIF
+IF(INDXFT_ADTIM4 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT_ADTIM4,XFT_ADTIM4)
+ print *,' VALEUR XFT_ADTIM4 FOURNIE : ',XFT_ADTIM4
+ENDIF
+IF(INDXFT_ADTIM5 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT_ADTIM5,XFT_ADTIM5)
+ print *,' VALEUR XFT_ADTIM5 FOURNIE : ',XFT_ADTIM5
+ENDIF
+IF(INDXFT_ADTIM6 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT_ADTIM6,XFT_ADTIM6)
+ print *,' VALEUR XFT_ADTIM6 FOURNIE : ',XFT_ADTIM6
+ENDIF
+IF(INDXFT_ADTIM7 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT_ADTIM7,XFT_ADTIM7)
+ print *,' VALEUR XFT_ADTIM7 FOURNIE : ',XFT_ADTIM7
+ENDIF
+IF(INDXFT_ADTIM8 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT_ADTIM8,XFT_ADTIM8)
+ print *,' VALEUR XFT_ADTIM8 FOURNIE : ',XFT_ADTIM8
+ENDIF
+IF(INDXFT1_ADTIM1 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1_ADTIM1,XFT1_ADTIM1)
+ print *,' VALEUR XFT1_ADTIM1 FOURNIE : ',XFT1_ADTIM1
+ENDIF
+IF(INDXFT1_ADTIM2 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1_ADTIM2,XFT1_ADTIM2)
+ print *,' VALEUR XFT1_ADTIM2 FOURNIE : ',XFT1_ADTIM2
+ENDIF
+IF(INDXFT1_ADTIM3 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1_ADTIM3,XFT1_ADTIM3)
+ print *,' VALEUR XFT1_ADTIM3 FOURNIE : ',XFT1_ADTIM3
+ENDIF
+IF(INDXFT1_ADTIM4 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1_ADTIM4,XFT1_ADTIM4)
+ print *,' VALEUR XFT1_ADTIM4 FOURNIE : ',XFT1_ADTIM4
+ENDIF
+IF(INDXFT1_ADTIM5 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1_ADTIM5,XFT1_ADTIM5)
+ print *,' VALEUR XFT1_ADTIM5 FOURNIE : ',XFT1_ADTIM5
+ENDIF
+IF(INDXFT1_ADTIM6 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1_ADTIM6,XFT1_ADTIM6)
+ print *,' VALEUR XFT1_ADTIM6 FOURNIE : ',XFT1_ADTIM6
+ENDIF
+IF(INDXFT1_ADTIM7 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1_ADTIM7,XFT1_ADTIM7)
+ print *,' VALEUR XFT1_ADTIM7 FOURNIE : ',XFT1_ADTIM7
+ENDIF
+IF(INDXFT1_ADTIM8 /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1_ADTIM8,XFT1_ADTIM8)
+ print *,' VALEUR XFT1_ADTIM8 FOURNIE : ',XFT1_ADTIM8
+ENDIF
+IF(INDXFTMIN /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFTMIN,XFTMIN)
+ print *,' VALEUR XFTMIN FOURNIE : ',XFTMIN
+ CALL LOADMNMX_FT_PVKT(YCARIN(1:LEN_TRIM(YCARIN)),INDXFTMIN,XFTMIN,1)
+ENDIF
+IF(INDXFTMAX /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFTMAX,XFTMAX)
+ print *,' VALEUR XFTMAX FOURNIE : ',XFTMAX
+ CALL LOADMNMX_FT_PVKT(YCARIN(1:LEN_TRIM(YCARIN)),INDXFTMAX,XFTMAX,2)
+ENDIF
+IF(INDXFT1MIN /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1MIN,XFT1MIN)
+ print *,' VALEUR XFT1MIN FOURNIE : ',XFT1MIN
+ENDIF
+IF(INDXFT1MAX /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1MAX,XFT1MAX)
+ print *,' VALEUR XFT1MAX FOURNIE : ',XFT1MAX
+ENDIF
+IF(INDXFT1MIN_ /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1MIN_,XFTMIN)
+ print *,' VALEUR XFT1MIN FOURNIE : ',XFTMIN
+ CALL LOADMNMX_FT_PVKT(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1MIN_,XFTMIN,5)
+ENDIF
+IF(INDXFT1MAX_ /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1MAX_,XFTMAX)
+ print *,' VALEUR XFT1MAX FOURNIE : ',XFTMAX
+ CALL LOADMNMX_FT_PVKT(YCARIN(1:LEN_TRIM(YCARIN)),INDXFT1MAX_,XFTMAX,6)
+ENDIF
+IF(INDXPVKTMIN /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPVKTMIN,XPVKTMIN)
+ print *,' VALEUR XPVKTMIN FOURNIE : ',XPVKTMIN
+ CALL LOADMNMX_FT_PVKT(YCARIN(1:LEN_TRIM(YCARIN)),INDXPVKTMIN,XPVKTMIN,3)
+ENDIF
+IF(INDXPVKTMAX /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXPVKTMAX,XPVKTMAX)
+ print *,' VALEUR XPVKTMAX FOURNIE : ',XPVKTMAX
+ CALL LOADMNMX_FT_PVKT(YCARIN(1:LEN_TRIM(YCARIN)),INDXPVKTMAX,XPVKTMAX,4)
+ENDIF
+IF(INDXVARMIN /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVARMIN,XVARMIN)
+ print *,' VALEUR XVARMIN FOURNIE : ',XVARMIN
+ENDIF
+IF(INDXVARMAX /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVARMAX,XVARMAX)
+ print *,' VALEUR XVARMAX FOURNIE : ',XVARMAX
+ENDIF
+IF(INDXZTMIN /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXZTMIN,XZTMIN)
+ print *,' VALEUR XZTMIN FOURNIE : ',XZTMIN
+ENDIF
+IF(INDXZTMAX /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXZTMAX,XZTMAX)
+ print *,' VALEUR XZTMAX FOURNIE : ',XZTMAX
+ENDIF
+IF(INDXVPTL /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTL,XVPTL)
+ print *,' VALEUR XVPTL FOURNIE : ',XVPTL
+ENDIF
+IF(INDXVPTR /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTR,XVPTR)
+ print *,' VALEUR XVPTR FOURNIE : ',XVPTR
+ENDIF
+IF(INDXVPTB /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTB,XVPTB)
+ print *,' VALEUR XVPTB FOURNIE : ',XVPTB
+ENDIF
+IF(INDXVPTT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTT,XVPTT)
+ print *,' VALEUR XVPTT FOURNIE : ',XVPTT
+ENDIF
+IF(INDXVPTVL /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTVL,XVPTVL)
+ print *,' VALEUR XVPTVL FOURNIE : ',XVPTVL
+ENDIF
+IF(INDXVPTVR /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTVR,XVPTVR)
+ print *,' VALEUR XVPTVR FOURNIE : ',XVPTVR
+ENDIF
+IF(INDXVPTVB /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTVB,XVPTVB)
+ print *,' VALEUR XVPTVB FOURNIE : ',XVPTVB
+ENDIF
+IF(INDXVPTVT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTVT,XVPTVT)
+ print *,' VALEUR XVPTVT FOURNIE : ',XVPTVT
+ENDIF
+!!!!!!!!!!!!!!!!!
+IF(INDXVPTFT1L /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTFT1L,XVPTFT1L)
+ print *,' VALEUR XVPTFT1L FOURNIE : ',XVPTFT1L
+ENDIF
+IF(INDXVPTFT1R /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTFT1R,XVPTFT1R)
+ print *,' VALEUR XVPTFT1R FOURNIE : ',XVPTFT1R
+ENDIF
+IF(INDXVPTFT1B /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTFT1B,XVPTFT1B)
+ print *,' VALEUR XVPTFT1B FOURNIE : ',XVPTFT1B
+ENDIF
+IF(INDXVPTFT1T /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTFT1T,XVPTFT1T)
+ print *,' VALEUR XVPTFT1T FOURNIE : ',XVPTFT1T
+ENDIF
+!!!!!!!!!!!!!!!!!
+IF(INDXVPTPVL /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTPVL,XVPTPVL)
+ print *,' VALEUR XVPTPVL FOURNIE : ',XVPTPVL
+ENDIF
+IF(INDXVPTPVR /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTPVR,XVPTPVR)
+ print *,' VALEUR XVPTPVR FOURNIE : ',XVPTPVR
+ENDIF
+IF(INDXVPTPVB /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTPVB,XVPTPVB)
+ print *,' VALEUR XVPTPVB FOURNIE : ',XVPTPVB
+ENDIF
+IF(INDXVPTPVT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTPVT,XVPTPVT)
+ print *,' VALEUR XVPTPVT FOURNIE : ',XVPTPVT
+ENDIF
+IF(INDXVPTXYL /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTXYL,XVPTXYL)
+ print *,' VALEUR XVPTXYL FOURNIE : ',XVPTXYL
+ENDIF
+IF(INDXVPTXYR /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTXYR,XVPTXYR)
+ print *,' VALEUR XVPTXYR FOURNIE : ',XVPTXYR
+ENDIF
+IF(INDXVPTXYB /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTXYB,XVPTXYB)
+ print *,' VALEUR XVPTXYB FOURNIE : ',XVPTXYB
+ENDIF
+IF(INDXVPTXYT /=0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDXVPTXYT,XVPTXYT)
+ print *,' VALEUR XVPTXYT FOURNIE : ',XVPTXYT
+ENDIF
+IF(INDXISOLEV/=0)THEN
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXISOLEV,XISOLEV)
+ENDIF
+IF(INDXPARCOLUV/=0)THEN
+ XPARCOLUV(:)=9999.
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXPARCOLUV,XPARCOLUV)
+ DO J=SIZE(XPARCOLUV,1),1,-1
+ IF(XPARCOLUV(J) /= 9999.)then
+ NBPARCOLUV=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXISOLEV_ /= 0)THEN
+ ZISOLEV(:)=9999.
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXISOLEV_,ZISOLEV)
+ DO J=SIZE(ZISOLEV,1),1,-1
+ IF(ZISOLEV(J) /= 9999.)then
+ JM=J
+ EXIT
+ ENDIF
+ ENDDO
+ CALL LOADXISOLEVP(YCARIN(1:LEN_TRIM(YCARIN)),INDXISOLEV_,ZISOLEV(1:JM+1))
+ENDIF
+IF(INDXPORTRAD1/=0)THEN
+ NPORTRAD1=0
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXPORTRAD1,XPORTRAD1)
+ DO J=SIZE(XPORTRAD1,1),1,-1
+ IF(XPORTRAD1(J) /= 9999.)then
+ NPORTRAD1=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXPORTRAD2/=0)THEN
+ NPORTRAD2=0
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXPORTRAD2,XPORTRAD2)
+ DO J=SIZE(XPORTRAD2,1),1,-1
+ IF(XPORTRAD2(J) /= 9999.)then
+ NPORTRAD2=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXPORTRAD3/=0)THEN
+ NPORTRAD3=0
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXPORTRAD3,XPORTRAD3)
+ DO J=SIZE(XPORTRAD3,1),1,-1
+ IF(XPORTRAD3(J) /= 9999.)then
+ NPORTRAD3=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXPORTRAD4/=0)THEN
+ NPORTRAD4=0
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXPORTRAD4,XPORTRAD4)
+ DO J=SIZE(XPORTRAD4,1),1,-1
+ IF(XPORTRAD4(J) /= 9999.)then
+ NPORTRAD4=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXLWRAD1/=0)THEN
+ NLWRAD1=0
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWRAD1,XLWRAD1)
+ DO J=SIZE(XLWRAD1,1),1,-1
+ IF(XLWRAD1(J) /= 9999.)then
+ NLWRAD1=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXLWRAD2/=0)THEN
+ NLWRAD2=0
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWRAD2,XLWRAD2)
+ DO J=SIZE(XLWRAD2,1),1,-1
+ IF(XLWRAD2(J) /= 9999.)then
+ NLWRAD2=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXLWRAD3/=0)THEN
+ NLWRAD3=0
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWRAD3,XLWRAD3)
+ DO J=SIZE(XLWRAD3,1),1,-1
+ IF(XLWRAD3(J) /= 9999.)then
+ NLWRAD3=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXLWRAD4/=0)THEN
+ NLWRAD4=0
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXLWRAD4,XLWRAD4)
+ DO J=SIZE(XLWRAD4,1),1,-1
+ IF(XLWRAD4(J) /= 9999.)then
+ NLWRAD4=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXLONCAR/=0)THEN
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXLONCAR,XLONCAR)
+ DO J=SIZE(XLONCAR,1),1,-1
+ IF(XLONCAR(J) /= 9999.)then
+ NLPCAR=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXLATCAR/=0)THEN
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXLATCAR,XLATCAR)
+ DO J=SIZE(XLATCAR,1),1,-1
+ IF(XLATCAR(J) /= 9999.)then
+ NLPCAR=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXICAR/=0)THEN
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXICAR,XICAR)
+ DO J=SIZE(XICAR,1),1,-1
+ IF(XICAR(J) /= 9999.)then
+ NIJCAR=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXJCAR/=0)THEN
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXJCAR,XJCAR)
+ DO J=SIZE(XJCAR,1),1,-1
+ IF(XJCAR(J) /= 9999.)then
+ NIJCAR=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+IF(INDXXPART/=0)THEN
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXXPART,XXPART)
+ DO J=SIZE(XXPART,1),1,-1
+ IF(XXPART(J) /= 9999.)then
+ NPART=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXYPART/=0)THEN
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXYPART,XYPART)
+ DO J=SIZE(XYPART,1),1,-1
+ IF(XYPART(J) /= 9999.)then
+ NPART=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXZPART/=0)THEN
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXZPART,XZPART)
+ DO J=SIZE(XZPART,1),1,-1
+ IF(XZPART(J) /= 9999.)then
+ NPART=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!JD Mars2009
+IF(INDCVARNPV1 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV1=' '
+ ELSE
+ print *,' AV read CVARNPV1 ',CVARNPV1
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV1(1:LEN(CVARNPV1))
+! CVARNPV1=ADJUSTL(YCARIN(INDQ1+1:INDQ2-1))
+ ENDIF
+ print *,' CVARNPV1 AP ',CVARNPV1
+! print *,' YCARIN(1:ILENC), ILENC,INDQ1,INDQ2 ',YCARIN(1:ILENC),ILENC,INDQ1,INDQ2
+ENDIF
+IF(INDCVARNPV2 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV2=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV2
+ ENDIF
+ENDIF
+IF(INDCVARNPV3 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV3=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV3
+ ENDIF
+ENDIF
+IF(INDCVARNPV4 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV4=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV4
+ ENDIF
+ENDIF
+IF(INDCVARNPV5 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV5=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV5
+ ENDIF
+ENDIF
+IF(INDCVARNPV6 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV6=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV6
+ ENDIF
+ENDIF
+IF(INDCVARNPV7 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV7=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV7
+ ENDIF
+ENDIF
+IF(INDCVARNPV8 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV8=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV8
+ ENDIF
+ENDIF
+IF(INDCVARNPV9 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV9=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV9
+ ENDIF
+ENDIF
+IF(INDCVARNPV10 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV10=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV10
+ ENDIF
+ENDIF
+IF(INDCVARNPV11 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV11=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV11
+ ENDIF
+ENDIF
+IF(INDCVARNPV12 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV12=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV12
+ ENDIF
+ENDIF
+IF(INDCVARNPV13 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV13=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV13
+ ENDIF
+ENDIF
+IF(INDCVARNPV14 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV14=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV14
+ ENDIF
+ENDIF
+IF(INDCVARNPV15 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPV15=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPV15
+ ENDIF
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF(INDCVARNPH1 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPH1=' '
+ ELSE
+ print *,' AV read CVARNPH1 ',CVARNPH1
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPH1(1:LEN(CVARNPH1))
+ ENDIF
+ print *,' CVARNPH1 AP ',CVARNPH1
+ENDIF
+IF(INDCVARNPH2 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPH2=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPH2
+ ENDIF
+ENDIF
+IF(INDCVARNPH3 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPH3=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPH3
+ ENDIF
+ENDIF
+IF(INDCVARNPH4 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPH4=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPH4
+ ENDIF
+ENDIF
+IF(INDCVARNPH5 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPH5=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPH5
+ ENDIF
+ENDIF
+IF(INDCVARNPH6 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPH6=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPH6
+ ENDIF
+ENDIF
+IF(INDCVARNPH7 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPH7=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPH7
+ ENDIF
+ENDIF
+IF(INDCVARNPH8 /=0)THEN
+ INDQ1=INDEX(YCARIN,"'")
+ INDQ2=INDEX(YCARIN(INDQ1+1:ILENC),"'")
+ INDQ2=INDQ1+INDQ2
+ IF(YCARIN(INDQ1+1:INDQ2-1) == ' ')THEN
+ CVARNPH8=' '
+ ELSE
+ READ(YCARIN(INDQ1+1:INDQ2-1),'(A22)')CVARNPH8
+ ENDIF
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IF(INDCNOMCAR /=0)THEN
+ IND9999=INDEX(YCARIN(1:ILENC),'9999.')
+ INBV=0
+ DO J=1,ILENC
+ IF(YCARIN(J:J) == '=')THEN
+ JM=J+1
+ EXIT
+ ENDIF
+ ENDDO
+ DO J=JM,ILENC
+ IF(YCARIN(J:J) == ',')THEN
+ INBV=INBV+1
+ ENDIF
+ ENDDO
+ IF(IND9999 == 0)THEN
+ NOMCAR=INBV+1
+ ELSE
+ NOMCAR=INBV
+ ENDIF
+ CNOMCAR(:)=' '
+ if(nverbia > 0)then
+ print *,' NOMCAR CNOMCAR YCARIN(JM:ILENC) ',NOMCAR,JM,ILENC
+ print *,CNOMCAR
+ print *,YCARIN(JM:ILENC)
+ endif
+ READ(YCARIN(JM:ILENC+2),*)(CNOMCAR(J),J=1,NOMCAR)
+ print *,' NOMCAR CNOMCAR ',NOMCAR
+ print *,(CNOMCAR(J),J=1,NOMCAR)
+ENDIF
+IF(INDCSYMCAR /=0)THEN
+ if(nverbia > 0)then
+ print *,' *** CARESOLV ILENC YCARIN(1:ILENC) ',ILENC,YCARIN(1:ILENC)
+ endif
+ IND9999=INDEX(YCARIN(1:ILENC),'9999.')
+ INBV=0
+ DO J=1,ILENC
+ IF(YCARIN(J:J) == '=')THEN
+ JM=J+1
+ EXIT
+ ENDIF
+ ENDDO
+ DO J=JM,ILENC
+ IF(YCARIN(J:J) == ',')THEN
+ INBV=INBV+1
+ ENDIF
+ ENDDO
+ IF(IND9999 == 0)THEN
+ NSYMCAR=INBV+1
+ ELSE
+ NSYMCAR=INBV
+ ENDIF
+ CSYMCAR(:)='.'
+ if(nverbia > 0)then
+ print *,' NSYMCAR CSYMCAR YCARIN(JM:ILENC) ',NSYMCAR,JM,ILENC
+ print *,CSYMCAR
+ print *,YCARIN(JM:ILENC)
+ endif
+! READ(YCARIN,*)(CSYMCAR(J),J=1,NSYMCAR)
+ READ(YCARIN(JM:ILENC+2),*)(CSYMCAR(J),J=1,NSYMCAR)
+ print *,' NSYMCAR CSYMCAR ',NSYMCAR
+ print *,(CSYMCAR(J),J=1,NSYMCAR)
+ENDIF
+IF(INDXPOSNOM /=0)THEN
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXPOSNOM,XPOSNOM)
+ DO J=SIZE(XPOSNOM,1),1,-1
+ IF(XPOSNOM(J) /= 9999.)then
+ NPOSNOM=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDXSZNOM /=0)THEN
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZNOM,XSZNOM)
+ DO J=SIZE(XSZNOM,1),1,-1
+ IF(XSZNOM(J) /= 9999.)then
+ NSZNOM=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!! pour les retrotrajectoires !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF(INDNSZRTRAJ /= 0)THEN
+ CALL RESOLVX(YCARIN(1:LEN_TRIM(YCARIN)),INDNSZRTRAJ,NSZRTRAJ)
+ PRINT *,' NSZRTRAJ FOURNI ',NSZRTRAJ
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF(INDXSZSYM /=0)THEN
+ CALL RESOLVXISOLEV(YCARIN(1:LEN_TRIM(YCARIN)),INDXSZSYM,XSZSYM)
+ DO J=SIZE(XSZSYM,1),1,-1
+ IF(XSZSYM(J) /= 9999.)then
+ NSZSYM=J
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDICOLNOM /=0)THEN
+ CALL RESOLVIARRAY(YCARIN(1:LEN_TRIM(YCARIN)),INDICOLNOM,ICOLNOM,NCOLNOM)
+ENDIF
+IF(INDICOLSYM /=0)THEN
+ CALL RESOLVIARRAY(YCARIN(1:LEN_TRIM(YCARIN)),INDICOLSYM,ICOLSYM,NCOLSYM)
+ENDIF
+IF(INDNINDCOLUV /=0)THEN
+ CALL RESOLVIARRAY(YCARIN(1:LEN_TRIM(YCARIN)),INDNINDCOLUV,NINDCOLUV,NBCOLUV)
+ENDIF
+
+INDIM=999
+IT(1)=INDIINF; IT(2)=INDJINF; IT(3)=INDISUP; IT(4)=INDJSUP
+IT(5)=INDIDEBCOU; IT(6)=INDJDEBCOU; IT(7)=INDXIDEBCOU; IT(8)=INDXJDEBCOU
+IT(9)=INDNLANGLE; IT(10)=INDNLMAX; IT(11)=INDNIOFFD; IT(12)=INDNULBLL
+IT(13)=INDNHI; IT(14)=INDNIMNMX; IT(15)=INDXDIAINT; IT(16)=INDLXY;
+IT(17)=INDLXZ; IT(18)=INDLISO; IT(19)=INDLMINMAX; IT(20)=INDATFILE;
+IT(21)=INDLCOLAREA; IT(22)=INDLCOLINE; IT(23)=INDLISOWHI; IT(24)=INDLCOLBR;
+IT(25)=INDLCOLAREASEL; IT(26)=INDLCOLINESEL; IT(27)=INDLTABCOLDEF
+IT(28)=INDNIFDC; IT(29)=INDNIGRNC; IT(30)=INDXHMIN; IT(31)=INDXHMAX
+IT(32)=INDXISOMIN; IT(33)=INDXISOMAX; IT(34)=INDVISU; IT(35)=INDNOVISU
+IT(36)=INDXSIZEL; IT(37)=INDNPROFILE; IT(38)=INDXPVMIN; IT(39)=INDXPVMAX
+IT(40)=INDXISOLEV; IT(41)=INDXFTMIN; IT(42)=INDXFTMAX; IT(43)=INDXPVKTMIN
+IT(44)=INDXPVKTMAX; IT(45)=INDLMNMXUSER; IT(46)=INDLCOLUSER;
+IT(47)=INDNIRS; IT(48)=INDNJRS; IT(49)=INDXIRS; IT(50)=INDXJRS
+IT(51)=INDXAMX; IT(52)=INDXVHC; IT(53)=INDXVRL; IT(54)=INDNDOT
+IT(55)=INDNISKIP; IT(56)=INDXLATCAR; IT(57)=INDXLONCAR; IT(58)=INDLVECTMNMX
+IT(59)=INDLANIMK; IT(60)=INDLANIMT; IT(61)=INDLPRINT; IT(62)=INDLPOINTG
+IT(63)=INDL2DBX; IT(64)=INDL2DBY; IT(65)=INDXISOMIN_; IT(66)=INDXISOMAX_
+IT(67)=INDXDIAINT_; IT(68)=INDXVARMIN; IT(69)=INDXVARMAX
+IT(70)=INDXZTMIN; IT(71)=INDXZTMAX; IT(72)=INDLXYO; IT(73)=INDLPRINTXY
+IT(74)=INDXFT1MIN; IT(75)=INDXFT1MAX; IT(76)=INDXFT1MIN_; IT(77)=INDXFT1MAX_
+IT(78)=INDLVPTUSER; IT(79)=INDLVPTVUSER; IT(80)=INDLVPTPVUSER
+IT(81)=INDXVPTL; IT(82)=INDXVPTR; IT(83)=INDXVPTB; IT(84)=INDXVPTT
+IT(85)=INDXVPTVL; IT(86)=INDXVPTVR; IT(87)=INDXVPTVB; IT(88)=INDXVPTVT
+IT(89)=INDXVPTPVL; IT(90)=INDXVPTPVR; IT(91)=INDXVPTPVB; IT(92)=INDXVPTPVT
+IT(93)=INDXLWV; IT(94)=INDXLWVDEF; IT(95)=INDXLWDEF
+IT(96)=INDXLW; IT(97)=INDXLW1; IT(98)=INDXLW2; IT(99)=INDXLW3; IT(100)=INDXLW4
+IT(101)=INDLCOLZERO; IT(102)=INDNCOLZERO; IT(103)=INDLHACH1; IT(104)=INDLHACH2
+IT(105)=INDLHACH3; IT(106)=INDLHACH4; IT(107)=INDLHACHSEL
+IT(108)=INDLABEL1; IT(109)=INDLBLUSER1; IT(110)=INDLBLUSER2
+IT(111)=INDLBLUSER3; IT(112)=INDLBLUSER4; IT(113)=INDLXABSC; IT(114)=INDLXMINTOP
+IT(115)=INDLINDSP; IT(116)=INDLOGNEP; IT(117)=INDLTABCOLDEF2
+IT(118)=INDLCONT; IT(119)=INDLRELIEF; IT(120)=INDLCONV2XY
+IT(121)=INDXPVMINT; IT(122)=INDXPVMAXT
+IT(123)=INDXVPTXYL; IT(124)=INDXVPTXYR; IT(125)=INDXVPTXYB; IT(126)=INDXVPTXYT
+IT(127)=INDLVPTXYUSER; IT(128)=INDNVERBIA; IT(129)=INDLINVWB
+IT(130)=INDLISOWHI2; IT(131)=INDLISOWHI3; IT(132)=INDXISOLEV_
+IT(133)=INDXSPVAL; IT(134)=INDLGEOG
+IT(135)=INDNFT1ITVXMJ;IT(136)=INDNFT1ITVXMN;IT(137)=INDNFT1ITVYMJ
+IT(138)=INDNFT1ITVYMN
+IT(139)=INDNFTITVXMJ;IT(140)=INDNFTITVXMN;IT(141)=INDNFTITVYMJ
+IT(142)=INDNFTITVYMN
+IT(143)=INDNCHITVXMJ;IT(144)=INDNCHITVXMN;IT(145)=INDNCHITVYMJ
+IT(146)=INDNCHITVYMN
+IT(147)=INDNCHPCITVXMJ;IT(148)=INDNCHPCITVXMN;IT(149)=INDNCHPCITVYMJ
+IT(150)=INDNCHPCITVYMN; IT(151)=INDLFT1STYLUSER
+IT(152)=INDNCVITVXMJ;IT(153)=INDNCVITVXMN;IT(154)=INDNCVITVYMJ;IT(155)=INDNCVITVYMN
+IT(156)=INDNPVITVXMJ;IT(157)=INDNPVITVXMN;IT(158)=INDNPVITVYMJ;IT(159)=INDNPVITVYMN
+IT(160)=INDNXYITVXMJ;IT(161)=INDNXYITVXMN;IT(162)=INDNXYITVYMJ;IT(163)=INDNXYITVYMN
+IT(164)=INDNMASKITVXMJ;IT(165)=INDNMASKITVXMN;IT(166)=INDNMASKITVYMJ;IT(167)=INDNMASKITVYMN
+IT(168)=INDLFTSTYLUSER;IT(169)=INDXSZTITXL;IT(170)=INDXSZTITXM;IT(171)=INDXSZTITXR
+IT(172)=INDLDEFCV2;IT(173)=INDLDEFCV2LL;IT(174)=INDLDEFCV2IND
+IT(175)=INDXIDEBCV;IT(176)=INDXJDEBCV;IT(177)=INDXIFINCV;IT(178)=INDXJFINCV
+IT(179)=INDXIDEBCVLL;IT(180)=INDXJDEBCVLL;IT(181)=INDXIFINCVLL;IT(182)=INDXJFINCVLL
+IT(183)=INDNIDEBCV;IT(184)=INDNJDEBCV;IT(185)=INDNIFINCV;IT(186)=INDNJFINCV
+IT(187)=INDLSYMB;IT(188)=INDLSYMBTEXTG;IT(189)=INDLTEXTG;IT(190)=INDLSTI
+IT(191)=INDLTRACECV;IT(192)=INDLTEXTIT; IT(193)=INDLMNMXLOC; IT(194)=INDLULMVTMOLD
+IT(195)=INDLTITFTUSER; IT(196)=INDXANGULVT
+IT(197)=INDLMASK3D; IT(198)=INDXXL; IT(199)=INDXXH; IT(200)=INDXYL
+IT(201)=INDXYH; IT(202)=INDXZL; IT(203)=INDXZH; IT(204)=INDXLWCONT
+IT(205)=INDLMARKER; IT(206)=INDXVLC; IT(207)=INDCNOMCAR; IT(208)=INDCSYMCAR
+IT(209)=INDXPOSNOM; IT(210)=INDXSZNOM; IT(211)=INDXSZSYM; IT(212)=INDICOLNOM
+IT(213)=INDICOLSYM; IT(214)=INDXSZTITT1; IT(215)=INDXSZTITT2;IT(216)=INDXSZTITT3
+IT(217)=INDLINDAX; IT(218)=INDXSZTITB1; IT(219)=INDXSZTITB2; IT(220)=INDXSZTITB3
+IT(221)=INDXPOSTITT1; IT(222)=INDXPOSTITT2;IT(223)=INDXPOSTITT3
+IT(224)=INDXYPOSTITT1; IT(225)=INDXYPOSTITT2;IT(226)=INDXYPOSTITT3
+IT(227)=INDXPOSTITB1; IT(228)=INDXPOSTITB2;IT(229)=INDXPOSTITB3
+IT(230)=INDXYPOSTITB1; IT(231)=INDXYPOSTITB2;IT(232)=INDXYPOSTITB3
+IT(233)=INDXSZTITVAR1; IT(234)=INDXSZTITVAR2; IT(235)=INDXSZTITVAR3
+IT(236)=INDXSZTITVAR4; IT(237)=INDXSZTITVAR5; IT(238)=INDXSZTITVAR6
+IT(239)=INDXSZTITVAR7; IT(240)=INDXSZTITVAR8
+IT(241)=INDXPOSTITVAR1; IT(242)=INDXPOSTITVAR2; IT(243)=INDXPOSTITVAR3
+IT(244)=INDXPOSTITVAR4; IT(245)=INDXPOSTITVAR5; IT(246)=INDXPOSTITVAR6
+IT(247)=INDXPOSTITVAR7; IT(248)=INDXPOSTITVAR8
+IT(249)=INDXYPOSTITVAR1; IT(250)=INDXYPOSTITVAR2; IT(251)=INDXYPOSTITVAR3
+IT(252)=INDXYPOSTITVAR4; IT(253)=INDXYPOSTITVAR5; IT(254)=INDXYPOSTITVAR6
+IT(255)=INDXYPOSTITVAR7; IT(256)=INDXYPOSTITVAR8; IT(257)=INDXLWPV1
+IT(258)=INDXLWPV2; IT(259)=INDXLWPV3; IT(260)=INDXLWPV4; IT(261)=INDXLWPV5
+IT(262)=INDXLWPV6; IT(263)=INDXLWPV7; IT(264)=INDXLWPV8; IT(265)=INDXSTYLPV1
+IT(266)=INDXSTYLPV2; IT(267)=INDXSTYLPV3;IT(268)=INDXSTYLPV4;IT(269)=INDXSTYLPV5
+IT(270)=INDXSTYLPV6; IT(271)=INDXSTYLPV7;IT(272)=INDXSTYLPV8
+IT(273)=INDLFACTIMP; IT(274)=INDNSD; IT(275)=INDXLWTRACECV
+IT(276)=INDLFMTAXEX; IT(277)=INDLFMTAXEY; IT(278)=INDLMASK3D_XY
+IT(279)=INDLMASK3D_XZ; IT(280)=INDLMASK3D_YZ; IT(281)=INDLXYZ00
+IT(282)=INDLINTERPTOP; IT(283)=INDLCOLISONE; IT(284)=INDLCOLRSONE
+IT(285)=INDLCOLRS1ONE; IT(286)=INDNCOLRSONE; IT(287)=INDNCOLISONE1
+IT(288)=INDNCOLISONE2; IT(289)=INDNCOLISONE3; IT(290)=INDNCOLISONE4
+IT(291)=INDNCOLISONE5
+IT(292)=INDNCOLRS1ONE2; IT(293)=INDNCOLRS1ONE3; IT(294)=INDNCOLRS1ONE4
+IT(295)=INDNCOLRS1ONE5; IT(296)=INDNCOLRS1ONE1; IT(297)=INDLCHREEL
+IT(298)=INDLCOLUSERUV; IT(299)=INDNINDCOLUV; IT(300)=INDXPARCOLUV
+IT(301)=INDNISKIPVX; IT(302)=INDNISKIPVY; IT(303)=INDLINVPTIR
+IT(304)=INDLDOMAIN; IT(305)=INDNDOMAINL; IT(306)=INDNDOMAINR
+IT(307)=INDNDOMAINB; IT(308)=INDNDOMAINT; IT(309)=INDXLWDOMAIN
+IT(310)=INDLHEURX; IT(311)=INDXVRLPH; IT(312)=INDXVHCPH;IT(313)=INDLTIMEUSER
+IT(314)=INDXTIMEMIN; IT(315)=INDXTIMEMAX; IT(316)=INDXSPVALT;IT(317)=INDLSPVALT
+IT(318)=INDXLWFTALL; IT(319)=INDLSEGM; IT(320)=INDNCOLSEGM
+IT(321)=INDXLWSEGM; IT(322)=INDL2CONT; IT(323)=INDNCOLUV1;IT(324)=INDNCOLUV2
+IT(325)=INDNCOLUV3; IT(326)=INDNCOLUV4; IT(327)=INDNCOLUV5; IT(328)=INDLPRESY
+IT(329)=INDXPMIN; IT(330)=INDXPMAX; IT(331)=INDXPINT; IT(332)=INDLM5S3
+IT(333)=INDXICAR; IT(334)=INDXJCAR; IT(335)=INDXLWPH1; IT(336)=INDXLWPH2
+IT(337)=INDXLWPH3; IT(338)=INDXLWPH4; IT(339)=INDLSPSECT; IT(340)=INDLEGVECT
+IT(341)=INDNSZLBX; IT(342)=INDNSZLBY; IT(343)=INDLCVZOOM; IT(344)=INDLVST
+IT(345)=INDLDILW ; IT(346)=INDLVSUPSCA; IT(347)=INDXLWPH5; IT(348)=INDXLWPH6
+IT(349)=INDXLWPH7; IT(350)=INDXLWPH8
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+IT(351)=INDXXPART
+IT(352)=INDXYPART
+IT(353)=INDXZPART
+IT(354)=INDLTRAJ3D
+IT(355)=INDLTRAJ_GROUP
+IT(356)=INDLFLUX3D
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+IT(357)=INDLFACTAXEX; IT(358)=INDLFACTAXEY; IT(359)=INDLAXEXUSER
+IT(360)=INDLAXEYUSER; IT(361)=INDXFACTAXEX; IT(362)=INDXFACTAXEY
+IT(363)=INDXAXEXUSERD; IT(364)=INDXAXEYUSERD; IT(365)=INDXAXEXUSERF
+IT(366)=INDXAXEYUSERF; IT(367)=INDLPRDAT; IT(368)=INDLXYWINCUR
+IT(369)=INDLSTREAM; IT(370)=INDLNOLABELX; IT(371)=INDLNOLABELY
+IT(372)=INDLINTERPOLSTR; IT(373)=INDNZSTR; IT(374)=INDNARSTR
+IT(375)=INDXSSP; IT(376)=INDXLWSTR; IT(377)=INDXARLSTR
+IT(378)=INDLMYHEURX ; IT(379)=INDLNOUVRS;IT(380)=INDNHEURXLBL
+IT(381)=INDNHEURXGRAD; IT(382)=INDL3D !; IT(383)=INDLCONVG2MASS
+IT(383)=INDXFT_ADTIM1;IT(384)=INDXFT_ADTIM2;IT(385)=INDXFT_ADTIM3
+IT(386)=INDXFT_ADTIM4;IT(387)=INDXFT_ADTIM5;IT(388)=INDXFT_ADTIM6
+IT(389)=INDXFT_ADTIM7;IT(390)=INDXFT_ADTIM8
+IT(391)=INDXFT1_ADTIM1;IT(392)=INDXFT1_ADTIM2;IT(393)=INDXFT1_ADTIM3
+IT(394)=INDXFT1_ADTIM4;IT(395)=INDXFT1_ADTIM5;IT(396)=INDXFT1_ADTIM6
+IT(397)=INDXFT1_ADTIM7;IT(398)=INDXFT1_ADTIM8; IT(399)=INDLRADAR
+IT(400)=INDXLATRAD1;IT(401)=INDXLATRAD2;IT(402)=INDXLATRAD3;IT(403)=INDXLATRAD4
+IT(404)=INDXLONRAD1;IT(405)=INDXLONRAD2;IT(406)=INDXLONRAD3;IT(407)=INDXLONRAD4
+IT(408)=INDXPORTRAD1;IT(409)=INDXPORTRAD2;IT(410)=INDXPORTRAD3
+IT(411)=INDXPORTRAD4
+IT(412)=INDXLWRAD1;IT(413)=INDXLWRAD2;IT(414)=INDXLWRAD3;IT(415)=INDXLWRAD4
+IT(416)=INDCSYMRAD1;IT(417)=INDCSYMRAD2;IT(418)=INDCSYMRAD3;IT(419)=INDCSYMRAD4
+IT(420)=INDLRADIST; IT(421)=INDLRADRAY
+IT(422)=INDLRADAR
+IT(423)=INDXLATRAD1;IT(424)=INDXLATRAD2;IT(425)=INDXLATRAD3;IT(426)=INDXLATRAD4
+IT(427)=INDXLONRAD1;IT(428)=INDXLONRAD2;IT(429)=INDXLONRAD3;IT(430)=INDXLONRAD4
+IT(431)=INDXPORTRAD1;IT(432)=INDXPORTRAD2;IT(433)=INDXPORTRAD3
+IT(434)=INDXPORTRAD4
+IT(435)=INDXLWRAD1;IT(436)=INDXLWRAD2;IT(437)=INDXLWRAD3;IT(438)=INDXLWRAD4
+IT(439)=INDXVPTFT1L;IT(440)=INDXVPTFT1R;IT(441)=INDXVPTFT1B;IT(442)=INDXVPTFT1T
+IT(443)=INDLRADIST; IT(444)=INDLRADRAY
+IT(445)=INDXISOREF; IT(446)=INDXISOREF_ ; IT(447)=INDLSPOT
+IT(448)=INDLFT3C; IT(449)=INDLFT4C; IT(450)=INDLFTCLIP
+IT(451)=INDLFTBAUTO; IT(452)=INDLFT1BAUTO
+IT(453)=INDLGREY; IT(454)=INDLFT1LUSER; IT(455)=INDNFT1STY1
+IT(456)=INDNFT1STY2; IT(457)=INDNFT1STY3; IT(458)=INDNFT1STY4
+IT(459)=INDNFT1STY5; IT(460)=INDNFT1STY6; IT(461)=INDNFT1STY7
+IT(462)=INDNFT1STY8; IT(463)=INDNFT1STY9; IT(464)=INDNFT1STY10
+IT(465)=INDNFT1STY11; IT(466)=INDNFT1STY12; IT(467)=INDNFT1STY13
+IT(468)=INDNFT1STY14; IT(469)=INDNFT1STY15; IT(470)=INDNFT1COL1
+IT(471)=INDNFT1COL2; IT(472)=INDNFT1COL3; IT(473)=INDNFT1COL4
+IT(474)=INDNFT1COL5; IT(475)=INDNFT1COL6; IT(476)=INDNFT1COL7
+IT(477)=INDNFT1COL8; IT(478)=INDNFT1COL9; IT(479)=INDNFT1COL10
+IT(480)=INDNFT1COL11; IT(481)=INDNFT1COL12; IT(482)=INDNFT1COL13
+IT(483)=INDNFT1COL14; IT(484)=INDNFT1COL15
+IT(485)=INDXFT1LW1; IT(486)=INDXFT1LW2; IT(487)=INDXFT1LW3
+IT(488)=INDXFT1LW4; IT(489)=INDXFT1LW5; IT(490)=INDXFT1LW6
+IT(491)=INDXFT1LW7; IT(492)=INDXFT1LW8; IT(493)=INDXFT1LW9
+IT(494)=INDXFT1LW10; IT(495)=INDXFT1LW11; IT(496)=INDXFT1LW12
+IT(497)=INDXFT1LW13; IT(498)=INDXFT1LW14; IT(499)=INDXFT1LW15
+IT(500)=INDCFT1TIT1; IT(501)=INDCFT1TIT2; IT(502)=INDCFT1TIT3
+IT(503)=INDCFT1TIT4; IT(504)=INDCFT1TIT5; IT(505)=INDCFT1TIT6
+IT(506)=INDCFT1TIT7; IT(507)=INDCFT1TIT8; IT(508)=INDCFT1TIT9
+IT(509)=INDCFT1TIT10; IT(510)=INDCFT1TIT11; IT(511)=INDCFT1TIT12
+IT(512)=INDCFT1TIT13; IT(513)=INDCFT1TIT14; IT(514)=INDCFT1TIT15
+IT(515)=INDLVPTFT1USER; IT(516)=INDXLWPV9; IT(517)=INDXLWPV10;
+IT(518)=INDXLWPV11; IT(519)=INDXLWPV12; IT(520)=INDXLWPV13; IT(521)=INDXLWPV14
+IT(522)=INDXLWPV15
+IT(523)=INDXSTYLPV9; IT(524)=INDXSTYLPV10;IT(525)=INDXSTYLPV11
+IT(526)=INDXSTYLPV12; IT(527)=INDXSTYLPV13;IT(528)=INDXSTYLPV14
+IT(529)=INDXSTYLPV15; IT(530)=INDLVARNPVUSER
+IT(531)=INDCVARNPV1; IT(532)=INDCVARNPV2; IT(533)=INDCVARNPV3
+IT(534)=INDCVARNPV4; IT(535)=INDCVARNPV5; IT(536)=INDCVARNPV6
+IT(537)=INDCVARNPV7; IT(538)=INDCVARNPV8; IT(539)=INDCVARNPV9
+IT(540)=INDCVARNPV10; IT(541)=INDCVARNPV11; IT(542)=INDCVARNPV12
+IT(543)=INDCVARNPV13; IT(544)=INDCVARNPV14; IT(545)=INDCVARNPV15
+IT(546)=INDXPOSXVARNPV1TOP; IT(547)=INDXPOSYVARNPV1TOP
+IT(548)=INDXPOSXVARNPV5BOT; IT(549)=INDXPOSYVARNPV5BOT
+IT(550)=INDXSZVARNPVTOP; IT(551)=INDXSZVARNPVTOP
+IT(552)=INDXSZVARNPVBOT; IT(553)=INDXSZVARNPVBOT; IT(554)=INDLINZEROPV
+IT(555)=INDNSTYLINZEROPV; IT(556)=INDLBLFT1SUP
+IT(557)=INDLXYSTYLTOP; IT(558)=INDLXYNVARTOP
+IT(559)=INDNPHCOL1; IT(560)=INDNPHCOL2; IT(561)=INDNPHCOL3;IT(562)=INDNPHCOL4
+IT(563)=INDNPHCOL1; IT(564)=INDNPHCOL2; IT(565)=INDNPHCOL3;IT(566)=INDNPHCOL4
+IT(567)=INDNPHSTY1; IT(568)=INDNPHSTY2; IT(569)=INDNPHSTY3;IT(570)=INDNPHSTY4
+IT(571)=INDNPHSTY1; IT(572)=INDNPHSTY2; IT(573)=INDNPHSTY3;IT(574)=INDNPHSTY4
+IT(575)=INDLPHCOLUSER; IT(576)=INDLPHSTYUSER; IT(577)=INDL24H
+IT(578)=INDLNOLBLBAR
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!! pour les retrotrajectoires !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IT(579)=INDNSZRTRAJ; IT(580)=INDLFMTRTRAJ ; IT(581)=INDLCONVG2MASS
+IT(582)=INDL90TITYT;IT(583)=INDL90TITYM;IT(584)=INDL90TITYB
+
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+ IT(585)=INDXSZTITYT; IT(586)=INDXSZTITYM;IT(587)=INDXSZTITYB
+IT(588)=INDLVARNPHUSER
+IT(589)=INDCVARNPH1; IT(590)=INDCVARNPH2; IT(591)=INDCVARNPH3
+IT(592)=INDCVARNPH4; IT(593)=INDCVARNPH5; IT(594)=INDCVARNPH6
+IT(594)=INDCVARNPH7; IT(596)=INDCVARNPH8;
+IT(597)=INDXPOSTITYT; IT(598)=INDXPOSTITYM;IT(599)=INDXPOSTITYB
+IT(600)=INDXYPOSTITYT; IT(601)=INDXYPOSTITYM;IT(602)=INDXYPOSTITYB
+IT(603)=INDLPATCH
+DO J=1,SIZE(IT)
+ IF(IT(J) /=0 )THEN
+ INDIM=MIN(INDIM,IT(J))
+ ENDIF
+ENDDO
+if(nverbia >0)then
+ print *,'*** CARESOLV INDIM ',INDIM
+endif
+
+IF (LPATCH) THEN
+ INDP = 0
+ELSE
+ INDP = INDEX(YCARIN,'_P_')
+ENDIF
+INDT = INDEX(YCARIN,'_T_')
+INDK = INDEX(YCARIN,'_K_')
+INDZ = INDEX(YCARIN,'_Z_')
+INDCV = INDEX(YCARIN,'_CV_')
+INDPV = INDEX(YCARIN,'_PV_')
+INDPVT = INDEX(YCARIN,'_PVT_')
+INDPXT = INDEX(YCARIN,'_PXT_')
+INDPYT = INDEX(YCARIN,'_PYT_')
+INDPVKT = INDEX(YCARIN,'_PVKT_')
+INDPH = INDEX(YCARIN,'_PH_')
+INDON = INDEX(YCARIN,'_ON_')
+INDFI = INDEX(YCARIN,'_FILE')
+INDN = INDEX(YCARIN,'_N_')
+INDFT = INDEX(YCARIN,'_FT_')
+INDFT1 = INDEX(YCARIN,'_FT1_')
+INDMASK = INDEX(YCARIN,'_MASK_')
+INDMASKCUM = INDEX(YCARIN,'_MASKCUM_')
+INDMASKSUM = INDEX(YCARIN,'_MASKSUM_')
+INDMINUS= INDEX(YCARIN,'_MINUS_')
+INDPLUS= INDEX(YCARIN,'_PLUS_')
+INDTK = INDEX(YCARIN,'_TK_')
+INDEV = INDEX(YCARIN,'_EV_')
+INDPR = INDEX(YCARIN,'_PR_')
+INDRS = INDEX(YCARIN,'_RS_')
+INDRS1 = INDEX(YCARIN,'_RS1_')
+INDPVKT1 = INDEX(YCARIN,'_PVKT1_')
+INDZTPVKT1 = INDEX(YCARIN,'_ZTPVKT1_')
+INDZT = INDEX(YCARIN,'_ZT_')
+INDXT = INDEX(YCARIN,'_XT_')
+INDYT = INDEX(YCARIN,'_YT_')
+INDXY = INDEX(YCARIN,'_XY_')
+INDXYZ = INDEX(YCARIN,'_XYZ_')
+INDUMVMPV = INDEX(YCARIN,'_UMVM_')
+IF(INDUMVMPV == 0)THEN
+ INDUMVMPV = INDEX(YCARIN,'_UTVT_')
+ENDIF
+INDLSPLO = INDEX(YCARIN,'_LSPLO_')
+INDSPO = INDEX(YCARIN,'_SPO_')
+INDOSPLO = INDEX(YCARIN,'_OSPLO_')
+INDPHALO = INDEX(YCARIN,'_PHALO_')
+INDPHAO = INDEX(YCARIN,'_PHAO_')
+INDMSKTOP = INDEX(YCARIN,'_MSKTOP_')
+INDSV3 = INDEX(YCARIN,'_SV3_')
+!
+INDTOT = INDP+INDT+INDK+INDZ+INDCV+INDPV+INDPVT+INDPH+INDON+INDFI+INDN+ &
+ INDFT+INDFT1+INDPVKT+INDMASK+INDMASKCUM+INDMASKSUM+INDMINUS+ &
+ INDTK+INDPR+INDRS+INDPVKT1+INDZTPVKT1+INDZT+INDXT+INDYT+INDXY+ &
+ INDRS1+INDPLUS+INDEV+INDPXT+INDPYT+INDLSPLO+INDSPO+INDOSPLO+ &
+ INDPHALO+INDPHAO+INDXYZ+INDMSKTOP+INDSV3+INDUMVMPV
+!
+if(nverbia >0)then
+ print *,'*** CARESOLV INDTOT ',INDTOT
+endif
+INBMIN=0
+IIMIN(:,1)=0
+IF(INDTOT == 0)THEN
+ YCARIN=ADJUSTL(YCARIN)
+ IF (INDIM /= 1)THEN
+! Oct 99
+ NPARG=INDEX(YCARIN(1:LEN_TRIM(YCARIN)),'(')
+ NPARD=INDEX(YCARIN(1:LEN_TRIM(YCARIN)),')')
+
+ IF(NPARG /= 0 .AND. NPARD /= 0)THEN
+! Juillet 2001
+ INDEXPR=INDEX(YCARIN(NPARG:NPARD),'*EXPR')
+ IF(INDEXPR == 0.)THEN
+ INDEXPR=INDEX(YCARIN(NPARG:NPARD),'/EXPR')
+ IF(INDEXPR /= 0.)NMULTDIV(1)=2
+ ELSE
+ NMULTDIV(1)=1
+ ENDIF
+
+ IF(INDEXPR /= 0.)THEN
+ CMULTDIV(1)=YCARIN(NPARG+1:NPARG+7)
+ YCARIN(NPARG:NPARD)=' '
+ CGROUP = YCARIN(1:LEN_TRIM(YCARIN))
+ ELSE
+! Juillet 2001
+
+ IETOILE=INDEX(YCARIN(NPARG:NPARD),'*')
+ ILOG =INDEX(YCARIN(NPARG:NPARD),'LOG')
+ CFACT(1)=YCARIN(1:NPARD)
+ CFACT(1)=ADJUSTL(CFACT(1))
+ IF(ILOG /=0) THEN
+ NOPE(1)=3
+ YCARIN(NPARG:NPARD)=' '
+ ELSE IF(IETOILE /= 0)THEN
+ READ(YCARIN(IETOILE+NPARG:NPARD-1),*)XCONSTANTE(1)
+ print *,' **Caresolv IETOILE+1+NPARG ',IETOILE+1+NPARG
+ NOPE(1)=2
+ YCARIN(NPARG:NPARD)=' '
+ ELSE
+ READ(YCARIN(NPARG+1:NPARD-1),*)XCONSTANTE(1)
+ NOPE(1)=1
+ YCARIN(NPARG:NPARD)=' '
+ ENDIF
+
+! Juillet 2001
+ IF(NPARD < LEN_TRIM(YCARIN))THEN
+ ILEN=LEN_TRIM(YCARIN)
+ INDEXPR=INDEX(YCARIN(NPARD+1:ILEN),'*EXPR')
+ IF(INDEXPR == 0.)THEN
+ INDEXPR=INDEX(YCARIN(NPARD+1:ILEN),'/EXPR')
+ IF(INDEXPR /= 0.)NMULTDIV(1)=2
+ ELSE
+ NMULTDIV(1)=1
+ ENDIF
+ IF(INDEXPR /= 0.)THEN
+ CMULTDIV(1)=YCARIN(NPARD+2:NPARD+8)
+ YCARIN(NPARG:NPARD+10)=' '
+ CGROUP = YCARIN(1:LEN_TRIM(YCARIN))
+ ENDIF
+
+ ELSE
+! Juillet 2001
+ CGROUP = YCARIN(1:LEN_TRIM(YCARIN))
+
+! Juillet 2001
+ ENDIF
+ ENDIF
+! Juillet 2001
+
+ ELSE
+! Oct 99
+ CGROUP = YCARIN(1:LEN_TRIM(YCARIN))
+! Oct 99
+ ENDIF
+! Oct 99
+ CGROUP=ADJUSTL(CGROUP)
+ IF(CGROUP(1:LEN_TRIM(CGROUP)) == 'ZS')THEN
+ CGROUP(1:LEN_TRIM(CGROUP))=' '
+ CGROUP='ZSBIS'
+ ENDIF
+ IF(CGROUP(1:LEN_TRIM(CGROUP)) == 'ZSMT')THEN
+ CGROUP(1:LEN_TRIM(CGROUP))=' '
+ CGROUP='ZSMTBIS'
+ ENDIF
+ CGROUPS(1)(1:LEN(CGROUPS(1))) = ' '
+ CGROUPS(1)=ADJUSTL(CGROUP)
+ ENDIF
+ IF(INDIM == 1 .OR. CGROUP(1:LEN_TRIM(CGROUP)) == ' ')THEN
+! Septembre 2000
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ RETURN
+ ENDIF
+ NSUPERDIA=1
+ LPROCDIALL(NSUPERDIA)=.TRUE.
+ LTIMEDIALL(NSUPERDIA,:)=.TRUE.
+ LNDIALL(NSUPERDIA)=.TRUE.
+ LVLKDIALL(NSUPERDIA,:)=.TRUE.
+ YCARIN=CGROUP(1:LEN_TRIM(CGROUP))//'_P_PROCALL_T_TIMEALL_N_NALL_K_LVLKALL'
+! print *,' CARESOLV HGRP ',CGROUP
+ CALL CARMEMORY(YCARIN,1)
+ CALL CARMEMORY(YCARIN,3)
+ELSE
+ IF(INDON /= 0)THEN
+ IF(INDPLUS == 0 .AND. INDMINUS == 0)THEN
+ CALL RESOLVON(YCARIN,INDON)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDON
+ ELSE
+ IF(INDPLUS == 0 .AND. INDMINUS /= 0)THEN
+ IF(INDMINUS < INDON)THEN
+ LMINUS=.TRUE.
+ CALL RESOLVON(YCARIN,INDMINUS)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDMINUS
+ ELSE
+ CALL RESOLVON(YCARIN,INDON)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDON
+ ENDIF
+ ELSE IF(INDPLUS /= 0 .AND. INDMINUS == 0)THEN
+ IF(INDPLUS < INDON)THEN
+ LPLUS=.TRUE.
+ CALL RESOLVON(YCARIN,INDPLUS)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDPLUS
+ ELSE
+ CALL RESOLVON(YCARIN,INDON)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDON
+ ENDIF
+ ELSE
+ IF(INDON < INDMINUS .AND. INDON < INDPLUS)THEN
+ CALL RESOLVON(YCARIN,INDON)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDON
+ ELSE IF(INDMINUS < INDON .AND. INDMINUS < INDPLUS)THEN
+ LMINUS=.TRUE.
+ CALL RESOLVON(YCARIN,INDMINUS)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDMINUS
+ ELSE IF(INDPLUS < INDON .AND. INDPLUS < INDMINUS)THEN
+ LPLUS=.TRUE.
+ CALL RESOLVON(YCARIN,INDPLUS)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ELSE IF(INDMINUS /= 0)THEN
+
+ IF(INDPLUS /= 0)THEN
+ IF(INDMINUS < INDPLUS)THEN
+ LMINUS=.TRUE.
+ CALL RESOLVON(YCARIN,INDMINUS)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDMINUS
+ ELSE
+ LPLUS=.TRUE.
+ CALL RESOLVON(YCARIN,INDPLUS)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDPLUS
+ ENDIF
+ ELSE
+ LMINUS=.TRUE.
+ CALL RESOLVON(YCARIN,INDMINUS)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDMINUS
+ ENDIF
+ ELSE IF(INDPLUS /= 0)THEN
+ IF(INDMINUS /= 0)THEN
+ IF(INDPLUS < INDMINUS)THEN
+ LPLUS=.TRUE.
+ CALL RESOLVON(YCARIN,INDPLUS)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDPLUS
+ ELSE
+ LMINUS=.TRUE.
+ CALL RESOLVON(YCARIN,INDMINUS)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDMINUS
+ ENDIF
+ ELSE
+ LPLUS=.TRUE.
+ CALL RESOLVON(YCARIN,INDPLUS)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,1)=INDPLUS
+ ENDIF
+
+ ELSE
+! print *,' INDMINUS,PLUS,LMINUS,LPLUS ',INDMINUS,INDPLUS,LMINUS,LPLUS,NSUPERDIA
+ NSUPERDIA=NSUPERDIA+1
+ CARSUP(NSUPERDIA)(1:ILENC)=YCARIN(1:ILENC)
+ END IF
+ IF(ALLOCATED(LXYZT))THEN
+ DEALLOCATE(LXYZT)
+ ENDIF
+ ALLOCATE(LXYZT(NSUPERDIA))
+ LXYZT(:)=.FALSE.
+ IF(ALLOCATED(LUMVMPVT))THEN
+ DEALLOCATE(LUMVMPVT)
+ ENDIF
+ ALLOCATE(LUMVMPVT(NSUPERDIA))
+ LUMVMPVT(:)=.FALSE.
+ DO J=1,NSUPERDIA
+ IF(J > 1 .AND. NSUPERDIA > 1)THEN
+ IIMIN(:,J)=0
+ INBMIN=0
+ ENDIF
+ INDMIN=1.E9
+ YCARIN=ADJUSTL(CARSUP(J)(1:LEN_TRIM(CARSUP(J))))
+
+ IF(INDEX(YCARIN,'_FILE') /=0 .AND. NSUPERDIA >1)THEN
+ if(nverbia >0)then
+ print *,' CARESOLV AV EXTRACT YCARIN ',YCARIN
+ endif
+ CALL EXTRACT_AND_OPEN_FILES(YCARIN(1:LEN_TRIM(YCARIN)),YCAROUT)
+ ENDIF
+ NFILESCUR(J)=NUMFILECUR
+ IF (LPATCH) THEN
+ INDP = 0
+ ELSE
+ INDP = INDEX(YCARIN,'_P_')
+ ENDIF
+ INDT = INDEX(YCARIN,'_T_')
+ INDK = INDEX(YCARIN,'_K_')
+ INDZ = INDEX(YCARIN,'_Z_')
+ INDCV = INDEX(YCARIN,'_CV_')
+ INDPV = INDEX(YCARIN,'_PV_')
+ INDPVT = INDEX(YCARIN,'_PVT_')
+ INDPXT = INDEX(YCARIN,'_PXT_')
+ INDPYT = INDEX(YCARIN,'_PYT_')
+ INDPVKT = INDEX(YCARIN,'_PVKT_')
+ INDPH = INDEX(YCARIN,'_PH_')
+ INDFI = INDEX(YCARIN,'_FILE')
+ INDN = INDEX(YCARIN,'_N_')
+ INDFT = INDEX(YCARIN,'_FT_')
+ INDFT1 = INDEX(YCARIN,'_FT1_')
+ INDMASK = INDEX(YCARIN,'_MASK_')
+ INDMASKCUM = INDEX(YCARIN,'_MASKCUM_')
+ INDMASKSUM = INDEX(YCARIN,'_MASKSUM_')
+ INDTK = INDEX(YCARIN,'_TK_')
+ INDEV = INDEX(YCARIN,'_EV_')
+ INDPR = INDEX(YCARIN,'_PR_')
+ INDRS = INDEX(YCARIN,'_RS_')
+ INDRS1 = INDEX(YCARIN,'_RS1_')
+ INDPVKT1 = INDEX(YCARIN,'_PVKT1_')
+ INDZTPVKT1 = INDEX(YCARIN,'_ZTPVKT1_')
+ INDZT = INDEX(YCARIN,'_ZT_')
+ INDXT = INDEX(YCARIN,'_XT_')
+ INDYT = INDEX(YCARIN,'_YT_')
+ INDXY = INDEX(YCARIN,'_XY_')
+ INDXYZ = INDEX(YCARIN,'_XYZ_')
+ INDUMVMPV = INDEX(YCARIN,'_UMVM_')
+ IF(INDUMVMPV == 0)THEN
+ INDUMVMPV = INDEX(YCARIN,'_UTVT_')
+ ENDIF
+ INDLSPLO = INDEX(YCARIN,'_LSPLO_')
+ INDSPO = INDEX(YCARIN,'_SPO_')
+ INDOSPLO = INDEX(YCARIN,'_OSPLO_')
+ INDPHALO = INDEX(YCARIN,'_PHALO_')
+ INDPHAO = INDEX(YCARIN,'_PHAO_')
+ INDMSKTOP = INDEX(YCARIN,'_MSKTOP_')
+ INDSV3 = INDEX(YCARIN,'_SV3_')
+
+! print *,'YCARIN'
+! PRINT *,' INDP ',INDP
+! print *,YCARIN
+ IF(INDCV /= 0)THEN
+ LCV = .TRUE.; LCH = .FALSE.
+! CALL RESOLVCV
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDCV
+ NHISTORY(J)=NHISTORY(J)+1
+ END IF
+ IF(INDPV /= 0)THEN
+ LPV = .TRUE.; LCH = .FALSE.
+! CALL RESOLVPV
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDPV
+ END IF
+ IF(INDPVT /= 0)THEN
+ LPVT = .TRUE.; LCH = .FALSE.
+! CALL RESOLVPVT
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDPVT
+ END IF
+ IF(INDPXT /= 0)THEN
+ LPXT = .TRUE.; LCH = .FALSE.
+! CALL RESOLVPXT
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDPXT
+ END IF
+ IF(INDPYT /= 0)THEN
+ LPYT = .TRUE.; LCH = .FALSE.
+! CALL RESOLVPYT
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDPYT
+ END IF
+ IF(INDPH /= 0)THEN
+ LPH = .TRUE.; LCH = .FALSE.
+! CALL RESOLVPH
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDPH
+ END IF
+ IF(INDP /= 0)THEN
+ CALL RESOLVP(YCARIN(1:LEN_TRIM(YCARIN)),INDP,J)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDP
+ ELSE
+ LPROCDIALL(J)=.TRUE.
+ END IF
+ IF(INDT /= 0)THEN
+! print *, ' AV RESOLV T'
+ CALL RESOLVT(YCARIN(1:LEN_TRIM(YCARIN)),INDT,J)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDT
+! print *, ' AP RESOLVT '
+ ELSE
+ LTIMEDIALL(J,:)=.TRUE.
+ END IF
+ IF(INDK /= 0)THEN
+ CALL RESOLVK(YCARIN(1:LEN_TRIM(YCARIN)),INDK,J)
+ LCH=.TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDK
+ NHISTORY(J)=NHISTORY(J)+2
+ ELSE
+ IF(INDZ == 0 .AND. INDPR == 0 .AND. INDTK == 0 .AND. INDEV == 0 .AND. &
+ INDSV3 == 0)THEN
+ LVLKDIALL(J,:)=.TRUE.
+! Ne surtout pas mettre LCH=.TRUE. ici; sinon pb avec LCV
+ ELSE
+ LVLKDIALL(J,:)=.FALSE.
+ ENDIF
+ END IF
+ IF(INDZ /= 0)THEN
+ CALL RESOLVZ(YCARIN(1:LEN_TRIM(YCARIN)),INDZ,J)
+! LCH remis a .TRUE. volontairement pour resoudre _PXT_ et _PYT_ traites parfois
+! avec les coupes verticales (cas d'1 PH enregistre comme tel) et parfois
+! avec les coupes horizontales ( PH extrait d'une matrice 2D ou 3D)
+! Idem pour les autres coupes horizontales
+ LCH=.TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDZ
+ NHISTORY(J)=NHISTORY(J)+2
+ END IF
+ IF(INDTK /= 0)THEN
+! Artifice pour faire comme _Z_
+ INDTK=INDTK+1
+ CALL RESOLVZ(YCARIN(1:LEN_TRIM(YCARIN)),INDTK,J)
+ LCH=.TRUE.
+ INDTK=INDTK-1
+ LTK=.TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDTK
+ NHISTORY(J)=NHISTORY(J)+2
+ END IF
+ IF(INDEV /= 0)THEN
+! Artifice pour faire comme _Z_
+ INDEV=INDEV+1
+ CALL RESOLVZ(YCARIN(1:LEN_TRIM(YCARIN)),INDEV,J)
+ LCH=.TRUE.
+ INDEV=INDEV-1
+ LEV=.TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDEV
+ NHISTORY(J)=NHISTORY(J)+2
+ END IF
+ IF(INDPR /= 0)THEN
+! Artifice pour faire comme _Z_
+ INDPR=INDPR+1
+ CALL RESOLVZ(YCARIN(1:LEN_TRIM(YCARIN)),INDPR,J)
+ LCH=.TRUE.
+ INDPR=INDPR-1
+ LPR=.TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDPR
+ NHISTORY(J)=NHISTORY(J)+2
+ END IF
+ IF(INDSV3 /= 0)THEN
+! Artifice pour faire comme _Z_
+ INDSV3=INDSV3+2
+ CALL RESOLVZ(YCARIN(1:LEN_TRIM(YCARIN)),INDSV3,J)
+ LSV3=.TRUE.; LCH=.TRUE.
+ INDSV3=INDSV3-2
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDSV3
+ END IF
+! print *,' ** caresolv AP INDZ... LVLKDIAll ',LVLKDIALL(J,1)
+ IF(INDRS /= 0)THEN
+ LRS=.TRUE.; LCH=.FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDRS
+ IF(XIRS /= -999.)THEN
+ ELSE
+ IF(NIRS <= 0 .OR. NIRS > NIMAX+2*JPHEXT .OR. NJRS <= 0 .OR. &
+ NJRS >NJMAX+2*JPHEXT)THEN
+ print *,' INDICES HORIZONTAUX (NIRS,NJRS) DU PROFIL VERTICAL INCORRECTS',&
+ NIRS,NJRS
+ print *,' ENTREZ LEURS VALEURS AVANT DE DEMANDER 1 RS '
+ LPBREAD=.TRUE.
+ ENDIF
+ ENDIF
+ END IF
+ IF(INDRS1 /= 0)THEN
+ LRS1=.TRUE.; LCH=.FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDRS1
+ IF(XIRS /= -999.)THEN
+ ELSE
+ IF(NIRS <= 0 .OR. NIRS > NIMAX+2*JPHEXT .OR. NJRS <= 0 .OR. &
+ NJRS >NJMAX+2*JPHEXT)THEN
+ print *,' INDICES HORIZONTAUX (NIRS,NJRS) DU PROFIL VERTICAL INCORRECTS',&
+ NIRS,NJRS
+ print *,' ENTREZ LEURS VALEURS AVANT DE DEMANDER 1 RS '
+ ENDIF
+ ENDIF
+ END IF
+ IF(INDFI /= 0)THEN
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDFI
+ END IF
+ IF(INDMASK /= 0)THEN
+ LCN=.TRUE.; LCH=.FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDMASK
+ ENDIF
+ IF(INDMASKCUM /= 0)THEN
+ LCNCUM=.TRUE.; LCH=.FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDMASKCUM
+ ENDIF
+ IF(INDMASKSUM /= 0)THEN
+ LCNSUM=.TRUE.; LCH=.FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDMASKSUM
+ ENDIF
+ IF(INDN /= 0)THEN
+ CALL RESOLVN(YCARIN(1:LEN_TRIM(YCARIN)),INDN,J)
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDN
+ ELSE
+ LNDIALL(J)=.TRUE.
+ END IF
+ IF(INDFT /=0 )THEN
+! IF(INDFT /=0 .AND. J==1)THEN
+ LFT=.TRUE.; LCH=.FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDFT
+ ENDIF
+ IF(INDFT1 /=0 )THEN
+! IF(INDFT1 /=0 .AND. J==1)THEN
+ LFT1=.TRUE.; LCH=.FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDFT1
+ ENDIF
+ IF(INDPVKT1 /= 0)THEN
+ LPVKT1 = .TRUE.; LCH = .FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDPVKT1
+ END IF
+ IF(INDPVKT /= 0)THEN
+ LPVKT = .TRUE.; LCH = .FALSE.
+! CALL RESOLVPVT
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDPVKT
+ END IF
+ IF(INDZTPVKT1 /= 0)THEN
+ LZTPVKT1 = .TRUE.; LCH = .FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDZTPVKT1
+ END IF
+ IF(INDZT /= 0)THEN
+ LZT = .TRUE.; LCH = .FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDZT
+ END IF
+ IF(INDMSKTOP /= 0)THEN
+ LMSKTOP = .TRUE.; LCH = .TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDMSKTOP
+ END IF
+ IF(INDXYZ /= 0)THEN
+ LXYZT(J) = .TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDXYZ
+ END IF
+ IF(INDUMVMPV /= 0)THEN
+ LUMVMPVT(J) = .TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDUMVMPV
+ END IF
+ IF(INDXT /= 0)THEN
+ LXT = .TRUE.; LCH = .FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDXT
+ END IF
+ IF(INDYT /= 0)THEN
+ LYT = .TRUE.; LCH = .FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDYT
+ END IF
+ IF(INDXY /= 0)THEN
+ LXYDIA = .TRUE.; LCH = .FALSE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDXY
+ END IF
+ IF(INDLSPLO /= 0)THEN
+ LSPLO= .TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDLSPLO
+ END IF
+ IF(INDSPO /= 0)THEN
+ LSPO= .TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDSPO
+ END IF
+ IF(INDOSPLO /= 0)THEN
+ LOSPLO= .TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDOSPLO
+ END IF
+ IF(INDPHALO /= 0)THEN
+ LPHALO= .TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDPHALO
+ END IF
+ IF(INDPHAO /= 0)THEN
+ LPHAO= .TRUE.
+ INBMIN=INBMIN+1
+ IIMIN(INBMIN,J)=INDPHAO
+ END IF
+
+
+! IF(J <= 1)THEN
+ IF(INBMIN == 0)THEN
+! Oct 99
+ NPARG=INDEX(YCARIN(1:LEN_TRIM(YCARIN)),'(')
+ NPARD=INDEX(YCARIN(1:LEN_TRIM(YCARIN)),')')
+ IF(NPARG /= 0 .AND. NPARD /= 0)THEN
+! Juillet 2001
+ INDEXPR=INDEX(YCARIN(NPARG:NPARD),'*EXPR')
+ IF(INDEXPR == 0.)THEN
+ INDEXPR=INDEX(YCARIN(NPARG:NPARD),'/EXPR')
+ IF(INDEXPR /= 0.)NMULTDIV(J)=2
+ ELSE
+ NMULTDIV(J)=1
+ ENDIF
+
+ IF(INDEXPR /= 0.)THEN
+!!!!!!!!!!!!Nov 2001
+ CMULTDIV(J)=YCARIN(NPARG+1:NPARG+7)
+ YCARIN(NPARG:NPARD)=' '
+ CGROUP = YCARIN(1:LEN_TRIM(YCARIN))
+ ELSE
+! Juillet 2001
+ CFACT(J)=YCARIN(1:NPARD)
+ CFACT(J)=ADJUSTL(CFACT(J))
+ IETOILE=INDEX(YCARIN(NPARG:NPARD),'*')
+ ILOG =INDEX(YCARIN(NPARG:NPARD),'LOG')
+ IF(ILOG /=0) THEN
+ NOPE(J)=3
+ YCARIN(NPARG:NPARD)=' '
+ ELSE IF(IETOILE /= 0)THEN
+ READ(YCARIN(IETOILE+NPARG:NPARD-1),*)XCONSTANTE(J)
+! print *,' **Caresolv IETOILE+1+NPARG ',IETOILE+1+NPARG
+ NOPE(J)=2
+ YCARIN(NPARG:NPARD)=' '
+ ELSE
+ READ(YCARIN(NPARG+1:NPARD-1),*)XCONSTANTE(J)
+ NOPE(J)=1
+ YCARIN(NPARG:NPARD)=' '
+ ENDIF
+! Juillet 2001
+ IF(NPARD < LEN_TRIM(YCARIN))THEN
+ ILEN=LEN_TRIM(YCARIN)
+ INDEXPR=INDEX(YCARIN(NPARD+1:ILEN),'*EXPR')
+ IF(INDEXPR == 0.)THEN
+ INDEXPR=INDEX(YCARIN(NPARD+1:ILEN),'/EXPR')
+ IF(INDEXPR /= 0.)NMULTDIV(J)=2
+ ELSE
+ NMULTDIV(J)=1
+ ENDIF
+ IF(INDEXPR /= 0.)THEN
+ CMULTDIV(J)=YCARIN(NPARD+2:NPARD+8)
+ YCARIN(NPARG:NPARD+10)=' '
+ CGROUP = YCARIN(1:LEN_TRIM(YCARIN))
+ ENDIF
+
+ ELSE
+! Juillet 2001
+
+ CGROUP = YCARIN(1:LEN_TRIM(YCARIN))
+ ENDIF
+! Juillet 2001
+ ENDIF
+ ENDIF
+! Juillet 2001
+
+! Oct 99
+ CGROUP = YCARIN(1:LEN_TRIM(YCARIN))
+
+! CGROUP=ADJUSTL(YCARIN)
+ CGROUP=ADJUSTL(CGROUP)
+ IF(CGROUP(1:LEN_TRIM(CGROUP)) == 'ZS')THEN
+ CGROUP(1:LEN_TRIM(CGROUP))=' '
+ CGROUP='ZSBIS'
+ ENDIF
+ CGROUPS(J)(1:LEN(CGROUPS(J))) = ' '
+ CGROUPS(J)=ADJUSTL(CGROUP)
+ ELSE
+ DO JJ=1,INBMIN
+ INDMIN=MIN(IIMIN(JJ,J),INDMIN)
+ ENDDO
+ IF(INDMIN >1)THEN
+! Oct 99
+ NPARG=INDEX(YCARIN(1:LEN_TRIM(YCARIN)),'(')
+ NPARD=INDEX(YCARIN(1:LEN_TRIM(YCARIN)),')')
+ IF(NPARG /= 0 .AND. NPARD /= 0)THEN
+! Juillet 2001
+ INDEXPR=INDEX(YCARIN(NPARG:NPARD),'*EXPR')
+ IF(INDEXPR == 0.)THEN
+ INDEXPR=INDEX(YCARIN(NPARG:NPARD),'/EXPR')
+ IF(INDEXPR /= 0.)NMULTDIV(J)=2
+ ELSE
+ NMULTDIV(J)=1
+ ENDIF
+
+ IF(INDEXPR /= 0.)THEN
+!!!!!!!Nov 2001
+ CMULTDIV(J)=YCARIN(NPARG+1:NPARG+7)
+ YCARIN(NPARG:NPARD)=' '
+ CGROUP = YCARIN(1:LEN_TRIM(YCARIN))
+ ELSE
+! Juillet 2001
+
+ CFACT(J)=YCARIN(1:NPARD)
+ CFACT(J)=ADJUSTL(CFACT(J))
+ IETOILE=INDEX(YCARIN(NPARG:NPARD),'*')
+ ILOG =INDEX(YCARIN(NPARG:NPARD),'LOG')
+ IF(ILOG /=0) THEN
+ NOPE(J)=3
+ YCARIN(NPARG:NPARD)=' '
+ ELSE IF(IETOILE /= 0)THEN
+ READ(YCARIN(IETOILE+NPARG:NPARD-1),*)XCONSTANTE(J)
+! print *,' **Caresolv IETOILE+1+NPARG ',IETOILE+1+NPARG
+ NOPE(J)=2
+ YCARIN(NPARG:NPARD)=' '
+ ELSE
+ READ(YCARIN(NPARG+1:NPARD-1),*)XCONSTANTE(J)
+ NOPE(J)=1
+ YCARIN(NPARG:NPARD)=' '
+ ENDIF
+
+! Juillet 2001
+ IF(NPARD < LEN_TRIM(YCARIN))THEN
+ ILEN=LEN_TRIM(YCARIN)
+ INDEXPR=INDEX(YCARIN(NPARD+1:ILEN),'*EXPR')
+ IF(INDEXPR == 0.)THEN
+ INDEXPR=INDEX(YCARIN(NPARD+1:ILEN),'/EXPR')
+ IF(INDEXPR /= 0.)NMULTDIV(J)=2
+ ELSE
+ NMULTDIV(J)=1
+ ENDIF
+ IF(INDEXPR /= 0.)THEN
+ CMULTDIV(J)=YCARIN(NPARD+2:NPARD+8)
+ YCARIN(NPARG:NPARD+10)=' '
+ CGROUP = YCARIN(1:LEN_TRIM(YCARIN))
+ ENDIF
+
+ ELSE
+! Juillet 2001
+
+ CGROUP = YCARIN(1:LEN_TRIM(YCARIN))
+ ENDIF
+! Juillet 2001
+ ENDIF
+ ENDIF
+! Juillet 2001
+
+ CGROUP=ADJUSTL(YCARIN(1:INDMIN-1))
+! print *,' CARESOLV HGRP ',CGROUP
+ CGROUP=ADJUSTL(CGROUP)
+ IF(CGROUP(1:LEN_TRIM(CGROUP)) == 'ZS')THEN
+ CGROUP(1:LEN_TRIM(CGROUP))=' '
+ CGROUP='ZSBIS'
+ ENDIF
+ CGROUPS(J)(1:LEN(CGROUPS(J))) = ' '
+ CGROUPS(J)=ADJUSTL(CGROUP)
+ ENDIF
+ ENDIF
+! END IF
+ENDDO
+CALL CARMEMORY(YCARIN,3)
+END IF
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+IF(NVERBIA >0)THEN
+ PRINT *,' ** sortie CARESOLV'
+ print *,' LPRESY,XHMIN,XHMAX ',LPRESY,XHMIN,XHMAX
+ PRINT *,' LPR,LTK,LEV,LSV3 ',LPR,LTK,LEV,LSV3
+ PRINT *,' NSUPERDIA,NSUPER ',NSUPERDIA,NSUPER
+ print *,' CVARNPV1 FIN caresolv ',CVARNPV1
+ENDIF
+! Septembre 2000
+#ifdef RHODES
+CALL FLUSH(NDIR,ISTAF)
+#else
+CALL FLUSH(NDIR)
+#endif
+RETURN
+END SUBROUTINE CARESOLV
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/carint.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/carint.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8aaa2ac41881e958e98ece62c15e32605ae256a4
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/carint.f90
@@ -0,0 +1,81 @@
+! ######spl
+ MODULE MODI_CARINT
+! ##################
+!
+INTERFACE
+!
+SUBROUTINE CARINT(HCAR,KOUT)
+CHARACTER(LEN=*) :: HCAR
+INTEGER :: KOUT
+END SUBROUTINE CARINT
+!
+END INTERFACE
+!
+END MODULE MODI_CARINT
+! ######spl
+ SUBROUTINE CARINT(HCAR,KOUT)
+! ############################
+!
+!!**** *CARINT* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCAR
+INTEGER :: KOUT
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+CHARACTER(LEN=LEN(HCAR)) :: YCAR
+!------------------------------------------------------------------------------
+!
+YCAR=HCAR
+READ(YCAR,*)KOUT
+
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE CARINT
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/carmemory.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/carmemory.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7318dd1704d59f2e91b47ea0b52d007735ccbaed
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/carmemory.f90
@@ -0,0 +1,100 @@
+! ######spl
+ MODULE MODI_CARMEMORY
+! #####################
+!
+INTERFACE
+!
+SUBROUTINE CARMEMORY(HCARIN,KOP)
+CHARACTER(LEN=*),INTENT(INOUT) :: HCARIN
+!CHARACTER(LEN=2400),INTENT(INOUT) :: HCARIN
+INTEGER :: KOP
+END SUBROUTINE CARMEMORY
+!
+END INTERFACE
+!
+END MODULE MODI_CARMEMORY
+! ######spl
+ SUBROUTINE CARMEMORY(HCARIN,KOP)
+! ################################
+!
+!!**** *CARMEMORY* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+!
+!CHARACTER(LEN=2400),INTENT(INOUT) :: HCARIN
+CHARACTER(LEN=*),INTENT(INOUT) :: HCARIN
+INTEGER :: KOP
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+CHARACTER(LEN=2400),SAVE :: YCAR
+INTEGER,SAVE :: ILENC, ILENGP1
+!------------------------------------------------------------------------------
+!
+IF(KOP == 1)THEN
+!fuji HCARIN=ADJUSTL(HCARIN) !introduit des caracteres genre {Á€W×?Ã
+ HCARIN=TRIM(HCARIN)
+ YCAR(1:LEN(YCAR))=' '
+ YCAR=ADJUSTL(HCARIN)
+ ILENC = LEN(YCAR)
+if (nverbia > 0)then
+!print *, ' *** CARMEMORY 1 ILENC YCAR ',ILENC,YCAR(1:80)
+print *, ' *** CARMEMORY 1 ILENC YCAR ',ILENC,YCAR(1:LEN_TRIM(YCAR))
+endif
+ELSE IF(KOP == 2)THEN
+ HCARIN(1:LEN(HCARIN))=' '
+ HCARIN=ADJUSTL(YCAR(ILENGP1+1:LEN_TRIM(YCAR)))
+ HCARIN=ADJUSTL(HCARIN)
+ELSE IF(KOP == 3)THEN
+ CGROUPS(1)=ADJUSTL(CGROUPS(1))
+ ILENGP1=LEN_TRIM(CGROUPS(1))
+ENDIF
+
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE CARMEMORY
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/closf.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/closf.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b8f942a190201a46516c8f5bb2cb88e5746d1f29
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/closf.f90
@@ -0,0 +1,596 @@
+! ######spl
+ MODULE MODI_CLOSF
+! ##################
+!
+INTERFACE
+!
+SUBROUTINE CLOSF(KLOOPT,KTIMEND,KSEGD,KSEGM,K)
+INTEGER,INTENT(IN) :: KLOOPT,KTIMEND,KSEGD,KSEGM,K
+END SUBROUTINE CLOSF
+!
+END INTERFACE
+!
+END MODULE MODI_CLOSF
+! ######spl
+ SUBROUTINE CLOSF(KLOOPT,KTIMEND,KSEGD,KSEGM,K)
+! ##############################################
+!
+!!**** *CLOSF* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODD_MEMCV
+USE MODD_NMGRID
+USE MODD_COORD
+USE MODD_DEFCV
+USE MODD_CONF
+USE MODD_CTL_AXES_AND_STYL
+USE MODN_NCAR
+USE MODN_PARA
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_TIME
+USE MODD_TIME1
+USE MODD_GRID1
+USE MODD_GRID, ONLY: XLONORI,XLATORI
+USE MODD_PARAMETERS, ONLY : JPHEXT
+USE MODE_GRIDPROJ
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+INTEGER,INTENT(IN) :: KLOOPT,KTIMEND,KSEGD,KSEGM,K
+!
+!* 0.1 Local variables
+! ---------------
+!
+INTEGER :: JJ, IER, INB, IWK, I, IA, ID, J
+INTEGER :: IP, IN, IT, IZ, IPV=0
+INTEGER :: KLEN, JI, JIM, ICOLI
+INTEGER :: INUM, IRESP, ISEGM, ICOLSEGM
+INTEGER :: II, IJ
+INTEGER,SAVE :: INBTRACECV=0, INBTOT, ICO
+LOGICAL,SAVE :: GGEOG, GVPTUSER
+REAL :: ZVPTL, ZVPTR, ZVPTB, ZVPTT
+REAL :: ZZZXD, ZZZXF, ZZZYD, ZZZYF
+REAL :: ZVL, ZVR, ZVB, ZVT, ZWL, ZWR, ZWB, ZWT
+REAL :: PHA, ZAX, ZAY, ZAU, ZAV
+REAL :: ZWIDTH, ZLAT, ZLON
+REAL,DIMENSION(100) :: ZX, ZY
+CHARACTER(LEN=25) :: CAR1, CAR2, CAR
+CHARACTER(LEN=80) :: YTEM
+!
+!------------------------------------------------------------------------------
+!IF(LANIMT)THEN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! CALL GFLAS2
+! IF(KLOOPT == KTIMEND)THEN
+! DO JJ=KSEGD,KSEGM
+! CALL GFLAS3(JJ)
+! ENDDO
+! CALL GCLWK(9)
+! CALL NGPICT(1,1)
+! !!!!!!!!!!!!
+! CALL GQACWK(1,IER,INB,IWK)
+! IF(INB > 1)CALL NGPICT(2,3)
+! ENDIF
+!ELSE IF(LPXT .OR. LPYT)THEN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF(LPXT .OR. LPYT)THEN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ELSE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ IF(LANIMK)THEN !!LANIMK
+ CALL GFLAS2
+ IF(NBLVLKDIA(K,1) == 0)THEN
+! Alt Niv. PR ou TK ...
+ IF(.NOT.LZINCRDIA(K))THEN
+! Pas incremental
+ IF(XLOOPZ == XLVLZDIA(NBLVLZDIA(K),K))THEN
+ DO JJ=KSEGD,KSEGM
+ CALL GFLAS3(JJ)
+ ENDDO
+ CALL GCLWK(9)
+ CALL NGPICT(1,1)
+ !!!!!!!!!!!!
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ELSE
+! Incremental
+ IF(XLOOPZ == XLVLZDIA(2,K))THEN
+ DO JJ=KSEGD,KSEGM
+ CALL GFLAS3(JJ)
+ ENDDO
+ CALL GCLWK(9)
+ CALL NGPICT(1,1)
+ !!!!!!!!!!!!
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+ ELSE
+! Niveaux K
+ IF(NLOOPK == NBLVLKDIA(K,1))THEN
+ DO JJ=KSEGD,KSEGM
+ CALL GFLAS3(JJ)
+ ENDDO
+ CALL GCLWK(9)
+ CALL NGPICT(1,1)
+ !!!!!!!!!!!!
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+
+ ELSE !!LANIMK
+
+ IF(K == NSUPERDIA)THEN !+++++++++++++++++++++++++++++++++
+! Trace du domaine fils eventuellement
+ IF(LDOMAIN .AND. (LCH .OR. LCHXY ) .AND. .NOT.LCV)THEN
+ ZZZXD=XXX(NDOMAINL,NMGRID)
+ ZZZXF=XXX(NDOMAINR,NMGRID)
+ ZZZYD=XXY(NDOMAINB,NMGRID)
+ ZZZYF=XXY(NDOMAINT,NMGRID)
+ CALL GSLWSC(XLWDOMAIN)
+ CALL FRSTPT(ZZZXD,ZZZYD)
+ CALL VECTOR(ZZZXF,ZZZYD)
+ CALL VECTOR(ZZZXF,ZZZYF)
+ CALL VECTOR(ZZZXD,ZZZYF)
+ CALL VECTOR(ZZZXD,ZZZYD)
+ ENDIF
+! Trace de segments eventuellement
+ IF(LSEGM .AND. (LCH .OR. LCHXY) .AND. .NOT.LCV)THEN
+ CALL GQPLCI(IER,ICOLI)
+ DO J=1,NCOLSEGM
+ !IF(.NOT.LCOLAREA .AND. .NOT.LCOLINE .AND. NCOLSEGMS(J) > 1)THEN
+ IF(NCOLSEGMS(J) > 1)THEN
+ CALL TABCOL_FORDIACHRO
+ print *,' appel a TABCOL_FORDIACHRO pour le trace de polylines couleur'
+ EXIT
+ ENDIF
+ ENDDO
+ CALL GSLWSC(XLWSEGM)
+ ISEGM=0
+ DO J=1,SIZE(NSEGMS,1)
+ ! Conversion en coordonnees conformes
+ ZLAT=XSEGMS(J,1)
+ ZLON=XSEGMS(J,2)
+ IF (NSEGMS(J)==1) THEN ! XSEGMS
+ IF (XCONFSEGMS(J,1)==0. .AND. XCONFSEGMS(J,2)==0.) &
+ CALL SM_XYHAT_S(XLATORI,XLONORI, &
+ ZLAT,ZLON, &
+ XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ELSE IF (NSEGMS(J)==-1) THEN ! ISEGMS
+ NSEGMS(J)=1
+ II=MAX(MIN(INT(ZLAT),NIMAX+2*JPHEXT-1),1)
+ IJ=MAX(MIN(INT(ZLON),NJMAX+2*JPHEXT-1),1)
+ XCONFSEGMS(J,1)=XXX(II,NMGRID) + &
+ (ZLAT-FLOAT(II))*(XXX(II+1,NMGRID) - XXX(II,NMGRID) )
+ XCONFSEGMS(J,2)=XXY(IJ,NMGRID) + &
+ (ZLON-FLOAT(IJ))*(XXY(IJ+1,NMGRID) - XXY(IJ,NMGRID) )
+ END IF
+ IF(J == 1 .AND. NSEGMS(J) == 1)THEN
+! IF((J == 1 .AND. NSEGMS(J) == 1) .OR. &
+! (J >1 .AND. NSEGMS(J) == 1 .AND. &
+! NSEGMS(J-1) == 0))THEN
+! IF(J > 1)CALL SFLUSH
+ ISEGM=ISEGM+1
+ ICOLSEGM=NCOLSEGMS(ISEGM)
+ IF((LCOLAREA .OR. LCOLINE) .AND. ICOLSEGM > 1)THEN
+ print *,' Avec LCOLAREA=T ou LCOLINE=T , attention a la superposition des couleurs'
+ print *,' pour les segments preferez NCOLSEGMS= 0 ou 1 '
+ !print *,' valeur trouvee: ',NCOLSEGMS(ISEGM),'FORCEE a 1 '
+ !ICOLSEGM=1
+ ENDIF
+ CALL GSPLCI(ICOLSEGM)
+ CALL GSTXCI(ICOLSEGM)
+ CALL FRSTPT(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+! ELSE IF(J > 1 .AND. NSEGMS(J) == 1 .AND. &
+ ELSE IF(J > 1 .AND. NSEGMS(J) == 1 )THEN
+ IF(NSEGMS(J-1)== 1)THEN
+ CALL VECTOR(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ELSE
+ CALL SFLUSH
+ ISEGM=ISEGM+1
+ ICOLSEGM=NCOLSEGMS(ISEGM)
+ IF((LCOLAREA .OR. LCOLINE) .AND. ICOLSEGM > 1)THEN
+ print *,' Avec LCOLAREA=T ou LCOLINE=T , attention a la superposition des couleurs'
+ print *,' pour les segments preferez NCOLSEGMS= 0 ou 1 '
+ !print *,' valeur trouvee: ',NCOLSEGMS(ISEGM),'FORCEE a 1 '
+ !ICOLSEGM=1
+ ENDIF
+ CALL GSPLCI(ICOLSEGM)
+ CALL GSTXCI(ICOLSEGM)
+ CALL FRSTPT(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ENDIF
+ ENDIF
+ ENDDO
+ CALL SFLUSH
+ CALL GSPLCI(ICOLI)
+ CALL GSTXCI(1)
+ ENDIF
+! Trace de la CV dans CH suivante(s) eventuellement
+ IF(LTRACECV .AND. (LCH .OR. LCHXY) .AND. .NOT.LCV)THEN
+ CALL GQLWSC(IER,ZWIDTH)
+ CALL GSLWSC(XLWTRACECV)
+ CALL GSMKSC(2.)
+ ICOLSEGM=1
+ CALL GSPLCI(ICOLSEGM)
+ CALL GSTXCI(ICOLSEGM)
+ DO J=1,SIZE(NSEGMS,1)-1
+ IF(NSEGMS(J) == 2 .AND. NSEGMS(J+1) ==2)THEN
+ print *,'closf J=',J
+ CALL GSMK(4)
+ CALL GPM(1,XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ CALL GSMK(5)
+ CALL GPM(1,XCONFSEGMS(J+1,1),XCONFSEGMS(J+1,2))
+ CALL CURVED(XCONFSEGMS(J:J+1,1),XCONFSEGMS(J:J+1,2),2)
+ ENDIF
+ ENDDO
+ CALL SFLUSH
+ CALL GSLWSC(ZWIDTH)
+ CALL GSTXCI(1)
+ ENDIF
+! Fermeture du dessin ds les cas =/= PH UMVM
+ IF(LCH .AND. LCV .AND. (LUMVM .OR. LUTVT))THEN
+ IF(nverbia > 0)then
+ print *,' ***closf NLMAX ',NLMAX
+ print *,' XTEMCVU ',XTEMCVU
+ print *,' XTEMCVV ',XTEMCVV
+ endif
+
+ ELSE
+ IF(LANIMT)THEN
+ CALL GFLAS2
+ IF(KLOOPT == KTIMEND)THEN
+ DO JJ=KSEGD,KSEGM
+ CALL GFLAS3(JJ)
+ ENDDO
+ CALL GCLWK(9)
+ CALL NGPICT(1,1)
+ !!!!!!!!!!!!
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ELSE
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ if(nverbia == -10)then
+ print *,' CCCCCLOSF FRAME'
+ endif
+ ENDIF
+ ENDIF
+! Fermeture du dessin ds les cas =/= PH UV
+ IF(LTRACECV .AND. LCV .AND..NOT.L1DT)THEN !.............................
+ INBTRACECV=INBTRACECV+1
+ IF(LPV)THEN
+ IPV=IPV+1
+ ZX(IPV)=XDSX(NPROFILE,NMGRID)
+ ZY(IPV)=XDSY(NPROFILE,NMGRID)
+ ENDIF
+ IF(NVERBIA == 10)THEN
+ print *,' closf INBTRACECV ',INBTRACECV
+ ENDIF
+
+ IF(INBTRACECV == 1)THEN !0000000000000000000000000000000
+ IP=NBPROCDIA(NLOOPSUPER)
+ IN=NBNDIA(NLOOPSUPER)
+ IF(.NOT.LTINCRDIA(NLOOPSUPER,1))THEN
+ IT=NBTIMEDIA(NLOOPSUPER,1)
+ ELSE
+ IT=(NTIMEDIA(2,NLOOPSUPER,1)-NTIMEDIA(1,NLOOPSUPER,1))&
+ /NTIMEDIA(3,NLOOPSUPER,1)+1
+ ENDIF
+! IF(LVLKDIALL(NLOOPSUPER,1))THEN
+! NBLVLKDIA(NLOOPSUPER,1)=0
+! print *,' **closf LTRACECV=T LCV=T LCH=T NBLVLKDIA(NLOOPSUPER,1) remis a 0 pour eliminer LVLKDIALL=T'
+! ENDIF
+ IF(.NOT.LCH)THEN
+! print *,' **closf LCH CDIRCUR ',LCH,CDIRCUR(1:LEN_TRIM(CDIRCUR))
+ IZ=1
+ ELSE
+ IF(NBLVLKDIA(NLOOPSUPER,1) /= 0)THEN
+ IZ=NBLVLKDIA(NLOOPSUPER,1)
+ ELSE
+ IF(.NOT.LZINCRDIA(NLOOPSUPER))THEN
+ IZ=NBLVLZDIA(NLOOPSUPER)
+ ELSE
+ IZ=(XLVLZDIA(2,NLOOPSUPER)-XLVLZDIA(1,NLOOPSUPER))&
+ /XLVLZDIA(3,NLOOPSUPER)+1
+ ENDIF
+ ENDIF
+ ENDIF
+ INBTOT=IP*IN*IT*IZ
+ IF(NVERBIA == 10)THEN
+ print *,' closf INBTOT,IP,IN,IT,IZ ',INBTOT,IP,IN,IT,IZ
+ ENDIF
+ ENDIF !0000000000000000000000000000000
+
+ IF(INBTRACECV == INBTOT)THEN
+ IF(LVPTUSER)THEN
+ GVPTUSER=.TRUE.
+ ZVPTL=XVPTL; ZVPTR=XVPTR; ZVPTB=XVPTB; ZVPTT=XVPTT
+ ELSE
+ GVPTUSER=.FALSE.
+ LVPTUSER=.TRUE.
+ ZVPTL=XVPTL; ZVPTR=XVPTR; ZVPTB=XVPTB; ZVPTT=XVPTT
+ XVPTL=.10; XVPTR=.90; XVPTB=.10; XVPTT=.90
+ ENDIF
+
+ IF(LCARTESIAN)THEN
+ CALL DEFENETRE
+ ELSE
+ IF(LGEOG)THEN
+ GGEOG=.TRUE.
+ ELSE
+ GGEOG=.FALSE.
+ ENDIF
+! LGEOG=.TRUE.
+! XVPTL=.12; XVPTR=.88; XVPTB=.12; XVPTT=.88
+ CALL BCGRD_FORDIACHRO(1)
+ CALL BCGRD_FORDIACHRO(2)
+ ENDIF
+
+ CALL GSLWSC(XLWTRACECV)
+ CALL GSMKSC(2.)
+ DO I =1,NTRACECV
+ CALL GSMK(4)
+ CALL GPM(1,XTRACECV(1,I),XYTRACECV(1,I))
+ CALL GSMK(5)
+ CALL GPM(1,XTRACECV(2,I),XYTRACECV(2,I))
+! CALL FRSTPT(XTRACECV(1,I),XYTRACECV(1,I))
+! CALL VECTOR(XTRACECV(2,I),XYTRACECV(2,I))
+ CALL CURVED(XTRACECV(1:2,I),XYTRACECV(1:2,I),2)
+ IF(IPV /= 0)THEN
+ DO IA=1,IPV
+ CALL GSMKSC(1.)
+ CALL GSMK(5)
+ CALL GPM(1,ZX(IA),ZY(IA))
+ ENDDO
+ IPV=0
+ ENDIF
+ ENDDO
+! Janv 2001
+ CALL GSMKSC(1.)
+! Janv 2001
+ CAR(1:LEN(CAR))=' '
+ CAR1(1:LEN(CAR1))=' '
+ CAR2(1:LEN(CAR2))=' '
+ IF(LDEFCV2CC)THEN
+
+ IF(LDEFCV2LL)THEN
+ WRITE(CAR,'(''Latitude,Longitude :'')')
+ WRITE(CAR1,'(''('',F6.2,'','',F6.2,'')'')')XIDEBCVLL,XJDEBCVLL
+ WRITE(CAR2,'(''('',F6.2,'','',F6.2,'')'')')XIFINCVLL,XJFINCVLL
+ ELSE IF(LDEFCV2IND)THEN
+ WRITE(CAR,'(''Indices de grille I,J : '')')
+ WRITE(CAR1,'(''('',I4,'','',I4,'')'')')NIDEBCV,NJDEBCV
+ WRITE(CAR2,'(''('',I4,'','',I4,'')'')')NIFINCV,NJFINCV
+ ELSE IF(LDEFCV2)THEN
+ WRITE(CAR,'(''Coordonnees conformes : '')')
+ WRITE(CAR1,'(''('',F10.2,'','',F10.2,'')'')')XTRACECV(1,1),XYTRACECV(1,1)
+ WRITE(CAR2,'(''('',F10.2,'','',F10.2,'')'')')XTRACECV(2,1),XYTRACECV(2,1)
+ ENDIF
+ ELSE
+ IF(XIDEBCOU == -999.)THEN
+ WRITE(CAR,'(''Indices de grille I,J : '')')
+ WRITE(CAR1,'(''('',I4,'','',I4,'')'')')NIDEBCOU,NJDEBCOU
+ WRITE(CAR2,'(''(NLMAX='',I4,'',ANG='',I3,'')'')')NLMAX,NLANGLE
+ ELSE
+ WRITE(CAR,'(''Coordonnees conformes : '')')
+ WRITE(CAR1,'(''('',F10.2,'','',F10.2,'')'')')XIDEBCOU,NJDEBCOU
+ WRITE(CAR2,'(''(NLMAX='',I4,'',ANG='',I3,'')'')')NLMAX,NLANGLE
+ ENDIF
+ ENDIF
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ XCURVPTL=ZVL;XCURVPTR=ZVR;XCURVPTB=ZVB;XCURVPTT=ZVT
+!
+! Traitement des PH UMVM ou UTVT . Condition
+! LTRACECV=T _CV__K_ (ou Z etc...) UMVM ou UTVT
+
+ IF(LCH .AND. LCV .AND. (LUMVM .OR. LUTVT))THEN
+ CALL ECHELLEPH(KLEN,PHA)
+ CALL GQLWSC(IER,ZWIDTH)
+ IF(XLWV > 0.)THEN
+ CALL GSLWSC(XLWV)
+ ENDIF
+ JIM=0
+ IF(LCOLINE)THEN
+ print *,' PH couleur fleches ? 1=noir 2=rouge 3=vert 4=bleu ... '
+ read(5,*,ERR=10)ICO
+ CALL GSPLCI(ICO)
+ GO TO 20
+ 10 CONTINUE
+ BACKSPACE 5
+ print *,' Mai 2000 PH vecteurs vent horizontal. Si LCOLINE=T, possibilite '
+ print *,' de mettre les fleches en couleur en fournissant un indice apres la requete '
+ print *,' En cas d''absence, elles restent en noir '
+ 20 CONTINUE
+ ENDIF
+ DO JI=1,SIZE(XTEMCVU,1),NISKIP
+ JIM=JIM+1
+ ZAX=XDSX(JI,1)
+ ZAY=XDSY(JI,1)
+ ZAU=XTEMCVU(JI,1)
+ ZAV=XTEMCVV(JI,1)
+ CALL FLECHE(ZAX,ZAY,ZAU,ZAV,KLEN,PHA)
+ ENDDO
+ CALL SFLUSH
+ CALL GSLWSC(ZWIDTH)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ if(nverbia > 0)then
+ print *,' ***closf JIM ',JIM,' NISKIP,SIZE(XTEMCVU,1) ',NISKIP,SIZE(XTEMCVU,1)
+ endif
+ IF(LPRINT)THEN
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ WRITE(INUM,'(''CLOSF '',''G:'',A16,4X,'' NBVAL:'',I5,'' NLMAX:'',I5,'' NISKIP:'',I5)')CGROUP,JIM,NLMAX,NISKIP
+ WRITE(INUM,'(A70)')CDIRCUR
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2)THEN
+ WRITE(INUM,'(''cc(deb)-(fin)=('',F8.0,'','',F8.0,'')-('',F8.0,'','',F8.0,'')'')')&
+ &XIDEBCV,XJDEBCV,XIFINCV,XJFINCV
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(INUM,'(''ll(deb)-(fin)=('',F8.4,'','',F8.4,'')-('',F8.4,'','',F8.4,'')'')')&
+ &XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL
+ ELSE IF(LDEFCV2IND)THEN
+ WRITE(INUM,'(''ij(deb)-(fin)=('',I4,'','',I4,'')-('',I4,'','',I4,'')'')')&
+ &NIDEBCV,NJDEBCV,NIFINCV,NJFINCV
+ ENDIF
+ ELSE
+ IF(XIDEBCOU /= -999.)THEN
+ WRITE(INUM,'(''xidebcou'',F8.0,'' xjdebcou'',F8.0,'' nlmax'',i5,'' nlangle'',i4)')&
+ &XIDEBCOU,XJDEBCOU,NLMAX,NLANGLE
+ ELSE
+ WRITE(INUM,'(''nidebcou'',i4,'' njdebcou'',i4,'' nlmax'',i5,'' nlangle'',i4)')&
+ &NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE
+ ENDIF
+ ENDIF
+! JUin 2001 Ecriture des dates (Demande G.Jaubert ) si LPRDAT=T
+ IF(LPRDAT)THEN
+ IF(.NOT.ALLOCATED(XPRDAT))THEN
+ print *,'**CLOSF XPRDAT NON ALLOUE.Dates non ecrites ds FICVAL .Prevenir J.Duron'
+ ELSE
+ WRITE(INUM,'(1X,75(1H*))')
+ WRITE(INUM,'(1X,'' Dates courante * modele * experience * segment'')')
+ WRITE(INUM,'(1X,'' J An M J Sec. * An M J Sec. * An M J Sec. * An M J Sec.'')')
+ WRITE(INUM,'(1X,75(1H*))')
+ DO J=1,SIZE(XPRDAT,2)
+ WRITE(INUM,'(1X,I3,1X,3(I4,I3,I3,I6,'' *''),I4,I3,I3,I6)')J,INT(XPRDAT(:,J))
+ ENDDO
+ ENDIF
+ ENDIF
+! JUin 2001 Ecriture des dates
+ WRITE(INUM,'(1X,78(1H*))')
+ WRITE(INUM,'(15X,''U'',17X,''V'',17X,''X'',17X,''Y'')')
+! WRITE(INUM,'(16X,''X'',19X,''Y'')')
+ WRITE(INUM,'(1X,78(1H*))')
+ JIM=0
+ DO JI=1,SIZE(XTEMCVU,1),NISKIP
+ JIM=JIM+1
+ ZAX=XDSX(JI,1)
+ ZAY=XDSY(JI,1)
+ ZAU=XTEMCVU(JI,1)
+ ZAV=XTEMCVV(JI,1)
+ WRITE(INUM,'(I5,4(2X,E15.8))')JIM,ZAU,ZAV,ZAX,ZAY
+ ENDDO
+ WRITE(INUM,'(1X,78(1H*))')
+ ENDIF
+ DEALLOCATE(XTEMCVU,XTEMCVV)
+ ENDIF
+
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ CALL GSLWSC(2.)
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ YTEM(1:LEN(YTEM))=' '
+ CALL GSLWSC(2.)
+ CALL GSTXFP(-13,0)
+ CALL RESOLV_TIT('CTITT1',YTEM)
+ IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(.001,.98,YTEM(1:LEN_TRIM(YTEM)),.012,0.,-1.)
+ ELSE
+ CALL PLCHHQ(.001,.98,CDIRCUR(1:LEN_TRIM(CDIRCUR)),.012,0.,-1.)
+ ENDIF
+ CALL GSTXFP(-13,2)
+ CALL GSLWSC(2.)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(.001,.95,YTEM(1:LEN_TRIM(YTEM)),.009,0.,-1.)
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT3',YTEM)
+ IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(.001,.93,YTEM(1:LEN_TRIM(YTEM)),.009,0.,-1.)
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITB1',YTEM)
+ IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(.001,.001,YTEM(1:LEN_TRIM(YTEM)),.009,0.,-1.)
+ ENDIF
+ CALL PLCHHQ(.001,.04,CAR(1:LEN_TRIM(CAR)),.012,0.,-1.)
+ CALL GSMK(4)
+ CALL GPM(1,.35,.04)
+ CALL PLCHHQ(.401,.04,CAR1(1:LEN_TRIM(CAR)),.012,0.,-1.)
+ CALL GSMK(5)
+ CALL GPM(1,.70,.04)
+ IF(LDEFCV2CC)THEN
+ CALL PLCHHQ(.751,.04,CAR2(1:LEN_TRIM(CAR)),.012,0.,-1.)
+ ELSE
+ CALL PLCHHQ(.721,.04,CAR2(1:LEN_TRIM(CAR)),.012,0.,-1.)
+ ENDIF
+ CALL FRAME
+ CALL GSLWSC(1.)
+ INBTRACECV=0
+ NTRACECV=0
+ IF(GVPTUSER)THEN
+ LVPTUSER=.TRUE.
+ XVPTL=ZVPTL; XVPTR=ZVPTR; XVPTB=ZVPTB; XVPTT=ZVPTT
+ ELSE
+ LVPTUSER=.FALSE.
+ XVPTL=ZVPTL; XVPTR=ZVPTR; XVPTB=ZVPTB; XVPTT=ZVPTT
+ ENDIF
+ IF(LCARTESIAN)THEN
+ ELSE
+ IF(GGEOG)THEN
+ LGEOG=.TRUE.
+ ELSE
+ LGEOG=.FALSE.
+ ENDIF
+ ENDIF
+! IF(LCARTESIAN)THEN
+! CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+! ENDIF
+ ENDIF !000000000000000000000000000000000000000
+ ELSE !..........................................
+ INBTRACECV=0
+ NTRACECV=0
+ ENDIF !..........................................
+ ENDIF !++++++++++++++++++++++++++++++++++++++++++
+
+ ENDIF !!LANIMK
+
+ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+RETURN
+END SUBROUTINE CLOSF
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/color_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/color_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1ebe1e2b85d001a327134a04c50b5629dd193e33
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/color_fordiachro.f90
@@ -0,0 +1,129 @@
+! ######spl
+ SUBROUTINE COLOR_FORDIACHRO(KN,KTYPE)
+! ###############################
+!
+!!**** *COLOR_FORDIACHRO* - Definition d'une table de couleurs en RGB
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 16/01/95
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+IMPLICIT NONE
+!
+!* 0.1 dummy arguments
+!
+INTEGER :: KN
+INTEGER :: KTYPE ! (1=color; 2=grey)
+!
+!* 0.2 local variables
+!
+REAL :: ZHUE, ZHUES, ZL, ZLS
+REAL :: ZRED, ZGREEN, ZBLUE
+
+
+INTEGER :: J, JJ
+INTEGER :: ICNT, ISTA, IER, INB, IWK
+INTEGER :: INBB
+!
+!-------------------------------------------------------------------------------
+CALL GQOPS(ISTA)
+CALL GQACWK(1,IER,INB,IWK)
+CALL GQOPWK(1,IER,INB,IWK)
+IF(KN <= 0)RETURN
+!
+IF(LINVWB)THEN
+ CALL GSCR(IWK,0,1.,1.,1.) ! BACKGROUND COLOR (black)
+ CALL GSCR(IWK,1,0.,0.,0.) ! First foreground color is white
+ELSE
+ CALL GSCR(IWK,0,0.,0.,0.) ! BACKGROUND COLOR (black)
+ CALL GSCR(IWK,1,1.,1.,1.) ! First foreground color is white
+ENDIF
+!
+DO JJ=1,INB
+ CALL GQOPWK(JJ,IER,INBB,IWK)
+ IF(IWK == 9)THEN
+ CYCLE
+ ELSE
+ CALL GSCR(IWK,2,.75,.75,.75) ! Second foreground color is gray
+ ENDIF
+ENDDO
+!
+! Choose other foreground colors spaced equally around the spectrum
+ICNT=0
+ZHUES=360./KN
+ZLS=100./KN
+DO J=1,KN
+ ZHUE=J*ZHUES
+ ZL=J*ZLS
+ IF(KTYPE==1) THEN
+ !full colors
+ CALL HLSRGB(ZHUE,50.,100.,ZRED,ZGREEN,ZBLUE)
+! CALL HLSRGB(ZHUE,55.,95.,ZRED,ZGREEN,ZBLUE)
+! CALL HLSRGB(ZHUE,60.,75.,ZRED,ZGREEN,ZBLUE)
+ IF(ZHUE.LE.36.)THEN
+ DO JJ=1,INB
+ CALL GQOPWK(JJ,IER,INBB,IWK)
+ IF(IWK == 9)THEN
+ CYCLE
+ ELSE
+ CALL GSCR(IWK,KN+3-J,ZRED,ZGREEN,ZBLUE)
+ ENDIF
+ ENDDO
+ ICNT=ICNT+1
+ ELSE
+ DO JJ=1,INB
+ CALL GQOPWK(JJ,IER,INBB,IWK)
+ IF(IWK == 9)THEN
+ CYCLE
+ ELSE
+ CALL GSCR(IWK,J-ICNT+2,ZRED,ZGREEN,ZBLUE)
+ ENDIF
+ ENDDO
+ END IF
+ ELSE IF(KTYPE==2) THEN
+ !greys (S=0.)
+ CALL HLSRGB(ZHUE,ZL,0.,ZRED,ZGREEN,ZBLUE)
+ DO JJ=1,INB
+ CALL GQOPWK(JJ,IER,INBB,IWK)
+ IF(IWK == 9)THEN
+ CYCLE
+ ELSE
+ CALL GSCR(IWK,J-ICNT+2,ZRED,ZGREEN,ZBLUE)
+ ENDIF
+ ENDDO
+END IF
+ENDDO
+!
+RETURN
+END SUBROUTINE COLOR_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/colvect.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/colvect.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d92efa5142e0ef9b6b43538643698a7f7d97a8b2
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/colvect.f90
@@ -0,0 +1,186 @@
+! ##############################
+ SUBROUTINE COLVECT(KKU,PTEM2D)
+! ##############################
+!
+!!**** *COLVECT* - Couleur fleches par un autre parametre
+!! Possible uniquement pour les profils verticaux de vecteurs vent horizontal
+!! generes directement ds un fichier diachronique (CART + MASK)
+!!****
+!!
+!! PURPOSE
+!! -------
+!
+!
+!
+!
+!!** METHOD
+!! ------
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist (former PARA common)
+!! NLANGLE : Angle between X Meso-NH axis and
+!! cross-section direction in degrees
+!! (Integer value anticlockwise)
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 23/10/2001
+!! Updated
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODN_NCAR
+USE MODD_PVT
+USE MODD_RESOLVCAR
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments and results
+!
+ !
+ !
+REAL, DIMENSION(:,:), INTENT(IN) :: PTEM2D !
+ !
+INTEGER :: KKU !
+ !
+!
+!* 0.2 Local variables
+!
+INTEGER :: JILOOP, JJLOOP, JKLOOP
+!
+REAL :: ZMXPARCOL, ZMNPARCOL, ZINTPARCOL
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTING THE LONGITUDINAL AND TRANSVERSE COMPONENTS
+! ----------------------------------------------------
+!
+!* 1.1
+!
+IF(ALLOCATED(NCOL2DUV))THEN
+ DEALLOCATE(NCOL2DUV)
+ENDIF
+ALLOCATE(NCOL2DUV(SIZE(PTEM2D,2),KKU))
+LCOLPVT=.TRUE.
+NCOL2DUV=1
+IF(LCOLUSERUV)THEN !:::::::::::::::::::::::::::
+ DO JILOOP=1,SIZE(PTEM2D,1)
+ DO JJLOOP=1,SIZE(PTEM2D,2)
+
+ IF(PTEM2D(JILOOP,JJLOOP) /= XSPVAL)THEN
+ IF(PTEM2D(JILOOP,JJLOOP) < XPARCOLUV(1))THEN
+ NCOL2DUV(JJLOOP,JILOOP)=NINDCOLUV(1)
+ ELSE IF(PTEM2D(JILOOP,JJLOOP) >= XPARCOLUV&
+ (NBPARCOLUV))THEN
+ NCOL2DUV(JJLOOP,JILOOP)=NINDCOLUV(NBCOLUV)
+ ELSE
+ DO JKLOOP=2,NBPARCOLUV
+ IF(PTEM2D(JILOOP,JJLOOP) >= XPARCOLUV(&
+ JKLOOP-1) .AND. PTEM2D(JILOOP,JJLOOP)<&
+ XPARCOLUV(JKLOOP))then
+ NCOL2DUV(JJLOOP,JILOOP)=NINDCOLUV(&
+ JKLOOP)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ENDIF
+
+ENDDO
+ENDDO
+ ELSE !:::::::::::::::::::::::::::
+ZMXPARCOL=-1.e14
+ZMNPARCOL=+1.e14
+DO JILOOP=1,SIZE(PTEM2D,1)
+DO JJLOOP=1,SIZE(PTEM2D,2)
+
+ IF(PTEM2D(JILOOP,JJLOOP) /= XSPVAL)THEN
+ ZMXPARCOL=MAX(PTEM2D(JILOOP,JJLOOP),ZMXPARCOL)
+ ZMNPARCOL=MIN(PTEM2D(JILOOP,JJLOOP),ZMNPARCOL)
+ ENDIF
+ENDDO
+ENDDO
+IF(ABS(ZMXPARCOL-ZMNPARCOL) >= 20)THEN
+ ZMNPARCOL=ZMNPARCOL+1
+ ZMXPARCOl=ZMXPARCOl-1
+ENDIF
+ZINTPARCOL=(ZMXPARCOL-ZMNPARCOL)/5.
+XPARCOLUVSTD(1)=ZMNPARCOL
+DO JILOOP=2,NBPARCOLUVSTD-1
+ XPARCOLUVSTD(JILOOP)=XPARCOLUVSTD(JILOOP-1)+&
+ ZINTPARCOL
+ENDDO
+XPARCOLUVSTD(NBPARCOLUVSTD)=ZMXPARCOL
+if(nverbia > 0)then
+print *,' **OPER_UV** XPARCOLUVSTD ',XPARCOLUVSTD
+endif
+DO JILOOP=1,SIZE(PTEM2D,1)
+DO JJLOOP=1,SIZE(PTEM2D,2)
+
+IF(PTEM2D(JILOOP,JJLOOP) /= XSPVAL)THEN
+ IF(PTEM2D(JILOOP,JJLOOP) < XPARCOLUVSTD(1))THEN
+ NCOL2DUV(JJLOOP,JILOOP)=NCOLUVSTD(1)
+ ELSE IF(PTEM2D(JILOOP,JJLOOP) >= XPARCOLUVSTD&
+ (NBPARCOLUVSTD))THEN
+ NCOL2DUV(JJLOOP,JILOOP)=NCOLUVSTD(NBCOLUVSTD)
+ ELSE
+ DO JKLOOP=2,NBPARCOLUVSTD
+ IF(PTEM2D(JILOOP,JJLOOP) >= XPARCOLUVSTD(&
+ JKLOOP-1) .AND. PTEM2D(JILOOP,JJLOOP)<&
+ XPARCOLUVSTD(JKLOOP))then
+ NCOL2DUV(JJLOOP,JILOOP)=NCOLUVSTD(&
+ JKLOOP)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ENDIF
+
+
+ENDDO
+ENDDO
+
+ ENDIF !::::::::::::::::::::::::::::::::::
+!
+!* 1.2
+!*
+!*
+!*
+!
+!
+!* 1.3
+!
+IF(nverbia > 0)THEN
+ print *,' ** colvect '
+endif
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE COLVECT
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/compcoord_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/compcoord_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9e42dc37b126430a6d10e62809e54e7dc0e0f172
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/compcoord_fordiachro.f90
@@ -0,0 +1,408 @@
+! ######spl
+ SUBROUTINE COMPCOORD_FORDIACHRO(KGRID)
+! ######################################
+!
+!!**** *COMPCOORD_FORDIACHRO* - Computes gridpoint locations,
+!! meshsizes and topography
+!! for all the possible grids, and true altitude where
+!! required.
+!!
+!! PURPOSE
+!! -------
+! When called for the first time (KGRID=0), COMPCOORD_FORDIACHRO returns for
+! the 7 possible grid locations:
+! - XHAT, YHAT, ZHAT values (meters) stored in:
+! XXX(:,1:7), XXY(:,1:7), XXZ(:,1:7)
+! - meshsizes values (meters):
+! XXDXHAT(:,1:7), XXDYHAT(:,1:7)
+! - topography altitudes values (meters):
+! XXZS(:,:,1:7)
+!
+! When called subsequently (0<KGRID<8), COMPCOORD_FORDIACHRO returns the true
+! gridpoint altitude (meters) corresponding to the requested KGRID value
+! in the XZZ(:,:,:) array.
+!
+!!** METHOD
+!! ------
+!! Temporary arrays are allocated to store the grid point characteristics
+!! and de-allocated on exit. The 3D gridpoints locations are linearly
+!! interpolated to the expected grid location from their respective
+!! nominal locations. Altitudes are interpolated for the w-grid values,
+!! which are obtained directly from the Gal-Chen Sommerville formula.
+!! For XXX, XXY, XXZ, XXDXHAT, XXDYHAT, XXZS the last index is the grid
+!! selector KGRID ranging from 1 to 7 as follows:
+!! 1 -> Mass grid,
+!! 2 -> U grid,
+!! 3 -> V grid,
+!! 4 -> W grid,
+!! 5 -> Vertical vorticity grid,
+!! 6 -> y-component vorticity grid,
+!! 7 -> x-component vorticity grid.
+!! all the 7 values are prepared one for all in this subroutine and passed
+!! to the general TRACE environment to be used in the display process.
+!!
+!! For the XZZ array the last index is the z direction one, not the grid
+!! selector one.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!!
+!! XXX,XXY,XXZ : coordinate values for all the MESO-NH grids
+!! XXDXHAT,XXDYHAT,XXDZHAT: meshsize values for all the MESO-NH grids
+!! XXZS : topography values for all the MESO_NH grids
+!!
+!! Module MODD_GRID1 : declares grid variables (Model module)
+!!
+!! XXHAT, XYHAT : x, y in the conformal or cartesian plane
+!! XZHAT : Gal-Chen z level
+!! XZS : topography zs
+!! XZZ : true gridpoint z altitude
+!!
+!! Module MODD_DIM1 : Contains dimensions
+!!
+!! NIMAX,NJMAX,NKMAX : x, y, and z array dimensions
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!!
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! The 7 MESO-NH grid types are defined in:
+!! - Asencio N. et al., 1994, "Le projet de modele non-hydrostatique
+!! commun CNRM-LA, specifications techniques",
+!! Note CNRM/GMME, 26, 139p, (pages 39 to 43).
+!!
+!! - Fischer C., 1994, "File structure and content in the Meso-NH
+!! model", Meso-nh internal note, CNRM/GMME, July 5.
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_COORD
+USE MODD_DIM1
+USE MODD_CONF
+USE MODD_GRID1
+USE MODD_PARAMETERS
+USE MODD_MEMCV
+USE MODD_RESOLVCAR
+!
+USE MODI_VERT_COORD
+!
+IMPLICIT NONE
+!
+!* 0.1 Local variables declarations
+!
+INTEGER :: IIU, IJU, IKU
+
+INTEGER :: IIB, IJB, IKB
+
+INTEGER :: IIE, IJE, IKE
+!
+! Calcul des X, Y, Z aux points de masse
+REAL,DIMENSION(:),ALLOCATABLE :: ZXMASS, ZYMASS, ZZMASS
+
+REAL,DIMENSION(:),ALLOCATABLE :: ZXTEM, ZYTEM, ZZTEM, &
+ ZDXTEM, ZDYTEM, ZDZTEM
+
+REAL,DIMENSION(:,:),ALLOCATABLE :: ZZSTEM
+
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZSCOEF
+
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: ZSZ
+
+REAL,SAVE :: ZSH
+
+INTEGER :: JGRIDLOOP, KGRID, &
+ OKZXTEM, OKZYTEM, OKZZTEM, OKZDXTEM, OKZDYTEM, OKZDZTEM, &
+ OKZZSTEM, OKZSCOEF, OKZXMASS, OKZYMASS, OKZZMASS, OKXXZS, OKXZZ, OKZSZ
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. ARRAY DIMENSIONS SETTOING
+! -------------------------
+!
+if(nverbia > 0)then
+if (LEN(CDIRCUR) .LT. 500)THEN
+print *,' **COMPCOORD KGRID DIRCUR ',KGRID,CDIRCUR(1:LEN_TRIM(CDIRCUR))
+endif
+endif
+IIU=NIMAX+2*JPHEXT
+IJU=NJMAX+2*JPHEXT
+IKU=NKMAX+2*JPVEXT
+IF(CSTORAGE_TYPE == 'PG' .OR. CSTORAGE_TYPE == 'SU')THEN
+ IKU=1
+ENDIF
+IIB=1+JPHEXT
+IJB=1+JPHEXT
+IKB=1+JPVEXT
+IIE=IIU-JPHEXT
+IJE=IJU-JPHEXT
+IKE=IKU-JPVEXT
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. CALCULATIONS PERFORMED FOR THE FIRST CALL
+! ----------------------------------------
+!
+! Test on KGRID selects processing mode:
+! . KGRID=0 --> X, Y, Z + meshsizes + topography computed for ALL the
+! possible grid geometry.
+! . 0<KGRID<8 --> true altitude computed for the KGRID gridpoints
+
+IF(KGRID==0)THEN ! if "KGRID=1" selected
+
+!
+!* 2.1 Array allocation when called for the first time
+!
+! 1D Arrays
+!
+ ALLOCATE(ZXTEM(1:IIU),STAT=OKZXTEM) ! RINT *,' OKZXTEM',OKZXTEM
+ ALLOCATE(ZYTEM(1:IJU),STAT=OKZYTEM) !PRINT *,' OKZYTEM',OKZYTEM
+ ALLOCATE(ZZTEM(1:IKU),STAT=OKZZTEM) !PRINT *,' OKZZTEM',OKZZTEM
+
+ ALLOCATE(ZDXTEM(1:IIU),STAT=OKZDXTEM) !PRINT *,' OKZDXTEM',OKZDXTEM
+ ALLOCATE(ZDYTEM(1:IJU),STAT=OKZDYTEM) !PRINT *,' OKZDYTEM',OKZDYTEM
+ ALLOCATE(ZDZTEM(1:IKU),STAT=OKZDZTEM) !PRINT *,' OKZDZTEM',OKZDZTEM
+
+ ALLOCATE(ZXMASS(1:IIU),STAT=OKZXMASS) !PRINT *,' OKZXMASS',OKZXMASS
+ ALLOCATE(ZYMASS(1:IJU),STAT=OKZYMASS) !PRINT *,' OKZYMASS',OKZYMASS
+ ALLOCATE(ZZMASS(1:IKU),STAT=OKZZMASS) !PRINT *,' OKZZMASS',OKZZMASS
+
+! 2D Arrays
+!
+ ALLOCATE(ZZSTEM(1:IIU,1:IJU),STAT=OKZZSTEM) !PRINT *,' OKZZSTEM',OKZZSTEM
+!
+ IF(ALLOCATED(ZSCOEF))THEN
+ DEALLOCATE(ZSCOEF)
+ END IF
+ ALLOCATE(ZSCOEF(1:IIU,1:IJU),STAT=OKZSCOEF) !PRINT *,' OKZSCOEF',OKZSCOEF
+ IF(ALLOCATED(XXX))THEN
+ DEALLOCATE(XXX)
+ END IF
+ ALLOCATE(XXX(1:IIU,7))
+ IF(ALLOCATED(XXY))THEN
+ DEALLOCATE(XXY)
+ END IF
+ ALLOCATE(XXY(1:IJU,7))
+ IF(ALLOCATED(XXZ))THEN
+ DEALLOCATE(XXZ)
+ END IF
+ ALLOCATE(XXZ(1:IKU,7))
+ IF(ALLOCATED(XXDXHAT))THEN
+ DEALLOCATE(XXDXHAT)
+ END IF
+ ALLOCATE(XXDXHAT(1:IIU,7))
+ IF(ALLOCATED(XXDYHAT))THEN
+ DEALLOCATE(XXDYHAT)
+ END IF
+ ALLOCATE(XXDYHAT(1:IJU,7))
+
+! 3D Arrays
+!
+ IF(ALLOCATED(XXZS))THEN
+ DEALLOCATE(XXZS)
+ END IF
+ ALLOCATE(XXZS(1:IIU,1:IJU,7),STAT=OKXXZS) !PRINT *,' OKXXZS',OKXXZS
+ IF(ALLOCATED(ZSZ))THEN
+ DEALLOCATE(ZSZ)
+ END IF
+ ALLOCATE(ZSZ(1:IIU,1:IJU,IKU),STAT=OKZSZ) !PRINT *,' OKZSZ',OKZSZ
+!
+!* 2.2 Computes true altitudes on the W grid (KGRID=4)
+!
+
+IF(CSTORAGE_TYPE /= 'PG' .AND. CSTORAGE_TYPE /='SU')THEN
+ print *,' ******* COMPCOORD_FORDIACHRO ZHAT(IKE+1) ',XZHAT(IKE+1)
+ CALL VERT_COORD(LSLEVE,XZS,XZSMT,XLEN1,XLEN2,XZHAT,ZSZ)
+ENDIF
+!
+!* 2.3 Interpolates XHAT, YHAT, ZHAT at mass gridpoints
+!
+
+ ZXMASS(1:IIU-1)=.5*(XXHAT(2:IIU)+XXHAT(1:IIU-1))
+ ZXMASS(IIU)=2.*ZXMASS(IIU-1)-ZXMASS(IIU-2)
+ ZYMASS(1:IJU-1)=.5*(XYHAT(2:IJU)+XYHAT(1:IJU-1))
+ ZYMASS(IJU)=2.*ZYMASS(IJU-1)-ZYMASS(IJU-2)
+ IF(IKU == 1)THEN
+ ZZMASS(1:IKU)=XZHAT(1:IKU)
+ !ZZMASS(1:IKU)=.5*(XZHAT(2:IKU)+XZHAT(1:IKU-1)) !!! size(XZHAT)=1 !!!
+ ELSE
+ ZZMASS(1:IKU-1)=.5*(XZHAT(2:IKU)+XZHAT(1:IKU-1))
+ ZZMASS(IKU)=2.*ZZMASS(IKU-1)-ZZMASS(IKU-2)
+ ENDIF
+
+!
+!* 2.4 Interpolates X, Y, Z, meshsizes, and topography
+!* for all the KGRID selection locations
+!
+ DO JGRIDLOOP=1,7
+
+ SELECT CASE(JGRIDLOOP)
+
+ CASE(1)
+ ZXTEM(:)=ZXMASS(:)
+ ZYTEM(:)=ZYMASS(:)
+ ZZTEM(:)=ZZMASS(:)
+ ZZSTEM(:,:)=XZS(:,:)
+
+ CASE(2)
+ ZXTEM(:)=XXHAT(:)
+ ZYTEM(:)=ZYMASS(:)
+ ZZTEM(:)=ZZMASS(:)
+ ZZSTEM(2:IIU,:)=.5*(XZS(2:IIU,:)+XZS(1:IIU-1,:))
+ ZZSTEM(1,:)=XZS(1,:)
+
+ CASE(3)
+ ZXTEM(:)=ZXMASS(:)
+ ZYTEM(:)=XYHAT(:)
+ ZZTEM(:)=ZZMASS(:)
+ ZZSTEM(:,2:IJU)=.5*(XZS(:,2:IJU)+XZS(:,1:IJU-1))
+ ZZSTEM(:,1)=XZS(:,1)
+
+ CASE(4)
+ ZXTEM(:)=ZXMASS(:)
+ ZYTEM(:)=ZYMASS(:)
+ ZZTEM(:)=XZHAT(:)
+ ZZSTEM(:,:)=XZS(:,:)
+
+ CASE(5)
+ ZXTEM(:)=XXHAT(:)
+ ZYTEM(:)=XYHAT(:)
+ ZZTEM(:)=ZZMASS(:)
+ ZZSTEM(2:IIU,:)=.5*(XZS(2:IIU,:)+XZS(1:IIU-1,:))
+ ZZSTEM(1,:)=XZS(1,:)
+ ZZSTEM(:,2:IJU)=.5*(ZZSTEM(:,2:IJU)+ZZSTEM(:,1:IJU-1))
+ ZZSTEM(:,1)=ZZSTEM(:,2)
+
+ CASE(6)
+ ZXTEM(:)=XXHAT(:)
+ ZYTEM(:)=ZYMASS(:)
+ ZZTEM(:)=XZHAT(:)
+ ZZSTEM(2:IIU,:)=.5*(XZS(2:IIU,:)+XZS(1:IIU-1,:))
+ ZZSTEM(1,:)=XZS(1,:)
+
+ CASE(7)
+ ZXTEM(:)=ZXMASS(:)
+ ZYTEM(:)=XYHAT(:)
+ ZZTEM(:)=XZHAT(:)
+ ZZSTEM(:,2:IJU)=.5*(XZS(:,2:IJU)+XZS(:,1:IJU-1))
+ ZZSTEM(:,1)=XZS(:,1)
+
+ END SELECT
+
+ ZDXTEM(1:IIU-1)=ZXTEM(2:IIU)-ZXTEM(1:IIU-1)
+!
+! NOTICE: An extra meshlength is added to the max size of the arrays
+! in order to avoid a lot of testing hereafter...
+!
+ ZDXTEM(IIU)=ZDXTEM(IIU-1)
+ ZDYTEM(1:IJU-1)=ZYTEM(2:IJU)-ZYTEM(1:IJU-1)
+ ZDYTEM(IJU)=ZDYTEM(IJU-1)
+ IF(IKU /= 1)THEN
+ ZDZTEM(1:IKU-1)=ZZTEM(2:IKU)-ZZTEM(1:IKU-1)
+ ZDZTEM(IKU)=ZDZTEM(IKU-1)
+ ENDIF
+
+! X, Y, Z as functions of KGRID
+ XXX(:,JGRIDLOOP)=ZXTEM
+ XXY(:,JGRIDLOOP)=ZYTEM
+ XXZ(:,JGRIDLOOP)=ZZTEM
+
+! Topography as a function of KGRID
+ XXZS(:,:,JGRIDLOOP)=ZZSTEM
+
+! Meshsizes as functions of KGRID
+ XXDXHAT(:,JGRIDLOOP)=ZDXTEM(:)
+ XXDYHAT(:,JGRIDLOOP)=ZDYTEM(:)
+
+ ENDDO
+
+ DEALLOCATE(ZXMASS,ZYMASS,ZZMASS)
+ DEALLOCATE(ZXTEM,ZYTEM,ZZTEM)
+ DEALLOCATE(ZDXTEM,ZDYTEM,ZDZTEM)
+ DEALLOCATE(ZZSTEM)
+
+!-------------------------------------------------------------------------------
+!
+!* 3. CALCULATIONS PERFORMED FOR ALL SUBSEQUENT CALLS
+! -----------------------------------------------
+!
+ELSE ! else if KGRID =/=1 selected
+
+! True altitudes
+
+ SELECT CASE(KGRID)
+
+ CASE(1)
+ XZZ(:,:,1:IKU-1)=0.5*(ZSZ(:,:,1:IKU-1)+ZSZ(:,:,2:IKU))
+ XZZ(:,:,IKU)=2.*XZZ(:,:,IKU-1)-XZZ(:,:,IKU-2)
+
+ CASE(2)
+ XZZ(:,:,1:IKU-1)=0.5*(ZSZ(:,:,1:IKU-1)+ZSZ(:,:,2:IKU))
+ XZZ(:,:,IKU)=2.*XZZ(:,:,IKU-1)-XZZ(:,:,IKU-2)
+ XZZ(2:IIU,:,:)=0.5*(XZZ(2:IIU,:,:)+XZZ(1:IIU-1,:,:))
+ XZZ(1,:,:)=2*XZZ(2,:,:)-XZZ(3,:,:)
+
+ CASE(3)
+ XZZ(:,:,1:IKU-1)=0.5*(ZSZ(:,:,1:IKU-1)+ZSZ(:,:,2:IKU))
+ XZZ(:,:,IKU)=2.*XZZ(:,:,IKU-1)-XZZ(:,:,IKU-2)
+ XZZ(:,2:IJU,:)=0.5*(XZZ(:,2:IJU,:)+XZZ(:,1:IJU-1,:))
+ XZZ(:,1,:)=2*XZZ(:,2,:)-XZZ(:,3,:)
+
+ CASE(4)
+ XZZ(:,:,:)=ZSZ(:,:,:)
+
+ CASE(5)
+ XZZ(:,:,1:IKU-1)=0.5*(ZSZ(:,:,1:IKU-1)+ZSZ(:,:,2:IKU))
+ XZZ(:,:,IKU)=2.*XZZ(:,:,IKU-1)-XZZ(:,:,IKU-2)
+ XZZ(2:IIU,:,:)=0.5*(XZZ(2:IIU,:,:)+XZZ(1:IIU-1,:,:))
+ XZZ(1,:,:)=2*XZZ(2,:,:)-XZZ(3,:,:)
+ XZZ(:,2:IJU,:)=0.5*(XZZ(:,2:IJU,:)+XZZ(:,1:IJU-1,:))
+ XZZ(:,1,:)=2*XZZ(:,2,:)-XZZ(:,3,:)
+
+ CASE(6)
+ XZZ(2:IIU,:,:)=0.5*(ZSZ(2:IIU,:,:)+ZSZ(1:IIU-1,:,:))
+ XZZ(1,:,:)=2*XZZ(2,:,:)-XZZ(3,:,:)
+
+ CASE(7)
+ XZZ(:,2:IJU,:)=0.5*(ZSZ(:,2:IJU,:)+ZSZ(:,1:IJU-1,:))
+ XZZ(:,1,:)=2*XZZ(:,2,:)-XZZ(:,3,:)
+
+ END SELECT
+
+END IF ! End KGRID selection
+!
+!---------------------------------------------------------------------------
+!
+!* 4. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE COMPCOORD_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/complat.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/complat.f90
new file mode 100644
index 0000000000000000000000000000000000000000..197649d353e0c1c23e47f21ba4c70e5840863ec4
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/complat.f90
@@ -0,0 +1,110 @@
+! ######spl
+ SUBROUTINE COMPLAT(PLAT)
+! ############################
+!
+!!**** *COMPLAT* -
+!!****
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!! COS ! trigonometric functions
+!! SIN !
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 22/02/2000
+!! Updated
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_COORD
+USE MODD_NMGRID
+USE MODD_GRID1
+USE MODD_GRID, ONLY: XLONORI,XLATORI
+USE MODE_GRIDPROJ
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments and results
+!
+REAL, DIMENSION(:,:), INTENT(OUT) :: PLAT
+!
+
+!* 0.2 Local variables
+!
+INTEGER :: II, IJ
+INTEGER :: JILOOP, JJLOOP
+!
+REAL,DIMENSION(:), ALLOCATABLE,SAVE :: ZY
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: ZLA, ZLO, ZYY, ZX
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTING THE LONGITUDINAL AND TRANSVERSE COMPONENTS
+! ----------------------------------------------------
+!
+!* 1.1 Array sizes calculations
+!
+II=SIZE(PLAT,1)
+IJ=SIZE(PLAT,2)
+!
+!* 1.2 Array allocations
+!
+IF (ALLOCATED(ZX))THEN
+ DEALLOCATE(ZX)
+ENDIF
+IF (ALLOCATED(ZY))THEN
+ DEALLOCATE(ZY)
+ENDIF
+IF (ALLOCATED(ZYY))THEN
+ DEALLOCATE(ZYY)
+ENDIF
+IF (ALLOCATED(ZLA))THEN
+ DEALLOCATE(ZLA)
+ENDIF
+IF (ALLOCATED(ZLO))THEN
+ DEALLOCATE(ZLO)
+ENDIF
+
+ALLOCATE(ZX(II,1),ZY(IJ))
+ALLOCATE(ZYY(II,1),ZLA(II,1),ZLO(II,1))
+!
+ZX(:,1)=XXX(:,NMGRID)
+ZY(:)=XXY(:,NMGRID)
+DO JJLOOP=1,IJ
+ DO JILOOP=1,II
+ ZYY(JILOOP,1)=ZY(JJLOOP)
+ ENDDO
+ CALL SM_LATLON_A(XLATORI,XLONORI,ZX,ZYY,ZLA,ZLO)
+ PLAT(:,JJLOOP)=ZLA(:,1)
+ENDDO
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE COMPLAT
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/conv2xy.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/conv2xy.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bb3a50ea04d7c90086d59bafd4042bbd996d1269
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/conv2xy.f90
@@ -0,0 +1,140 @@
+! ######spl
+ MODULE MODI_CONV2XY
+! ####################
+!
+INTERFACE
+!
+SUBROUTINE CONV2XY(PXX,PYY,PX,PY,K)
+REAL :: PXX,PYY,PX,PY
+INTEGER,INTENT(IN) :: K
+END SUBROUTINE CONV2XY
+!
+END INTERFACE
+!
+END MODULE MODI_CONV2XY
+! ######spl
+ SUBROUTINE CONV2XY(PXX,PYY,PX,PY,K)
+! ###################################
+!
+!!**** *CONV2XY* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 16/06/98
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_COORD
+USE MODD_DIM1
+USE MODD_CONF
+USE MODD_GRID1
+USE MODD_GRID, ONLY: XLONORI,XLATORI
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_FILES_DIACHRO
+USE MODE_GRIDPROJ
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+!
+REAL :: PXX,PYY,PX,PY
+INTEGER,INTENT(IN) :: K
+!
+!* 0.1 Local variables
+! ---------------
+!
+INTEGER :: J,JM,JMCUR
+INTEGER :: IINF, IJINF, ISUP, IJSUP
+LOGICAL :: GOK
+! !------------------------------------------------------------------------------
+GOK=.FALSE.
+IINF=NIINF; ISUP=NISUP; IJINF=NJINF; IJSUP=NJSUP
+IF(ALLOCATED(XXHAT))THEN
+ELSE
+ IF (NBFILES == 1)THEN
+ ELSE
+ DO J=1,NBFILES
+ IF(NUMFILES(J)==NUMFILECUR)THEN
+ JMCUR=J
+ if(nverbia > 0)then
+ print *,' CONV2XY J JMCUR ',J,JMCUR
+ endif
+ EXIT
+ ENDIF
+ ENDDO
+ DO J=1,NBFILES
+ IF(NUMFILES(J)==NUMFILECUR)THEN
+ CYCLE
+ ELSE
+ JM=J
+ if(nverbia > 0 )THEN
+ print *,' CONV2XY JM,CFILEDIAS(JM) ',JM,CFILEDIAS(JM)
+ ENDIF
+ CALL READ_FILEHEAD(JM,CFILEDIAS(JM),CLUOUTDIAS(JM))
+ IF(NIMAX /= 0)THEN
+ GOK=.TRUE.
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ENDIF
+IF(ALLOCATED(XXHAT))THEN
+IF(LCONV2XY .AND. NLATLON /= 0)THEN
+ CALL SM_XYHAT_S(XLATORI,XLONORI,PXX,PYY, &
+ PX,PY)
+ IF(K == 11)THEN
+ PXX=PX
+ ELSE IF(K == 12)THEN
+ PXX=PY
+ ELSE IF(K == 21)THEN
+ PYY=PX
+ ELSE IF(K == 22)THEN
+ PYY=PY
+ ENDIF
+ENDIF
+ELSE
+ print *,' Absence d''entete dans les differents fichiers ouverts'
+ print *,' Impossibilite de convertir les coordonnees geographiques en conformes '
+ print *,' LCONV2XY remis a .FALSE. '
+ LCONV2XY=.FALSE.
+ENDIF
+IF(GOK)THEN
+ CALL READ_FILEHEAD(JMCUR,CFILEDIAS(JMCUR),CLUOUTDIAS(JMCUR))
+ENDIF
+NIINF=IINF; NISUP=ISUP; NJINF=IJINF; NJSUP=IJSUP
+RETURN
+END SUBROUTINE CONV2XY
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/convallij2ll.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/convallij2ll.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3e2d4e52f6ca581f30615ac36a979e7d12cfdcf2
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/convallij2ll.f90
@@ -0,0 +1,220 @@
+! ######spl
+ SUBROUTINE CONVALLIJ2LL(HCARIN)
+! ###############################
+!
+!!**** *CONVALLIJ2LL* - Convertit des indices de grille I,J en coordonnees
+!! conformes et coordonnees geographiques
+!! sur l'ensemble du domaine (points de garde)
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_CONVIJ2XY
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX : XXHAT coordinate values for all the MESO-NH grids
+!! XXY : XYHAT "
+!!
+!! Module MODE_GRIDPROJ
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 01/04/99
+!! Updated
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODE_GRIDPROJ
+USE MODD_COORD
+USE MODD_FILES_DIACHRO
+USE MODD_CONF
+USE MODD_GRID
+USE MODD_DIM1
+USE MODD_GRID1
+USE MODD_GRID, ONLY: XLONORI,XLATORI
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_RESOLVCAR
+USE MODD_CONVIJ2XY
+USE MODD_PARAMETERS
+USE MODI_RESOLVXISOLEV
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+!
+CHARACTER(LEN=2400) :: HCARIN
+!
+!* 0.2 Local variables
+!
+INTEGER :: IMGRID, J, I, JM, INUM, IRESP
+INTEGER :: IEGAL, IG, ITER, II, IDEB, IFIN
+INTEGER :: IIU, IJU, ICONVALLIJ2LL, ICONVI, ICONVJ
+REAL,DIMENSION(:,:),ALLOCATABLE :: ZLAT,ZLON
+REAL :: ZX1, ZY1, ZLA, ZLO
+!REAL,DIMENSION(:),ALLOCATABLE :: ZCONVLAT, ZCONVLON
+!
+REAL,DIMENSION(100) :: ZIJ
+!
+!-------------------------------------------------------------------------------
+!
+!* 1.
+! ----------------------------
+!
+IIU=NIMAX+2*JPHEXT
+IJU=NJMAX+2*JPHEXT
+CALL INI_CST
+!
+!
+!* 1.1
+!
+HCARIN=ADJUSTL(HCARIN)
+if(nverbia >0)then
+ print *,' **CONVALLIJ2LL HCARIN ',TRIM(HCARIN)
+endif
+IF(NBFILES == 0)THEN
+ print *,' Vous devez ouvrir le fichier pour lequel vous demandez l''information avec _file1_...'
+ print *,' puis entrer a nouveau votre directive '
+ LPBREAD=.TRUE.
+ RETURN
+ENDIF
+CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' CONVALLIJ2LL --> Les valeurs seront mises dans le fichier FICVAL '')'
+ENDIF
+IF (LCARTESIAN) THEN
+ print *,' In the cartesian geometry, reference latitude and longitude are the same for the whole domain:'
+ print *,XLAT0,XLON0
+ LPBREAD=.TRUE.
+ RETURN
+ENDIF
+
+ICONVALLIJ2LL=INDEX(HCARIN,'CONVALLIJ2LL')
+ZIJ(:)=9999.
+IEGAL=INDEX(HCARIN,'=')
+IF(IEGAL == 0)THEN
+ JM=4
+ ZIJ(1)=1.
+ ZIJ(2)=2.
+ ZIJ(3)=3.
+ ZIJ(4)=5.
+ELSE
+CALL RESOLVXISOLEV(HCARIN(1:LEN_TRIM(HCARIN)),ICONVALLIJ2LL,ZIJ)
+DO J=SIZE(ZIJ,1),1,-1
+ IF(ZIJ(J) /= 9999.)THEN
+ JM=J
+ EXIT
+ ENDIF
+ENDDO
+ENDIF
+if(nverbia >0)then
+ print *,' ZIJ ',ZIJ(1:JM)
+endif
+ALLOCATE(XCONVI(IIU))
+ALLOCATE(XCONVJ(IJU))
+ALLOCATE(ZLAT(IIU,IJU))
+ALLOCATE(ZLON(IIU,IJU))
+DO I=1,IIU
+ XCONVI(I)=I
+ENDDO
+DO J=1,IJU
+ XCONVJ(J)=J
+ENDDO
+IF(NVERBIA > 0)THEN
+ENDIF
+DO IG=1,JM
+
+IMGRID=ZIJ(IG)
+DO J=1,IJU
+DO I=1,IIU
+ICONVI=INT(XCONVI(I))
+ICONVJ=INT(XCONVJ(J))
+!IF(I < 5 .AND. J < 5)print *,' IMGRID,ICONVI,ICONVJ ',IMGRID,ICONVI,ICONVJ
+ZX1=XXX(ICONVI,IMGRID)+(XXX(MIN(ICONVI+1,SIZE(XXX,1)),IMGRID)-XXX(ICONVI,IMGRID))*(XCONVI(I)-FLOAT(ICONVI))
+ZY1=XXY(ICONVJ,IMGRID)+(XXY(MIN(ICONVJ+1,SIZE(XXY,1)),IMGRID)-XXY(ICONVJ,IMGRID))*(XCONVJ(J)-FLOAT(ICONVJ))
+CALL SM_LATLON_S(XLATORI,XLONORI,ZX1,ZY1,ZLA,ZLO)
+ZLAT(I,J)=ZLA
+ZLON(I,J)=ZLO
+!IF(I < 5 .AND. J < 5)print *,' ZLA,ZLO ',ZLA,ZLO
+ENDDO
+ENDDO
+ITER=IIU/3
+IF(ITER*3 < IIU)ITER=ITER+1
+IF(IMGRID == 1 .OR. IMGRID == 4)THEN
+WRITE(INUM,*)' FICHIER: ',CFILEDIAS(NUMFILECUR)
+WRITE(INUM,*)' GRILLES N: 1 et 4 ITER:',ITER,' CONVERSION I,J -> LAT,LON '
+ELSE IF(IMGRID == 2 .OR. IMGRID == 6)THEN
+WRITE(INUM,*)' FICHIER: ',CFILEDIAS(NUMFILECUR)
+WRITE(INUM,*)' GRILLES N: 2 et 6 ITER:',ITER,' CONVERSION I,J -> LAT,LON '
+ELSE IF(IMGRID == 3 .OR. IMGRID == 7)THEN
+WRITE(INUM,*)' FICHIER: ',CFILEDIAS(NUMFILECUR)
+WRITE(INUM,*)' GRILLES N: 3 et 7 ITER:',ITER,' CONVERSION I,J -> LAT,LON '
+ELSE IF(IMGRID == 5)THEN
+WRITE(INUM,*)' FICHIER: ',CFILEDIAS(NUMFILECUR)
+WRITE(INUM,*)' GRILLE N: 5 ITER:',ITER,' CONVERSION I,J -> LAT,LON '
+ENDIF
+WRITE(INUM,'('' niinf'',i4,'' njinf'',i4,'' nisup'',i4,'' njsup'',i4)')LBOUND(ZLAT,1),&
+LBOUND(ZLAT,2),IIU,IJU
+WRITE(INUM,'('' NBVAL en I '',i4,'' NBVAL en J '',i4)')IIU,IJU
+DO I=1,ITER
+ IF(I == 1)THEN
+ IDEB=1; IFIN=3
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+3
+ IF(I == ITER)THEN
+ IFIN=IIU
+ ENDIF
+ ENDIF
+ WRITE(INUM,'(1X,78(1H*))')
+ WRITE(INUM,'('' I-> '',7X,I4,9X,2(9X,I4,9X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'('' J '',3X,''Lat , Lon'',6X,2(8X,''Lat , Lon'',6X))')
+ WRITE(INUM,'(1X,78(1H*))')
+ DO J=IJU,1,-1
+! WRITE(INUM,'(I3,3('' *'',F10.5,'' ,'',F10.5,1X))')J,ZLAT(IDEB,J), &
+! ZLON(IDEB,J),ZLAT(IDEB+1,J),ZLON(IDEB+1,J),ZLAT(IDEB+2,J),ZLON(IDEB+2,J)
+ WRITE(INUM,'(I4,3('' *'',F10.5,'' ,'',F10.5,1X))')J,(ZLAT(II,J), &
+ ZLON(II,J),II=IDEB,IFIN)
+ ENDDO
+ENDDO
+ENDDO
+DEALLOCATE(XCONVI)
+DEALLOCATE(XCONVJ)
+DEALLOCATE(ZLAT)
+DEALLOCATE(ZLON)
+!DEALLOCATE(ZCONVLAT)
+!DEALLOCATE(ZCONVLON)
+
+!
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+!
+RETURN
+END SUBROUTINE CONVALLIJ2LL
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/convij2xy.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/convij2xy.f90
new file mode 100644
index 0000000000000000000000000000000000000000..128fcbd87a560b30fbe9f6a4df3ce41ec13e71be
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/convij2xy.f90
@@ -0,0 +1,221 @@
+! ######spl
+ MODULE MODI_CONVIJ2XY
+! ######################
+!
+INTERFACE
+!
+SUBROUTINE CONVIJ2XY(HCARIN)
+CHARACTER(LEN=*) :: HCARIN
+END SUBROUTINE CONVIJ2XY
+!
+END INTERFACE
+!
+END MODULE MODI_CONVIJ2XY
+! ######spl
+ SUBROUTINE CONVIJ2XY(HCARIN)
+! ##################
+!
+!!**** *CONVIJ2XY* - Convertit des indices de grille I,J en coordonnees
+!! conformes et coordonnees geographiques
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_CONIJ2XY
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX : XXHAT coordinate values for all the MESO-NH grids
+!! XXY : XYHAT "
+!!
+!! Module MODE_GRIDPROJ
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 01/04/99
+!! Updated
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODE_GRIDPROJ
+USE MODD_COORD
+USE MODD_FILES_DIACHRO
+USE MODD_CONF
+USE MODD_GRID
+USE MODD_DIM1
+USE MODD_GRID1
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_RESOLVCAR
+USE MODD_CONVIJ2XY
+USE MODD_PARAMETERS
+USE MODI_RESOLVXISOLEV
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+!
+CHARACTER(LEN=*) :: HCARIN
+!
+!* 0.2 Local variables
+!
+INTEGER :: JJLOOP,JILOOP ,IMGRID, J, JJ, I, JM
+INTEGER :: IIU, IJU, ICONVIJ2XY, ICONVI, ICONVJ
+REAL :: ZLAT,ZLON,ZX,ZY
+!REAL,DIMENSION(:),ALLOCATABLE :: ZCONVLAT, ZCONVLON
+!
+REAL,DIMENSION(100) :: ZIJ
+CHARACTER(LEN=8) :: YMGRID
+!
+!-------------------------------------------------------------------------------
+!
+!* 1.
+! ----------------------------
+!
+IIU=NIMAX+2*JPHEXT
+IJU=NJMAX+2*JPHEXT
+CALL INI_CST
+!
+!
+!* 1.1
+!
+HCARIN=ADJUSTL(HCARIN)
+if(nverbia >0)then
+ print *,' **CONVIJ2XY HCARIN ',TRIM(HCARIN)
+endif
+IF(NBFILES == 0)THEN
+ print *,' Vous devez ouvrir le fichier pour lequel vous demandez l''information avec _file1_...'
+ print *,' puis entrer a nouveau votre directive '
+ LPBREAD=.TRUE.
+ RETURN
+ENDIF
+ICONVIJ2XY=INDEX(HCARIN,'CONVIJ2XY')
+ZIJ(:)=9999.
+CALL RESOLVXISOLEV(HCARIN(1:LEN_TRIM(HCARIN)),ICONVIJ2XY,ZIJ)
+DO J=SIZE(ZIJ,1),1,-1
+ IF(ZIJ(J) /= 9999.)THEN
+ JM=J
+ EXIT
+ ENDIF
+ENDDO
+if(nverbia >0)then
+ print *,' ZIJ ',ZIJ(1:JM)
+endif
+ALLOCATE(XCONVIJ(JM))
+ALLOCATE(XCONVI(JM/2))
+ALLOCATE(XCONVJ(JM/2))
+ALLOCATE(XCONVX(JM/2))
+ALLOCATE(XCONVY(JM/2))
+ALLOCATE(XCONVLAT(JM/2))
+ALLOCATE(XCONVLON(JM/2))
+!ALLOCATE(ZCONVLAT(JM/2*7))
+!ALLOCATE(ZCONVLON(JM/2*7))
+J=JM/2
+XCONVIJ(1:JM)=ZIJ(1:JM)
+XCONVI(1:J)=XCONVIJ(1:JM-1:2)
+XCONVJ(1:J)=XCONVIJ(2:JM:2)
+IF(NVERBIA > 0)THEN
+ print *,' convij2xy: XCONVIJ,XCONVI,XCONVJ'
+ print *,XCONVIJ
+ print *,XCONVI,' ',XCONVJ
+ENDIF
+!
+DO IMGRID=1,7
+DO I=1,J
+ICONVI=INT(XCONVI(I))
+ICONVJ=INT(XCONVJ(I))
+XCONVX(I)=XXX(ICONVI,IMGRID)+(XXX(MIN(ICONVI+1,SIZE(XXX,1)),IMGRID)-XXX(ICONVI,IMGRID))*(XCONVI(I)-FLOAT(ICONVI))
+XCONVY(I)=XXY(ICONVJ,IMGRID)+(XXY(MIN(ICONVJ+1,SIZE(XXY,1)),IMGRID)-XXY(ICONVJ,IMGRID))*(XCONVJ(I)-FLOAT(ICONVJ))
+ZX=XCONVX(I); ZY=XCONVY(I)
+IF (.NOT. LCARTESIAN) THEN
+ CALL SM_LATLON_S(XLATORI,XLONORI,ZX,ZY,ZLAT,ZLON)
+ XCONVLAT(I)=ZLAT
+ XCONVLON(I)=ZLON
+ !IF(I == 1)THEN
+ ! ZCONVLAT(IMGRID*2-1)=ZLAT
+ ! ZCONVLON(IMGRID*2-1)=ZLON
+ !ELSE
+ ! ZCONVLAT(IMGRID*2)=ZLAT
+ ! ZCONVLON(IMGRID*2)=ZLON
+ !ENDIF
+ IF(IMGRID == 1 .AND. I == 1)THEN
+print *,' GRILLES * I * J * X * Y * LAT * LON '
+print *,'******************************************************************************'
+ ENDIF
+ELSE
+ IF(IMGRID == 1 .AND. I == 1)THEN
+print *,' GRILLES * I * J * X * Y '
+print *,'*******************************************************'
+ ENDIF
+ENDIF
+IF(IMGRID == 1)THEN
+YMGRID=' 1 et 4 '
+ELSE IF(IMGRID == 2)THEN
+YMGRID=' 2 et 6 '
+ELSE IF(IMGRID == 3)THEN
+YMGRID=' 3 et 7 '
+ELSE IF(IMGRID == 5)THEN
+YMGRID=' 5 '
+ENDIF
+IF(IMGRID == 1 .OR. IMGRID == 2 .OR. IMGRID == 3 .OR. IMGRID == 5)THEN
+IF (.NOT. LCARTESIAN) THEN
+ print 10,YMGRID,XCONVI(I),XCONVJ(I),XCONVX(I),XCONVY(I),XCONVLAT(I),XCONVLON(I)
+ELSE
+ print 20,YMGRID,XCONVI(I),XCONVJ(I),XCONVX(I),XCONVY(I)
+ENDIF
+print *,'------------------------------------------------------------------------------'
+ENDIF
+ENDDO
+ENDDO
+!if (nverbia > 0)then
+!DO I=1,J*7
+! ZLAT=ZCONVLAT(I)
+! ZLON=ZCONVLON(I)
+! CALL SM_XYHAT_S(XLATORI,XLONORI,ZLAT,ZLON,ZX,ZY)
+! print *,' ZLAT=',ZLAT,' ZLON=',ZLON,' ZX=',ZX,' ZY=',ZY
+!ENDDO
+!endif
+10 FORMAT(1X,A8,' *',F6.2,' *',F6.2,' * ',F10.0,' * ',F10.0,' *',F10.6,' *',F11.6)
+20 FORMAT(1X,A8,' *',F6.2,' *',F6.2,' * ',F10.0,' * ',F10.0)
+DEALLOCATE(XCONVIJ)
+DEALLOCATE(XCONVI)
+DEALLOCATE(XCONVJ)
+DEALLOCATE(XCONVX)
+DEALLOCATE(XCONVY)
+DEALLOCATE(XCONVLAT)
+DEALLOCATE(XCONVLON)
+!DEALLOCATE(ZCONVLAT)
+!DEALLOCATE(ZCONVLON)
+
+!
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+!
+RETURN
+END SUBROUTINE CONVIJ2XY
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/convlo2up.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/convlo2up.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2e456f312163e1789b3203a677effe580bd58f76
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/convlo2up.f90
@@ -0,0 +1,427 @@
+! ######spl
+ MODULE MODI_CONVLO2UP
+! #####################
+!
+INTERFACE
+!
+SUBROUTINE CONVLO2UP(HCARIN,HCAROUT)
+CHARACTER(LEN=*) :: HCARIN
+CHARACTER(LEN=*) :: HCAROUT
+END SUBROUTINE CONVLO2UP
+!
+END INTERFACE
+!
+END MODULE MODI_CONVLO2UP
+! ######spl
+ SUBROUTINE CONVLO2UP(HCARIN,HCAROUT)
+! ####################################
+!
+!!**** *CONVLO2UP* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FILES_DIACHRO
+USE MODD_ALLOC_FORDIACHRO
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+CHARACTER(LEN=*) :: HCAROUT
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+CHARACTER(LEN=LEN_TRIM(HCARIN)) :: YCARIN
+CHARACTER(LEN=1),DIMENSION(26),SAVE :: YLO=(/'a','b','c','d','e','f','g', &
+ 'h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y','z'/)
+CHARACTER(LEN=1),DIMENSION(26),SAVE :: YUP=(/'A','B','C','D','E','F','G', &
+ 'H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/)
+INTEGER :: ILENC
+INTEGER :: INDCAR
+INTEGER :: INDTIT, INDPVMIN, INDPVMAX, INDFTMIN, INDFTMAX
+INTEGER :: INDPVKTMIN, INDPVKTMAX
+INTEGER :: INDISOMIN, INDISOMAX, INDDIAINT, INDISOREF
+INTEGER :: INDFT1MIN, INDFT1MAX, INDISOLEV
+
+INTEGER :: J, JA, IBEG, IEND, JJ
+!------------------------------------------------------------------------------
+!
+NBGUIL=0
+HCAROUT(1:LEN(HCAROUT))=' '
+YCARIN = HCARIN
+ILENC = LEN(YCARIN)
+!print *,' HCARIN ',LEN(HCARIN)
+!print *,HCARIN
+DO J=1,ILENC
+ DO JA=1,26
+ IF(YCARIN(J:J) == YLO(JA))YCARIN(J:J)=YUP(JA)
+ ENDDO
+ENDDO
+!print *,' YCARIN ',YCARIN
+INDCAR=INDEX(YCARIN,'CSYMCAR')
+IF(INDCAR /= 0)THEN
+ IF(YCARIN(INDCAR:INDCAR+6)=='CSYMCAR')THEN
+ HCARIN(INDCAR:INDCAR+6)=YCARIN(INDCAR:INDCAR+6)
+ HCAROUT=HCARIN
+ HCAROUT=ADJUSTL(HCAROUT)
+ RETURN
+ ENDIF
+ENDIF
+INDCAR=INDEX(YCARIN,'CNOMCAR')
+IF(INDCAR /= 0)THEN
+ IF(YCARIN(INDCAR:INDCAR+6)=='CNOMCAR')THEN
+ HCARIN(INDCAR:INDCAR+6)=YCARIN(INDCAR:INDCAR+6)
+ HCAROUT=HCARIN
+ HCAROUT=ADJUSTL(HCAROUT)
+ RETURN
+ ENDIF
+ENDIF
+
+INDTIT=INDEX(YCARIN,'CTIT')
+
+IF(INDTIT /= 0)THEN
+
+IF(YCARIN(INDTIT:INDTIT+5)=='CTITT1' .OR. YCARIN(INDTIT:INDTIT+5)=='CTITT2'.OR.&
+ YCARIN(INDTIT:INDTIT+5)=='CTITT3' .OR. YCARIN(INDTIT:INDTIT+5)=='CTITB1'.OR.&
+ YCARIN(INDTIT:INDTIT+5)=='CTITB2' .OR. YCARIN(INDTIT:INDTIT+5)=='CTITB3'.OR.&
+ YCARIN(INDTIT:INDTIT+5)=='CTITYT' .OR. YCARIN(INDTIT:INDTIT+5)=='CTITYM'.OR.&
+ YCARIN(INDTIT:INDTIT+5)=='CTITYB' .OR. YCARIN(INDTIT:INDTIT+5)=='CTITXL'.OR.&
+ YCARIN(INDTIT:INDTIT+5)=='CTITXM' .OR. YCARIN(INDTIT:INDTIT+5)=='CTITXR')THEN
+!print *,' HCARIN ',HCARIN
+ HCARIN(INDTIT:INDTIT+5)=YCARIN(INDTIT:INDTIT+5)
+! HCAROUT=ADJUSTL(HCARIN)
+ HCAROUT=HCARIN
+ HCAROUT=ADJUSTL(HCAROUT)
+!print *,' HCARIN ',HCARIN
+!print *,' HCAROUT ',HCAROUT
+ RETURN
+ENDIF
+IF(YCARIN(INDTIT:INDTIT+7)=='CTITVAR1' .OR. YCARIN(INDTIT:INDTIT+7)=='CTITVAR2'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CTITVAR3' .OR. YCARIN(INDTIT:INDTIT+7)=='CTITVAR4'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CTITVAR5' .OR. YCARIN(INDTIT:INDTIT+7)=='CTITVAR6'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CTITVAR7' .OR. YCARIN(INDTIT:INDTIT+7)=='CTITVAR8')THEN
+!print *,' HCARIN ',HCARIN
+ HCARIN(INDTIT:INDTIT+7)=YCARIN(INDTIT:INDTIT+7)
+! HCAROUT=ADJUSTL(HCARIN)
+ HCAROUT=HCARIN
+ HCAROUT=ADJUSTL(HCAROUT)
+!print *,' HCARIN ',HCARIN
+!print *,' HCAROUT ',HCAROUT
+ RETURN
+ENDIF
+
+ENDIF
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+INDTIT=INDEX(YCARIN,'CFT1TIT')
+!
+IF(INDTIT /= 0)THEN
+!
+IF(YCARIN(INDTIT:INDTIT+7)=='CFT1TIT1' .OR. YCARIN(INDTIT:INDTIT+7)=='CFT1TIT2'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CFT1TIT3' .OR. YCARIN(INDTIT:INDTIT+7)=='CFT1TIT4'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CFT1TIT5' .OR. YCARIN(INDTIT:INDTIT+7)=='CFT1TIT6'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CFT1TIT7' .OR. YCARIN(INDTIT:INDTIT+7)=='CFT1TIT8'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CFT1TIT9')THEN
+
+ HCARIN(INDTIT:INDTIT+7)=YCARIN(INDTIT:INDTIT+7)
+ HCAROUT=HCARIN
+ HCAROUT=ADJUSTL(HCAROUT)
+!print *,' HCARIN ',HCARIN
+!print *,' HCAROUT ',HCAROUT
+ RETURN
+ENDIF
+IF(YCARIN(INDTIT:INDTIT+8)=='CFT1TIT10'.OR.&
+ YCARIN(INDTIT:INDTIT+8)=='CFT1TIT11' .OR. YCARIN(INDTIT:INDTIT+8)=='CFT1TIT12' .OR. &
+ YCARIN(INDTIT:INDTIT+8)=='CFT1TIT13' .OR. YCARIN(INDTIT:INDTIT+8)=='CFT1TIT14' .OR. &
+ YCARIN(INDTIT:INDTIT+8)=='CFT1TIT15' )THEN
+
+ HCARIN(INDTIT:INDTIT+8)=YCARIN(INDTIT:INDTIT+8)
+ HCAROUT=HCARIN
+ HCAROUT=ADJUSTL(HCAROUT)
+!print *,' HCARIN ',HCARIN
+!print *,' HCAROUT ',HCAROUT
+ RETURN
+ENDIF
+!
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+INDTIT=INDEX(YCARIN,'CVARNPV')
+!
+IF(INDTIT /= 0)THEN
+!
+IF(YCARIN(INDTIT:INDTIT+7)=='CVARNPV1' .OR. YCARIN(INDTIT:INDTIT+7)=='CVARNPV2'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CVARNPV3' .OR. YCARIN(INDTIT:INDTIT+7)=='CVARNPV4'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CVARNPV5' .OR. YCARIN(INDTIT:INDTIT+7)=='CVARNPV6'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CVARNPV7' .OR. YCARIN(INDTIT:INDTIT+7)=='CVARNPV8'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CVARNPV9')THEN
+
+ HCARIN(INDTIT:INDTIT+7)=YCARIN(INDTIT:INDTIT+7)
+ HCAROUT=HCARIN
+ HCAROUT=ADJUSTL(HCAROUT)
+!print *,' HCARIN ',HCARIN
+!print *,' HCAROUT ',HCAROUT
+ RETURN
+ENDIF
+IF(YCARIN(INDTIT:INDTIT+8)=='CVARNPV10'.OR.&
+ YCARIN(INDTIT:INDTIT+8)=='CVARNPV11' .OR. YCARIN(INDTIT:INDTIT+8)=='CVARNPV12' .OR. &
+ YCARIN(INDTIT:INDTIT+8)=='CVARNPV13' .OR. YCARIN(INDTIT:INDTIT+8)=='CVARNPV14' .OR. &
+ YCARIN(INDTIT:INDTIT+8)=='CVARNPV15' )THEN
+
+ HCARIN(INDTIT:INDTIT+8)=YCARIN(INDTIT:INDTIT+8)
+ HCAROUT=HCARIN
+ HCAROUT=ADJUSTL(HCAROUT)
+!print *,' HCARIN ',HCARIN
+!print *,' HCAROUT ',HCAROUT
+ RETURN
+ENDIF
+!
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+INDTIT=INDEX(YCARIN,'CVARNPH')
+!
+IF(INDTIT /= 0)THEN
+!
+IF(YCARIN(INDTIT:INDTIT+7)=='CVARNPH1' .OR. YCARIN(INDTIT:INDTIT+7)=='CVARNPH2'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CVARNPH3' .OR. YCARIN(INDTIT:INDTIT+7)=='CVARNPH4'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CVARNPH5' .OR. YCARIN(INDTIT:INDTIT+7)=='CVARNPH6'.OR.&
+ YCARIN(INDTIT:INDTIT+7)=='CVARNPH7' .OR. YCARIN(INDTIT:INDTIT+7)=='CVARNPH8')THEN
+
+ HCARIN(INDTIT:INDTIT+7)=YCARIN(INDTIT:INDTIT+7)
+ HCAROUT=HCARIN
+ HCAROUT=ADJUSTL(HCAROUT)
+ RETURN
+ENDIF
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+INDPVMIN=INDEX(YCARIN,'XPVMIN_')
+IF(INDPVMIN /= 0)THEN
+! HCARIN(INDPVMIN:INDPVMIN+6)=YCARIN(INDPVMIN:INDPVMIN+6)
+ DO J=INDPVMIN+6,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDPVMIN+6:J)=HCARIN(INDPVMIN+6:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+INDFTMIN=INDEX(YCARIN,'XFTMIN_')
+IF(INDFTMIN /= 0)THEN
+! HCARIN(INDFTMIN:INDFTMIN+6)=YCARIN(INDFTMIN:INDFTMIN+6)
+ DO J=INDFTMIN+6,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDFTMIN+6:J)=HCARIN(INDFTMIN+6:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+INDFT1MIN=INDEX(YCARIN,'XFT1MIN_')
+IF(INDFT1MIN /= 0)THEN
+! HCARIN(INDFT1MIN:INDFT1MIN+7)=YCARIN(INDFT1MIN:INDFT1MIN+7)
+ DO J=INDFT1MIN+7,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDFT1MIN+7:J)=HCARIN(INDFT1MIN+7:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+INDPVKTMIN=INDEX(YCARIN,'XPVKTMIN_')
+IF(INDPVKTMIN /= 0)THEN
+! HCARIN(INDPVKTMIN:INDPVKTMIN+8)=YCARIN(INDPVKTMIN:INDPVKTMIN+8)
+ DO J=INDPVKTMIN+8,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDPVKTMIN+8:J)=HCARIN(INDPVKTMIN+8:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+INDPVMAX=INDEX(YCARIN,'XPVMAX_')
+IF(INDPVMAX /= 0)THEN
+! HCARIN(INDPVMAX:INDPVMAX+6)=YCARIN(INDPVMAX:INDPVMAX+6)
+ DO J=INDPVMAX+6,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDPVMAX+6:J)=HCARIN(INDPVMAX+6:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+INDFTMAX=INDEX(YCARIN,'XFTMAX_')
+IF(INDFTMAX /= 0)THEN
+! HCARIN(INDFTMAX:INDFTMAX+6)=YCARIN(INDFTMAX:INDFTMAX+6)
+ DO J=INDFTMAX+6,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDFTMAX+6:J)=HCARIN(INDFTMAX+6:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+INDFT1MAX=INDEX(YCARIN,'XFT1MAX_')
+IF(INDFT1MAX /= 0)THEN
+! HCARIN(INDFT1MAX:INDFT1MAX+7)=YCARIN(INDFT1MAX:INDFT1MAX+7)
+ DO J=INDFT1MAX+7,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDFT1MAX+7:J)=HCARIN(INDFT1MAX+7:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+INDPVKTMAX=INDEX(YCARIN,'XPVKTMAX_')
+IF(INDPVKTMAX /= 0)THEN
+! HCARIN(INDPVKTMAX:INDPVKTMAX+8)=YCARIN(INDPVKTMAX:INDPVKTMAX+8)
+ DO J=INDPVKTMAX+8,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDPVKTMAX+8:J)=HCARIN(INDPVKTMAX+8:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+INDISOMIN=INDEX(YCARIN,'XISOMIN_')
+IF(INDISOMIN /= 0)THEN
+! HCARIN(INDISOMIN:INDISOMIN+7)=YCARIN(INDISOMIN:INDISOMIN+7)
+ DO J=INDISOMIN+7,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDISOMIN+7:J)=HCARIN(INDISOMIN+7:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+INDISOMAX=INDEX(YCARIN,'XISOMAX_')
+IF(INDISOMAX /= 0)THEN
+! HCARIN(INDISOMAX:INDISOMAX+7)=YCARIN(INDISOMAX:INDISOMAX+7)
+ DO J=INDISOMAX+7,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDISOMAX+7:J)=HCARIN(INDISOMAX+7:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+INDDIAINT=INDEX(YCARIN,'XDIAINT_')
+IF(INDDIAINT /= 0)THEN
+! HCARIN(INDDIAINT:INDDIAINT+7)=YCARIN(INDDIAINT:INDDIAINT+7)
+ DO J=INDDIAINT+7,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDDIAINT+7:J)=HCARIN(INDDIAINT+7:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+INDISOREF=INDEX(YCARIN,'XISOREF_')
+IF(INDISOREF /= 0)THEN
+ DO J=INDISOREF+7,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDISOREF+7:J)=HCARIN(INDISOREF+7:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+INDISOLEV=INDEX(YCARIN,'XISOLEV_')
+IF(INDISOLEV /= 0)THEN
+ DO J=INDISOLEV+7,ILENC
+ IF(HCARIN(J:J) == ' ' .OR. HCARIN(J:J) == '=')THEN
+ YCARIN(INDISOLEV+7:J)=HCARIN(INDISOLEV+7:J)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(INDPVMIN + INDPVMAX + INDFTMIN + INDFTMAX + INDPVKTMIN + &
+ INDPVKTMAX + INDISOMIN + INDISOMAX + INDDIAINT + INDISOREF + &
+ INDFT1MIN + INDFT1MAX + INDISOLEV /= 0)THEN
+! HCAROUT=ADJUSTL(YCARIN)
+ HCAROUT=YCARIN
+ HCAROUT=ADJUSTL(HCAROUT)
+ RETURN
+ENDIF
+
+YCARIN = HCARIN
+
+!print *,' YCARIN ILENC ',ILENC,YCARIN
+
+NBGUIL=0
+
+DO J = 1,ILENC
+ IF(YCARIN(J:J) == '"')THEN
+ NBGUIL=NBGUIL+1
+ NMGUIL(NBGUIL)=J
+ ENDIF
+ IF(YCARIN(J:J) == "'")THEN
+ NBGUIL=NBGUIL+1
+ NMGUIL(NBGUIL)=J
+ ENDIF
+ENDDO
+IF(MOD(NBGUIL,2) /= 0)THEN
+ print *,' NB DE GUILLEMETS ET(/OU) DE QUOTES IMPAIR. VERIFIEZ LA SYNTAXE DE VOS', &
+ ' INSTRUCTIONS D ENTREE'
+ LPBREAD=.TRUE.
+ RETURN
+! STOP
+ENDIF
+NMGUIL(NBGUIL+1)=ILENC+1
+!
+DO J=1,NBGUIL+1,2
+ IF(J == 1)THEN
+ IBEG=1
+ IEND=NMGUIL(J)-1
+ ELSE IF(J == NBGUIL+1)THEN
+ IBEG=MIN(NMGUIL(J-1)+1,ILENC)
+ IEND=ILENC
+ ELSE
+ IBEG=NMGUIL(J-1)+1
+ IEND=NMGUIL(J)-1
+ END IF
+! print *,' ibeg iend ilenc ycarin ',ibeg,iend,ilenc
+! print *,ycarin(ibeg:iend)
+DO JJ=IBEG,IEND
+ DO JA=1,26
+ IF(YCARIN(JJ:JJ) == YLO(JA))YCARIN(JJ:JJ)=YUP(JA)
+ ENDDO
+ENDDO
+ENDDO
+!HCAROUT=ADJUSTL(YCARIN)
+HCAROUT=YCARIN
+HCAROUT=ADJUSTL(HCAROUT)
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+!print *,' ** sortie convlo2up'
+RETURN
+END SUBROUTINE CONVLO2UP
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/convxy2ij.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/convxy2ij.f90
new file mode 100644
index 0000000000000000000000000000000000000000..03b2308faabde82bdc636f8247822337c3c8d127
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/convxy2ij.f90
@@ -0,0 +1,237 @@
+! ############################
+ SUBROUTINE CONVXY2IJ(HCARIN)
+! ############################
+!
+!!**** *CONVXY2IJ* - Convertit des coordonnees conformes et coordonnees
+!! geographiques en indices de grille I,J
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_CONVIJ2XY
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX : XXHAT coordinate values for all the MESO-NH grids
+!! XXY : XYHAT "
+!!
+!! Module MODE_GRIDPROJ
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 01/04/99
+!! Updated
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODE_GRIDPROJ
+USE MODD_COORD
+USE MODD_FILES_DIACHRO
+USE MODD_CONF
+USE MODD_GRID
+USE MODD_DIM1
+USE MODD_GRID1
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_RESOLVCAR
+! Utilisation du meme module pour les operations inverses
+USE MODD_CONVIJ2XY
+USE MODD_PARAMETERS
+USE MODI_RESOLVXISOLEV
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+!
+CHARACTER(LEN=800) :: HCARIN
+!
+!* 0.2 Local variables
+!
+INTEGER :: IMGRID, J, I, JM
+INTEGER :: II, IJ, IIM, IJM
+INTEGER :: IIU, IJU, ICONVXY2IJ
+REAL :: ZLAT,ZLON,ZX,ZY
+!REAL,DIMENSION(:),ALLOCATABLE :: ZCONVLAT, ZCONVLON
+!
+REAL,DIMENSION(100) :: ZIJ
+CHARACTER(LEN=8) :: YMGRID
+!
+!-------------------------------------------------------------------------------
+!
+!* 1.
+! ----------------------------
+!
+IIU=NIMAX+2*JPHEXT
+IJU=NJMAX+2*JPHEXT
+CALL INI_CST
+!
+!
+!* 1.1
+!
+HCARIN=ADJUSTL(HCARIN)
+if(nverbia >0)then
+ print *,' **CONVXY2IJ HCARIN ',HCARIN
+endif
+IF(NBFILES == 0)THEN
+ print *,' Vous devez ouvrir le fichier pour lequel vous demandez l''information avec _file1_...'
+ print *,' puis entrer a nouveau votre directive '
+ LPBREAD=.TRUE.
+ RETURN
+ENDIF
+IF (LCARTESIAN) THEN
+ print *,' In the cartesian geometry, reference latitude and longitude are the same for the whole domain:'
+ print *,XLAT0,XLON0
+ LPBREAD=.TRUE.
+ RETURN
+ENDIF
+
+ICONVXY2IJ=INDEX(HCARIN,'CONVXY2IJ')
+ZIJ(:)=9999.
+CALL RESOLVXISOLEV(HCARIN(1:LEN_TRIM(HCARIN)),ICONVXY2IJ,ZIJ)
+DO J=SIZE(ZIJ,1),1,-1
+ IF(ZIJ(J) /= 9999.)THEN
+ JM=J
+ EXIT
+ ENDIF
+ENDDO
+if(nverbia >0)then
+ print *,' convxy2ij: ZIJ ',ZIJ(1:JM)
+endif
+ALLOCATE(XCONVI(JM/2))
+ALLOCATE(XCONVJ(JM/2))
+ALLOCATE(XCONVX(JM/2))
+ALLOCATE(XCONVY(JM/2))
+ALLOCATE(XCONVLAT(JM/2))
+ALLOCATE(XCONVLON(JM/2))
+!ALLOCATE(ZCONVLAT(JM/2*7))
+!ALLOCATE(ZCONVLON(JM/2*7))
+J=JM/2
+XCONVLAT(1:J)=ZIJ(1:JM-1:2)
+XCONVLON(1:J)=ZIJ(2:JM:2)
+IF(NVERBIA > 0)THEN
+ print *,' convxy2ij: XCONVLAT, XCONVLON'
+ print *,XCONVLAT
+ print *,XCONVLON
+ENDIF
+DO IMGRID=1,7
+DO I=1,J
+ZLAT=XCONVLAT(I)
+ZLON=XCONVLON(I)
+
+!
+CALL SM_XYHAT_S(XLATORI,XLONORI,ZLAT,ZLON,ZX,ZY)
+
+XCONVX(I)=ZX
+XCONVY(I)=ZY
+
+DO II=2,SIZE(XXX,1)
+ IF(ZX >= XXX(II-1,IMGRID) .AND. ZX < XXX(II,IMGRID))THEN
+ IIM=II-1
+ EXIT
+ ELSE
+ IF(II == SIZE(XXX,1))THEN
+ IIM=II
+ EXIT
+ ENDIF
+ ENDIF
+ENDDO
+IF(IIM == SIZE(XXX,1))THEN
+ XCONVI(I)=IIM
+ELSE
+ XCONVI(I)=IIM+((ZX-XXX(IIM,IMGRID))/(XXX(IIM+1,IMGRID)-XXX(IIM,IMGRID)))
+ENDIF
+
+DO IJ=2,SIZE(XXY,1)
+ IF(ZY >= XXY(IJ-1,IMGRID) .AND. ZY < XXY(IJ,IMGRID))THEN
+ IJM=IJ-1
+ EXIT
+ ELSE
+ IF(IJ == SIZE(XXY,1))THEN
+ IJM=IJ
+ EXIT
+ ENDIF
+ ENDIF
+ENDDO
+IF(IJM == SIZE(XXY,1))THEN
+ XCONVJ(I)=IJM
+ELSE
+ XCONVJ(I)=IJM+((ZY-XXY(IJM,IMGRID))/(XXY(IJM+1,IMGRID)-XXY(IJM,IMGRID)))
+ENDIF
+!
+!IF(I == 1)THEN
+! ZCONVLAT(IMGRID*2-1)=ZLAT
+! ZCONVLON(IMGRID*2-1)=ZLON
+!ELSE
+! ZCONVLAT(IMGRID*2)=ZLAT
+! ZCONVLON(IMGRID*2)=ZLON
+!ENDIF
+IF(IMGRID == 1 .AND. I == 1)THEN
+
+print *,' GRILLES * LAT * LON * X * Y * I * J '
+print *,'******************************************************************************'
+endif
+IF(IMGRID == 1)THEN
+YMGRID=' 1 et 4 '
+ELSE IF(IMGRID == 2)THEN
+YMGRID=' 2 et 6 '
+ELSE IF(IMGRID == 3)THEN
+YMGRID=' 3 et 7 '
+ELSE IF(IMGRID == 5)THEN
+YMGRID=' 5 '
+ENDIF
+IF(IMGRID == 1 .OR. IMGRID == 2 .OR. IMGRID == 3 .OR. IMGRID == 5)THEN
+print 10,YMGRID,XCONVLAT(I),XCONVLON(I),XCONVX(I),XCONVY(I),XCONVI(I),XCONVJ(I)
+print *,'------------------------------------------------------------------------------'
+ENDIF
+ENDDO
+ENDDO
+!if (nverbia > 0)then
+!DO I=1,J*7
+! ZLAT=ZCONVLAT(I)
+! ZLON=ZCONVLON(I)
+! CALL SM_XYHAT_S(XLATORI,XLONORI,ZLAT,ZLON,ZX,ZY)
+! print *,' ZLAT=',ZLAT,' ZLON=',ZLON,' ZX=',ZX,' ZY=',ZY
+!ENDDO
+!endif
+10 FORMAT(1X,A8,' * ',F10.6,' * ',F11.6,'* ',F10.0,' * ',F10.0,' *',F6.2,' *',F6.2)
+DEALLOCATE(XCONVI)
+DEALLOCATE(XCONVJ)
+DEALLOCATE(XCONVX)
+DEALLOCATE(XCONVY)
+DEALLOCATE(XCONVLAT)
+DEALLOCATE(XCONVLON)
+!DEALLOCATE(ZCONVLAT)
+!DEALLOCATE(ZCONVLON)
+
+!
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+!
+RETURN
+END SUBROUTINE CONVXY2IJ
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/coupe_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/coupe_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0274d9614b5f593710498ea84c94b3e8946554b5
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/coupe_fordiachro.f90
@@ -0,0 +1,293 @@
+! ######spl
+ SUBROUTINE COUPE_FORDIACHRO(PTABI,PTABO,K)
+! ##########################################
+!
+!!**** *COUPE_FORDIACHRO* - Vertical cross-section interpolation
+!!
+!! PURPOSE
+!! -------
+! Interpolates 2D vertical cross-sections within the Meso-NH 3D
+! arrays. Model fields, iapprpriate gridpoint altitudes as well as
+! appropriate topography height are interpolated.
+!
+!!** METHOD
+!! ------
+!! The general case of a vertical cross-section along any oblique
+!! direction with respect to the x-y model axes is considered. Simple
+!! linear interpolation is done.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX,XXY,XXZ : coordinate values for all the MESO-NH grids
+!! XXZS : topography values for all the MESO_NH grids
+!! XDSX, XDSY : projections on the MESO-NH cartesian axes of the XDS
+!! oblique abscissa (meters), for all grid locations
+!!
+!! Module MODD_GRID1 : declares grid variables (Model module)
+!! XZZ : true z altitude for the current NMGRID grid location
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist (form. NCAR common)
+!! XSPVAL : Special value
+!!
+!! Module MODD_CVERT : Declares work arrays for vertical cross-sections
+!! XWORKZ : working array for true altitude storage (all grids)
+!! XWZ : working array for topography (all grids)
+!!
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist (form. PARA common)
+!! NLMAX : Number of points horizontally along
+!! the vertical section
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NKMAX : z array dimension
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!!
+!! Module MODD_NMGRID : declares global variable NMGRID
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 06/01/59
+!-------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_COORD
+USE MODD_GRID1
+USE MODN_NCAR
+USE MODD_CVERT
+USE MODD_MEMCV
+USE MODN_PARA
+USE MODD_PARAMETERS
+USE MODD_NMGRID
+USE MODD_RESOLVCAR
+USE MODD_TYPE_AND_LH
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments and results
+!
+REAL,DIMENSION(:,:) :: PTABI ! Input data array to be interpolated
+REAL,DIMENSION(:) :: PTABO ! Returned interpolated 2D array
+INTEGER :: K ! Model level where interpolation is done
+!
+!* 0.2 Local variables
+!
+REAL :: ZCIINF,ZCISUP,ZCJINF,ZCJSUP,ZXX,ZYY
+INTEGER :: IMIM1,IMI,IMJM1,IMJ,JILOOP, JI, JJ
+INTEGER :: IIU, IJU, IKU, IKB, IKE
+!
+!------------------------------------------------------------------------------
+!
+!* 1. PERFORMING VERTICAL INTERPOLATIONS
+! ----------------------------------
+!
+!* 1.0 Presetting array extends
+!
+!print *,' ++++coupe NMGRID DIRCUR ',NMGRID,CDIRCUR(1:LEN_TRIM(CDIRCUR))
+IIU=NIMAX+2*JPHEXT
+IJU=NJMAX+2*JPHEXT
+IKU=NKMAX+2*JPVEXT
+IKE=IKU-JPVEXT
+IKB=1+JPVEXT
+! Oct 2000 prise en compte du 2D horizontal -> PH=CH+CV
+! Ajout LKCP Avril 2001 -> prise en compte du 3D compresse en K
+IF(LCHXY .OR. LKCP)THEN
+ IKU=1; IKB=1; IKE=1
+ if(nverbia > 0)then
+ print *,' **coupe NKL NKH LCHXY ',NKL,NKH,LCHXY
+ endif
+ENDIF
+!
+!* 1.1 Scans along-section oblique x axis
+!
+DO JILOOP=1,NLMAX ! Start of general X- scanning loop
+!
+!* 1.2 Locates the current gridpoint along the cross-section
+!* oblique x-axis within the Meso-NH grid
+!
+ ZXX=XDSX(JILOOP,NMGRID) ! Collects the model X- and Y- axes projections
+ ZYY=XDSY(JILOOP,NMGRID) ! onto the oblique vertical section plane
+ ! for the current (new) section point
+!
+!* 1.3 The current section point is located along
+!* the x- axis
+!
+ DO JI=2,IIU
+ IF(ZXX.LE.XXX(JI,NMGRID).AND.ZXX.GE.XXX(JI-1,NMGRID))GO TO 1
+ ENDDO
+
+1 CONTINUE
+
+ IMIM1=MAX(1,JI-1)
+ IMI=JI ! JI is the index of the first model bin to the left
+!
+!* 1.4 Then, it is located along
+!* the Y- axis
+!
+ DO JJ=2,IJU
+ IF(ZYY.LE.XXY(JJ,NMGRID).AND.ZYY.GE.XXY(JJ-1,NMGRID))GO TO 2
+ ENDDO
+
+2 CONTINUE
+
+ IMJM1=MAX(1,JJ-1)
+ IMJ=JJ ! JJ is the index of the first model bin below
+!
+!* 1.5 Finally the X- and Y- distances between the current section
+!* point and closest model box to the left-bottom are calculated
+!
+ IF(IMI==IMIM1)THEN ! Left wall special case
+ ZCIINF=0.
+ ZCISUP=0.
+ ELSE
+ !print *,'XX(IMI IMIM1) ZXX',XX(IMI),XX(IMIM1),ZXX
+ ZCIINF=(XXX(IMI,NMGRID)-ZXX)/MAX(1.E-10,(XXX(IMI,NMGRID)-XXX(IMIM1,NMGRID)))
+ ZCISUP=(ZXX-XXX(IMIM1,NMGRID))/MAX(1.E-10,(XXX(IMI,NMGRID)-XXX(IMIM1,NMGRID)))
+ END IF
+ !
+ IF(IMJ==IMJM1)THEN ! Bottom wall special case
+ ZCJINF=0.
+ ZCJSUP=0.
+ ELSE
+ !PRINT *,'XY(IMJ IMJM1) ZXY',XY(IMJ),XY(IMJM1),ZYY
+ ZCJINF=(XXY(IMJ,NMGRID)-ZYY)/MAX(1.E-10,(XXY(IMJ,NMGRID)-XXY(IMJM1,NMGRID)))
+ ZCJSUP=(ZYY-XXY(IMJM1,NMGRID))/MAX(1.E-10,(XXY(IMJ,NMGRID)-XXY(IMJM1,NMGRID)))
+ END IF
+!
+!* 1.6 Computes the interpolated altitude of the
+!* current section point
+!
+if(nverbia > 1)then
+print *,' ** coupe AV XWORKZ K= ',K,' size XWORKZ ',size(XWORKZ,1),size(XWORKZ,2),size(XWORKZ,3), &
+' IMIM1,IMJM1,IMJ,IMI ',IMIM1,IMJM1,IMJ,IMI
+print *,' ** coupe AV XWORKZ ZCIINF,ZCJINF,ZCISUP,ZCJSUP,NMGRID ',ZCIINF,ZCJINF,ZCISUP,ZCJSUP,NMGRID
+print *,' ** coupe AV XWORKZ JILOOP XZZ(IMIM1,IMJM1,K),XZZ(IMIM1,IMJ,K),XZZ(IMI,IMJM1,K),XZZ(IMI,IMJ,K) ',&
+JILOOP,XZZ(IMIM1,IMJM1,K),XZZ(IMIM1,IMJ,K),XZZ(IMI,IMJM1,K),XZZ(IMI,IMJ,K)
+endif
+
+ XWORKZ(JILOOP,K,NMGRID)=ZCIINF*ZCJINF*XZZ(IMIM1,IMJM1,K)+ &
+ ZCIINF*ZCJSUP*XZZ(IMIM1,IMJ,K)+ &
+ ZCISUP*ZCJINF*XZZ(IMI,IMJM1,K)+ &
+ ZCISUP*ZCJSUP*XZZ(IMI,IMJ,K)
+
+if(nverbia > 1)then
+print *,' ** coupe AP XWORKZ K= ',K,' size XZZ ',size(XZZ,1),size(XZZ,2),size(XZZ,3),' IMIM1,IMJM1,IMJ,IMI ',IMIM1,IMJM1,IMJ,IMI
+endif
+!
+!* 1.7 Computes the interpolated value of the field for
+!* current section point
+!
+! Modifs for diachro
+! Avril 2001 Ajout LKCP -> prise en compte 3D compresse sur K
+ IF((K.LT.MAX(NKL,IKB).OR.K.GT.MIN(NKH,IKE)) .AND. .NOT.LKCP)THEN
+ PTABO(JILOOP)=XSPVAL
+ ELSE
+! Ajout pour les PH definis avec _CV__K_ ou _Z_ etc... le 10/3/99
+! IF(LCV .AND. LCH)THEN
+! idem (02/04/04) pour les _CV_ classiques (cas obs2mesonh)
+! Ds ce cas on ne travaille pas necessairemnet sur les niveaux du modele
+! mais sur un plan Z ou PR ou TK ou EV qui peut contenir des valeurs speciales
+! XSPVAL. Il faut donc en tenir compte en limite de relief
+! A PEAUFINER
+! Le calcul des altitudes et du relief est fait mais je ne m'en sers pas
+! Il peut etre aberrant . PENSER a les eliminer avec LPRINT et LPRINTXY
+ IF((PTABI(IMIM1,IMJM1)==XSPVAL .AND. PTABI(IMIM1,IMJ)==XSPVAL).OR.&
+ (PTABI(IMIM1,IMJM1)==XSPVAL .AND. PTABI(IMI,IMJM1)==XSPVAL).OR.&
+ (PTABI(IMIM1,IMJM1)==XSPVAL .AND. PTABI(IMI,IMJ)==XSPVAL).OR. &
+ (PTABI(IMI,IMJM1)==XSPVAL .AND. PTABI(IMI,IMJ)==XSPVAL).OR. &
+ (PTABI(IMIM1,IMJ)==XSPVAL .AND. PTABI(IMI,IMJ)==XSPVAL).OR. &
+ (PTABI(IMIM1,IMJ)==XSPVAL .AND. PTABI(IMI,IMJM1)==XSPVAL))THEN
+ PTABO(JILOOP)=XSPVAL
+ ELSE IF(PTABI(IMIM1,IMJM1)==XSPVAL .AND. PTABI(IMIM1,IMJ)/=XSPVAL.AND.&
+ PTABI(IMI,IMJM1)/=XSPVAL .AND. PTABI(IMI,IMJ)/=XSPVAL)THEN
+ PTABO(JILOOP)= &
+ ZCIINF*ZCJSUP*PTABI(IMIM1,IMJ)+ &
+ ZCISUP*ZCJINF*PTABI(IMI,IMJM1)+ &
+ ZCISUP*ZCJSUP*PTABI(IMI,IMJ)
+ ELSE IF(PTABI(IMIM1,IMJM1)/=XSPVAL .AND. PTABI(IMIM1,IMJ)==XSPVAL.AND.&
+ PTABI(IMI,IMJM1)/=XSPVAL .AND. PTABI(IMI,IMJ)/=XSPVAL)THEN
+ PTABO(JILOOP)=ZCIINF*ZCJINF*PTABI(IMIM1,IMJM1)+ &
+ ZCISUP*ZCJINF*PTABI(IMI,IMJM1)+ &
+ ZCISUP*ZCJSUP*PTABI(IMI,IMJ)
+ ELSE IF(PTABI(IMIM1,IMJM1)/=XSPVAL .AND. PTABI(IMIM1,IMJ)/=XSPVAL.AND.&
+ PTABI(IMI,IMJM1)==XSPVAL .AND. PTABI(IMI,IMJ)/=XSPVAL)THEN
+ PTABO(JILOOP)=ZCIINF*ZCJINF*PTABI(IMIM1,IMJM1)+ &
+ ZCIINF*ZCJSUP*PTABI(IMIM1,IMJ)+ &
+ ZCISUP*ZCJSUP*PTABI(IMI,IMJ)
+ ELSE IF(PTABI(IMIM1,IMJM1)/=XSPVAL .AND. PTABI(IMIM1,IMJ)/=XSPVAL.AND.&
+ PTABI(IMI,IMJM1)/=XSPVAL .AND. PTABI(IMI,IMJ)==XSPVAL)THEN
+ PTABO(JILOOP)=ZCIINF*ZCJINF*PTABI(IMIM1,IMJM1)+ &
+ ZCIINF*ZCJSUP*PTABI(IMIM1,IMJ)+ &
+ ZCISUP*ZCJINF*PTABI(IMI,IMJM1)
+ ELSE
+ PTABO(JILOOP)=ZCIINF*ZCJINF*PTABI(IMIM1,IMJM1)+ &
+ ZCIINF*ZCJSUP*PTABI(IMIM1,IMJ)+ &
+ ZCISUP*ZCJINF*PTABI(IMI,IMJM1)+ &
+ ZCISUP*ZCJSUP*PTABI(IMI,IMJ)
+ ENDIF
+
+! ELSE
+! Cas habituel
+! PTABO(JILOOP)=ZCIINF*ZCJINF*PTABI(IMIM1,IMJM1)+ &
+! ZCIINF*ZCJSUP*PTABI(IMIM1,IMJ)+ &
+! ZCISUP*ZCJINF*PTABI(IMI,IMJM1)+ &
+! ZCISUP*ZCJSUP*PTABI(IMI,IMJ)
+! ENDIF
+ END IF
+!
+!* 1.8 Computes the interpolated topography height for
+!* current section point
+!
+if(nverbia > 1)then
+ print *,' ** coupe AV XWZ '
+endif
+
+XWZ(JILOOP,NMGRID)=ZCIINF*ZCJINF*XXZS(IMIM1,IMJM1,NMGRID)+ &
+ ZCIINF*ZCJSUP*XXZS(IMIM1,IMJ,NMGRID)+ &
+ ZCISUP*ZCJINF*XXZS(IMI,IMJM1,NMGRID)+ &
+ ZCISUP*ZCJSUP*XXZS(IMI,IMJ,NMGRID)
+!
+ENDDO ! End of the general X- scanning loop
+
+if(nverbia > 0)then
+print *,' >>>> SORTIE COUPE NMGRID= ',NMGRID,' size(XWZ)' ,size(XWZ,1)
+endif
+if(nverbia > 1)then
+print *,' XWZ ',XWZ(:,NMGRID)
+endif
+!
+RETURN
+!------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+END SUBROUTINE COUPE_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/coupeuw_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/coupeuw_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d0e02f71a08531ebec003bbb984f76e791af5896
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/coupeuw_fordiachro.f90
@@ -0,0 +1,252 @@
+! #################################################
+ SUBROUTINE COUPEUW_FORDIACHRO(PTABI,PTABO,K,KCOMP)
+! ##################################################
+!
+!!**** *COUPEUW_FORDIACHRO* - Vertical cross-section interpolation for U and W
+!! wind components
+!!
+!! PURPOSE
+!! -------
+! Interpolates 2D vertical cross-sections within the Meso-NH 3D
+! arrays. U and W model fields, appropriate gridpoint altitudes
+! as well as appropriate topography height are interpolated.
+!
+!!** METHOD
+!! ------
+!! The general case of a vertical cross-section along any oblique
+!! direction with respect to the x-y model axes is considered. Simple
+!! linear interpolation is done.
+!! (First, wind components were co-located onto mass gridpoint)
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX,XXY,XXZ : coordinate values for all the MESO-NH grids
+!! XXZS : topography values for all the MESO_NH grids
+!! XDSX, XDSY : projections on the MESO-NH cartesian axes of the XDS
+!! oblique abscissa (meters), for all grid locations
+!!
+!! Module MODD_GRID1 : declares grid variables (Model module)
+!! XZZ : true z altitude for the current NMGRID grid location
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist (form. NCAR common)
+!! XSPVAL : Special value
+!!
+!! Module MODD_CVERT : Declares work arrays for vertical cross-sections
+!! XWORKZ : working array for true altitude storage (all grids)
+!! XWZ : working array for topography (all grids)
+!!
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist (form. PARA common)
+!! NLMAX : Number of points horizontally along
+!! the vertical section
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NKMAX : z array dimension
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!!
+!! Module MODD_NMGRID : declares global variable NMGRID
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 19/09/95
+!! Updated PM
+!-------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_COORD
+USE MODD_MEMCV
+USE MODD_GRID1
+USE MODN_NCAR
+USE MODD_CVERT
+USE MODN_PARA
+USE MODD_PARAMETERS
+USE MODD_NMGRID
+USE MODD_TYPE_AND_LH
+USE MODD_RESOLVCAR
+USE MODD_MEMGRIUV
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments and results
+!
+REAL,DIMENSION(:,:) :: PTABI ! Input data array to be interpolated
+REAL,DIMENSION(:) :: PTABO ! Returned interpolated 1D array
+INTEGER :: K ! Model level where interpolation is done
+INTEGER :: KCOMP ! Code = 1 --> U wind component
+ ! = 2 --> V "
+ ! = 3 --> W "
+!
+!* 0.2 Local variables
+!
+REAL :: ZCIINF,ZCISUP,ZCJINF,ZCJSUP,ZXX,ZYY
+INTEGER :: IMIM1,IMI,IMJM1,IMJ,JILOOP, JI, JJ
+INTEGER :: IIU, IJU, IKU, IKB, IKE
+INTEGER :: IGRID
+!
+!------------------------------------------------------------------------------
+!
+!* 1. PERFORMING VERTICAL INTERPOLATIONS
+! ----------------------------------
+!
+!* 1.0 Presetting array extends
+!
+IIU=NIMAX+2*JPHEXT
+IJU=NJMAX+2*JPHEXT
+IKU=NKMAX+2*JPVEXT
+IKE=IKU-JPVEXT
+IKB=1+JPVEXT
+!
+!* 1.1 Scans along-section oblique x axis
+!
+! NOTA :
+! L'utilisation explicite et volontaire de la valeur 1 comme dernier indice
+! des tableaux presents dans la routine signifie que la representation se fait
+! en definitive par rapport a la grille de masse en replacant les com-
+! -posantes du vent dans celle-ci
+!
+SELECT CASE(KCOMP)
+ CASE(1)
+ IGRID=2
+ IF(NGRIU == 1)THEN
+ IF(nverbia >0)then
+ print *,' **coupeuw NGRIU,CGROUP ',NGRIU,CGROUP
+ endif
+ IGRID=1
+ ENDIF
+ CASE(2)
+ IGRID=3
+ IF(NGRIV == 1)THEN
+ IF(nverbia >0)then
+ print *,' **coupeuw NGRIV,CGROUP ',NGRIV,CGROUP
+ endif
+ IGRID=1
+ ENDIF
+ CASE(3)
+ IGRID=1 ! W components put at mass gridpoints
+END SELECT
+
+if(nverbia > 0)then
+print *,' **COUPEUW NMGRID DIRCUR ',NMGRID,' ',CDIRCUR(1:LEN_TRIM(CDIRCUR))
+endif
+DO JILOOP=1,NLMAX ! Start of general X- scanning loop
+!
+!* 1.2 Locates the current gridpoint along the cross-section
+!* oblique x-axis within the Meso-NH grid
+!
+ ZXX=XDSX(JILOOP,1) ! Collects the model X- and Y- axes projections
+ ZYY=XDSY(JILOOP,1) ! onto the oblique vertical section plane
+ ! for the current (new) section point
+!
+!* 1.3 The current section point is located along
+!* the x- axis
+!
+ DO JI=2,IIU
+ IF(ZXX.LE.XXX(JI,IGRID).AND.ZXX.GE.XXX(JI-1,IGRID))GO TO 1
+ ENDDO
+
+1 CONTINUE
+
+ IMIM1=MAX(1,JI-1)
+ IMI=JI ! JI is the index of the first model bin to the left
+!
+!* 1.4 Then, it is located along
+!* the Y- axis
+!
+ DO JJ=2,IJU
+ IF(ZYY.LE.XXY(JJ,IGRID).AND.ZYY.GE.XXY(JJ-1,IGRID))GO TO 2
+ ENDDO
+
+2 CONTINUE
+
+ IMJM1=MAX(1,JJ-1)
+ IMJ=JJ ! JJ is the index of the first model bin below
+!
+!* 1.5 Finally the X- and Y- distances between the current section
+!* point and closest model box to the left-bottom are calculated
+!
+ IF(IMI==IMIM1)THEN ! Left wall special case
+ ZCIINF=0.
+ ZCISUP=0.
+ ELSE
+ !print *,'XX(IMI IMIM1) ZXX',XX(IMI),XX(IMIM1),ZXX
+ ZCIINF=(XXX(IMI,IGRID)-ZXX)/MAX(1.E-10,(XXX(IMI,IGRID)-XXX(IMIM1,IGRID)))
+ ZCISUP=(ZXX-XXX(IMIM1,IGRID))/MAX(1.E-10,(XXX(IMI,IGRID)-XXX(IMIM1,IGRID)))
+ END IF
+ !
+ IF(IMJ==IMJM1)THEN ! Bottom wall special case
+ ZCJINF=0.
+ ZCJSUP=0.
+ ELSE
+ !PRINT *,'XY(IMJ IMJM1) ZXY',XY(IMJ),XY(IMJM1),ZYY
+ ZCJINF=(XXY(IMJ,IGRID)-ZYY)/MAX(1.E-10,(XXY(IMJ,IGRID)-XXY(IMJM1,IGRID)))
+ ZCJSUP=(ZYY-XXY(IMJM1,IGRID))/MAX(1.E-10,(XXY(IMJ,IGRID)-XXY(IMJM1,IGRID)))
+ END IF
+!
+!* 1.6 Computes the interpolated altitude of the
+!* current section point
+!
+ XWORKZ(JILOOP,K,1)=ZCIINF*ZCJINF*XZZ(IMIM1,IMJM1,K)+ &
+ ZCIINF*ZCJSUP*XZZ(IMIM1,IMJ,K)+ &
+ ZCISUP*ZCJINF*XZZ(IMI,IMJM1,K)+ &
+ ZCISUP*ZCJSUP*XZZ(IMI,IMJ,K)
+!
+!* 1.7 Computes the interpolated value of the field for
+!* current section point
+!
+
+! Modifs for diachro
+ IF(K.LT.MAX(NKL,IKB).OR.K.GT.MIN(NKH,IKE))THEN
+! IF(K.LT.IKB.OR.K.GT.IKE)THEN
+ PTABO(JILOOP)=XSPVAL
+ ELSE
+ PTABO(JILOOP)=ZCIINF*ZCJINF*PTABI(IMIM1,IMJM1)+ &
+ ZCIINF*ZCJSUP*PTABI(IMIM1,IMJ)+ &
+ ZCISUP*ZCJINF*PTABI(IMI,IMJM1)+ &
+ ZCISUP*ZCJSUP*PTABI(IMI,IMJ)
+ END IF
+!
+!* 1.8 Computes the interpolated topography height for
+!* current section point
+!
+XWZ(JILOOP,1)=ZCIINF*ZCJINF*XXZS(IMIM1,IMJM1,NMGRID)+ &
+ ZCIINF*ZCJSUP*XXZS(IMIM1,IMJ,NMGRID)+ &
+ ZCISUP*ZCJINF*XXZS(IMI,IMJM1,NMGRID)+ &
+ ZCISUP*ZCJSUP*XXZS(IMI,IMJ,NMGRID)
+!
+ENDDO ! End of the general X- scanning loop
+!
+RETURN
+!------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+END SUBROUTINE COUPEUW_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/datfile_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/datfile_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..45511716e19a600da1195b0ab6f9a6dff6f848ed
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/datfile_fordiachro.f90
@@ -0,0 +1,241 @@
+! ######spl
+ SUBROUTINE DATFILE_FORDIACHRO
+! #############################
+!
+!!**** *DATFILE_FORDIACHRO* - Recupere la date du run du graphique et l'inscrit sur
+! le dessin ainsi que le nom du fichier traite
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 19/09/95
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_OUT
+USE MODD_FILES_DIACHRO
+USE MODD_RESOLVCAR
+USE MODD_TYPE_AND_LH
+USE MODD_ALLOC_FORDIACHRO
+!
+IMPLICIT NONE
+!
+!* 0.1 dummy argument
+!
+!
+!
+!
+!* 0.1 local variables
+!
+!
+CHARACTER(LEN=8) :: YTIM8, YTEM8
+CHARACTER(LEN=9) :: YTEM9
+#if defined(HPPA)
+CHARACTER(LEN=9) :: YDAT8
+#else
+#if defined(LINUX) || defined (O2000)
+CHARACTER(LEN=9) :: YDAT8
+CHARACTER(LEN=10) :: YTIM10
+#else
+#if defined(VPP)
+CHARACTER(LEN=8) :: YDAT8
+#endif
+#endif
+#endif
+INTEGER :: J, JM, ID
+INTEGER,DIMENSION(3) :: ITIM
+REAL :: ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+!-------------------------------------------------------------------------------
+#if defined(HPPA)
+CALL DATE(YDAT8)
+CALL TIME(YTIM8)
+#else
+#if defined(LINUX) || defined (O2000)
+CALL DATE_AND_TIME(YDAT8,YTIM10)
+#else
+#if defined(VPP)
+CALL ITIME(ITIM)
+YTIM8=' '
+WRITE(YTIM8,'(I2,I2,I2)')ITIM
+CALL DATE_AND_TIME(YDAT8,YTIM8)
+YTEM8=' '
+#endif
+#endif
+#endif
+
+!!!!!!!!!!! Date
+YTEM9=' '
+#if defined(HPPA)
+YTEM9(1:2)=YDAT8(1:2)
+#else
+#if defined(LINUX) || defined (O2000)
+YTEM9(1:2)=YDAT8(7:8)
+#else
+#if defined(VPP)
+YTEM8(1:2)=YDAT8(7:8)
+YTEM8(4:5)=YDAT8(4:5)
+#endif
+#endif
+#endif
+YTEM9(3:3)='/'
+#if defined(HPPA)
+YTEM9(4:6)=YDAT8(4:6)
+#else
+#if defined(LINUX) || defined (O2000)
+YTEM9(4:5)=YDAT8(5:6)
+#else
+#if defined(VPP)
+YTEM8(3:3)='/'
+YTEM8(6:6)='/'
+#endif
+#endif
+#endif
+
+#if defined(HPPA)
+YTEM9(7:7)='/'
+#else
+#if defined(LINUX) || defined (O2000)
+YTEM9(6:6)='/'
+#else
+#if defined(VPP)
+YTEM8(7:8)=YDAT8(1:2)
+#endif
+#endif
+#endif
+#if defined(HPPA)
+YTEM9(8:9)=YDAT8(8:9)
+#else
+#if defined(LINUX)
+YTEM9(7:8)=YDAT8(3:4)
+YTEM9(9:9)='/'
+#if defined (O2000)
+YTEM9(7:8)=YDAT8(1:2)
+YTEM9(9:9)='/'
+#endif
+#endif
+#endif
+#if defined(VPP)
+YDAT8=YTEM8
+#else
+#if defined(HPPA)
+YDAT8=YTEM9(1:9)
+#else
+YDAT8=YTEM9(1:8)
+#endif
+#endif
+
+!!!!!!!!!!! Time
+YTEM8=' '
+#if defined(HPPA)
+YTEM8(1:2)=YTIM8(1:2)
+#else
+#if defined(LINUX) || defined (O2000)
+YTEM8(1:2)=YTIM10(1:2)
+#else
+#if defined(VPP)
+YTEM8(4:5)=YTIM8(3:4)
+#endif
+#endif
+#endif
+YTEM8(3:3)='H'
+
+#if defined(HPPA)
+YTEM8(4:5)=YTIM8(4:5)
+#else
+#if defined(LINUX) || defined (O2000)
+YTEM8(4:5)=YTIM10(3:4)
+#else
+#if defined(VPP)
+YTEM8(7:8)=YTIM8(5:6)
+#endif
+#endif
+#endif
+YTEM8(6:6)='M'
+
+#if defined(HPPA)
+YTEM8(7:8)=YTIM8(7:8)
+#else
+#if defined(LINUX) || defined (O2000)
+YTEM8(7:8)=YTIM10(5:6)
+#endif
+#endif
+
+YTIM8=YTEM8
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+#if defined(HPPA)
+CALL PLCHHQ(0.80,0.99,YDAT8,.008,0.,-1.)
+#else
+#if defined(LINUX) || defined (O2000)
+CALL PLCHHQ(0.80,0.99,YDAT8(1:LEN_TRIM(YDAT8)),.008,0.,-1.)
+#else
+#if defined(VPP)
+CALL PLCHHQ(0.78,0.99,YDAT8,.008,0.,-1.)
+#endif
+#endif
+#endif
+#if defined(HPPA)
+CALL PLCHHQ(0.99,0.99,YTIM8,.008,0.,+1.)
+#else
+#if defined(LINUX) || defined (O2000)
+CALL PLCHHQ(0.99,0.99,YTIM8(1:LEN_TRIM(YTIM8)),.008,0.,+1.)
+#else
+#if defined(VPP)
+CALL PLCHHQ(0.90,0.99,YTIM8,.008,0.,-1.)
+#endif
+#endif
+#endif
+!
+! Modifs for diachro
+!
+DO J=1,NBFILES
+ IF(NUMFILES(J) == NUMFILECUR)THEN
+ JM=J
+ EXIT
+ ENDIF
+ENDDO
+#if defined(HPPA)
+CALL PLCHHQ(0.80,.97,CFILEDIAS(JM),.008,0.,-1.)
+#else
+#if defined(LINUX) || defined (O2000)
+CALL PLCHHQ(0.80,.97,CFILEDIAS(JM)(1:LEN_TRIM(CFILEDIAS(JM))),.008,0.,-1.)
+#else
+#if defined(VPP)
+CALL PLCHHQ(0.78,.97,CFILEDIAS(JM),.008,0.,-1.)
+#endif
+#endif
+#endif
+IF(ALLOCATED(XVAR))THEN
+IF(SIZE(XVAR,6) > 1 )THEN
+ CALL PLCHHQ(0.99,.95,CGROUP(1:LEN_TRIM(CGROUP)),.008,0.,+1.)
+ENDIF
+ENDIF
+IF(CTYPE == 'MASK')THEN
+ CALL PLCHHQ(0.99,.95,CGROUP(1:LEN_TRIM(CGROUP)),.008,0.,+1.)
+ENDIF
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+RETURN
+END SUBROUTINE DATFILE_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/defenetre.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/defenetre.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9841dde50624730beef50365a7b9a281bb1a4ace
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/defenetre.f90
@@ -0,0 +1,341 @@
+! ######spl
+ SUBROUTINE DEFENETRE
+! ####################
+!
+!!**** *DEFENETRE* - Defines the display window for a cartesian model
+!!
+!! PURPOSE
+!! -------
+! Defines the display window in the cartesian case for horizontal
+! cross-sections
+!
+!!** METHOD
+!! ------
+!! NCAR routines are called to select a display window
+!! corresponding to the post-processed section of the model
+!! arrays (NIINFxNISUP).(NJINFxNJSUP)
+!!
+!!
+!! EXTERNAL
+!! --------
+!! SET : defines NCAR window and viewport in normalized and user
+!! coordinates
+!! LABMOD : defines axis label format
+!! GRIDAL : draws axis divisions and ticks
+!! PERIM : draws a perimeter box for the current plot
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX,XXY : coordinate values for all the MESO-NH grids
+!!
+!! Module MODD_NMGRID : declares global variable NMGRID
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NIINF, NISUP : lower and upper bounds of arrays
+!! to be plotted in x direction
+!! NJINF, NJSUP : lower and upper bounds of arrays
+!! to be plotted in y direction
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 13/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_COORD
+USE MODD_NMGRID
+USE MODD_RESOLVCAR
+USE MODD_DIM1
+USE MODD_CTL_AXES_AND_STYL
+USE MODN_NCAR
+!
+IMPLICIT NONE
+!
+REAL :: ZWL, ZWR, ZWB, ZWT, ZDIFWLR, ZDIFWBT, ZDIFVLR, ZDIFVBT
+REAL :: ZXMIN, ZXMAX,ZYMIN, ZYMAX
+REAL :: ZVL, ZVR, ZVB, ZVT
+REAL :: ZDIFVPTLR, ZDIFVPTBT
+REAL :: ZI, ZJ, ZX, ZY, ZSZ, ZPOS, ZCENT
+INTEGER :: IPOS, ICONVI, ICONVJ, JCAR, ICOLS, ICOLN
+CHARACTER(LEN=10) :: FORMAX, FORMAY
+CHARACTER(LEN=20) :: YNOM
+CHARACTER(LEN=1) :: YSYMB
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DISPLAY WINDOW SETTING AND DRAWING
+! ----------------------------------
+!
+ZWL=XXX(NIINF,NMGRID)
+ZWR=XXX(NISUP,NMGRID)
+ZWB=XXY(NJINF,NMGRID)
+ZWT=XXY(NJSUP,NMGRID)
+ZXMIN=ZWL; ZXMAX=ZWR; ZYMIN=ZWB; ZYMAX=ZWT
+!
+ZDIFWLR=ZWR-ZWL
+ZDIFWBT=ZWT-ZWB
+if(nverbia > 0)then
+print *,' defenetre ENTREE NMGRID NIINF,NISUP,NJINF,NJSUP,ZDIFWLR,ZDIFWBT'
+print *,NMGRID,NIINF,NISUP,NJINF,NJSUP,ZDIFWLR,ZDIFWBT
+print *,'ZWL,ZWR,ZWB,ZWT, ',ZWL,ZWR,ZWB,ZWT
+endif
+!
+IF(LVPTUSER)THEN
+ ZDIFVPTBT=XVPTT-XVPTB
+ ZDIFVPTLR=XVPTR-XVPTL
+ IF(ZDIFVPTBT >= ZDIFVPTLR*ZDIFWBT/ZDIFWLR)THEN
+ ZDIFVBT=ZDIFVPTLR*ZDIFWBT/ZDIFWLR
+ ZVB=XVPTB+ABS(ZDIFVPTBT-ZDIFVBT)/2.
+! XVPTB=XVPTB+ABS(ZDIFVPTBT-ZDIFVBT)/2.
+ ZVT=XVPTT-ABS(ZDIFVPTBT-ZDIFVBT)/2.
+! XVPTT=XVPTT-ABS(ZDIFVPTBT-ZDIFVBT)/2.
+ ZVL=XVPTL; ZVR=XVPTR
+ ELSE
+ ZDIFVLR=ZDIFVPTBT*ZDIFWLR/ZDIFWBT
+ ZVL=XVPTL+ABS(ZDIFVPTLR-ZDIFVLR)/2.
+! XVPTL=XVPTL+ABS(ZDIFVPTLR-ZDIFVLR)/2.
+ ZVR=XVPTR-ABS(ZDIFVPTLR-ZDIFVLR)/2.
+! XVPTR=XVPTR-ABS(ZDIFVPTLR-ZDIFVLR)/2.
+ ZVB=XVPTB; ZVT=XVPTT
+ ENDIF
+if(nverbia > 0)then
+print *,'ZVL,ZVR,ZVB,ZVT LVPTUSER=T, ',ZVL,ZVR,ZVB,ZVT
+endif
+ELSE
+ IF(ZDIFWLR.GT.ZDIFWBT)THEN
+ ZVL=.1
+ ZVR=.90
+ ! ZVR=.95
+ ZDIFVLR=ZVR-ZVL
+ ZDIFVBT=ZDIFVLR/ZDIFWLR*ZDIFWBT
+ ZVB=(1.-ZDIFVBT)/2.
+ ZVT=1.-ZVB
+if(nverbia > 0)then
+print *,'ZVL,ZVR,ZVB,ZVT, ',ZVL,ZVR,ZVB,ZVT
+endif
+ ELSE
+ ZVB=.1
+ ZVT=.90
+ ! ZVT=.95
+ ZDIFVBT=ZVT-ZVB
+ ZDIFVLR=ZDIFVBT/ZDIFWBT*ZDIFWLR
+ ZVL=(1.-ZDIFVLR)/2.
+ ZVR=1.-ZVL
+ END IF
+END IF
+!
+if(nverbia > 0)then
+print *,' defenetre ZVL,ZVR,ZVB,ZVT ',ZVL,ZVR,ZVB,ZVT
+endif
+!!!!!!!!!!!!!!! Sept 99
+IF(LINDAX)THEN
+if(nverbia > 0)then
+print *, '***********DEFENETRE NIINF ...',NIINF,NISUP,NJINF,NJSUP
+endif
+CALL SET(ZVL,ZVR,ZVB,ZVT,FLOAT(NIINF),FLOAT(NISUP),FLOAT(NJINF),FLOAT(NJSUP),1) ! Sets NCAR user coordinates
+FORMAX=' '
+IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ELSE
+ FORMAX='(F5.1)'
+ENDIF
+FORMAY=' '
+IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ELSE
+ FORMAY='(F5.1)'
+ENDIF
+
+CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0) ! Sets axis label formats
+!CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0) ! Sets axis label formats
+!CALL LABMOD('(F5.1)','(F5.1)',0,0,10,10,0,0,0) ! Sets axis label formats
+
+ELSE
+
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1) ! Sets NCAR user coordinates
+! ! and normalized coordinates
+FORMAX=' '
+IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ELSE
+ FORMAX='(F8.0)'
+ENDIF
+FORMAY=' '
+IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ELSE
+ FORMAY='(F8.0)'
+ENDIF
+CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0) ! Sets axis label formats
+!CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0) ! Sets axis label formats
+!CALL LABMOD('(F8.0)','(F8.0)',0,0,10,10,0,0,0) ! Sets axis label formats
+ENDIF
+!!!!!!!!!!!!!!! Sept 99
+!CALL GRIDAL(1,1,1,1,1,1,5,0.,0.)
+CALL GASETI('LTY',1) ! Labels printed by PLCHHQ
+IF(LINDAX)THEN
+! Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCHITVXMJ,NCHITVXMN,NCHITVYMJ,NCHITVYMN,0,0,5,0.,0) ! Draws axis tiks and labels
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCHITVXMJ,NCHITVXMN,NCHITVYMJ,NCHITVYMN,0,1,5,0.,0) ! Draws axis tiks and labels
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCHITVXMJ,NCHITVXMN,NCHITVYMJ,NCHITVYMN,1,0,5,0.,0) ! Draws axis tiks and labels
+ ELSE
+ CALL GRIDAL(NCHITVXMJ,NCHITVXMN,NCHITVYMJ,NCHITVYMN,1,1,5,0.,0) ! Draws axis tiks and labels
+ ENDIF
+! Avril 2002
+ELSE
+! Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCHITVXMJ,NCHITVXMN,NCHITVYMJ,NCHITVYMN,0,0,5,0.,0) ! Draws axis tiks and labels
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCHITVXMJ,NCHITVXMN,NCHITVYMJ,NCHITVYMN,0,1,5,0.,0) ! Draws axis tiks and labels
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCHITVXMJ,NCHITVXMN,NCHITVYMJ,NCHITVYMN,1,0,5,0.,0) ! Draws axis tiks and labels
+ ELSE
+ CALL GRIDAL(NCHITVXMJ,NCHITVXMN,NCHITVYMJ,NCHITVYMN,1,1,5,0.,0) ! Draws axis tiks and labels
+ ENDIF
+! Avril 2002
+ENDIF
+!CALL GRIDAL(5,0,4,0,1,1,5,0.,0) ! Draws axis tiks and labels
+CALL PERIM(1,0,1,0) ! Draws perimeter box
+!
+!!!!!!!!!!!!!!! Sept 99
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1) ! Sets NCAR user coordinates
+!!!!!!!!!!!!!!! Sept 99
+!!!!!!!!!!!!!!! NOv R2000
+
+! deplace en juillet 2010 dans bcgrd_fordiachro.f90 par G. TANGUY
+!if(nverbia > 0)then
+! print *,' **defenetre NIJCAR ',NIJCAR
+!endif
+!IF(NIJCAR.GE.1)THEN
+! IF(.NOT.LCOLAREA .AND. .NOT.LCOLINE)THEN
+! call tabcol_fordiachro
+! ENDIF
+!! IF(LUMVM .OR. LUTVT .AND. NSUPERDIA == 1)THEN
+!! call tabcol_fordiachro
+!! ENDIF
+! DO JCAR=1,NIJCAR
+! ZI=XICAR(JCAR)
+! ZJ=XJCAR(JCAR)
+! print *,' **defenetre ZI,ZJ ',ZI,ZJ
+! YSYMB=CSYMCAR(JCAR)
+! ZPOS=XPOSNOM(JCAR)
+! ICOLS=ICOLSYM(JCAR)
+! ICOLN=ICOLNOM(JCAR)
+! IF(XSZSYM(JCAR) /= 0.)THEN
+! ZSZ=XSZSYM(JCAR)
+! IF(ZSZ == 9999.)ZSZ=.012
+! ELSE
+! ZSZ=.012
+! ENDIF
+! ICONVI=INT(ZI)
+! ICONVJ=INT(ZJ)
+! if(nverbia > 0)then
+! print *,' **defenetre ICONVI, ICONVJ ',ICONVI,ICONVJ
+! endif
+! ZX=XXX(ICONVI,NMGRID)+(XXX(MIN(ICONVI+1,SIZE(XXX,1)),NMGRID)-XXX(ICONVI,NMGRID))*(ZI-FLOAT(ICONVI))
+! ZY=XXY(ICONVJ,NMGRID)+(XXY(MIN(ICONVJ+1,SIZE(XXY,1)),NMGRID)-XXY(ICONVJ,NMGRID))*(ZJ-FLOAT(ICONVJ))
+! if(nverbia > 0)then
+! print *,' **defenetre ZX,ZY ',ZX,ZY
+! endif
+!! CALL SM_XYHAT_S(XLATOR,XLONOR,ZLAT,ZLON,ZU,ZV)
+! CALL PCSETI('OC',ICOLS)
+! IF(YSYMB == '.')THEN
+! CALL NGWSYM('N',8,ZX,ZY,ZSZ,ICOLS,0)
+! ELSE
+! CALL PCSETI('OF',2)
+! CALL PCSETR('OL',1.5)
+! CALL PLCHHQ(ZX,ZY,YSYMB,ZSZ,0.,0.)
+! CALL PCSETI('OF',0)
+! CALL PCSETR('OL',0.)
+! ENDIF
+! CALL PCSETI('OC',1)
+! IF(XSZNOM(JCAR) /= 0.)THEN
+! ZSZ=XSZNOM(JCAR)
+! IF(ZSZ == 9999.)ZSZ=.012
+! ELSE
+! ZSZ=.012
+! ENDIF
+! IPOS=ZPOS
+!! print *,' ZSZ NOM ',ZSZ
+! SELECT CASE(IPOS)
+! CASE(0)
+! ZCENT=-1.
+! ZX=ZX+ZSZ*1.1*(ZXMAX-ZXMIN)
+! CASE(45)
+! ZCENT=-1.
+! ZX=ZX+ZSZ*1.0*(ZXMAX-ZXMIN)
+! ZY=ZY+ZSZ*1.0*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+! CASE(90)
+! ZCENT=0.
+! ZY=ZY+ZSZ*1.5*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+! CASE(135)
+! ZCENT=1.
+! ZX=ZX-ZSZ*1.0*(ZXMAX-ZXMIN)
+! ZY=ZY+ZSZ*1.0*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+! CASE(180)
+! ZCENT=1.
+! ZX=ZX-ZSZ*1.1*(ZXMAX-ZXMIN)
+! CASE(225)
+! ZCENT=1.
+! ZX=ZX-ZSZ*1.0*(ZXMAX-ZXMIN)
+! ZY=ZY-ZSZ*1.0*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+! CASE(270)
+! ZCENT=0.
+! ZY=ZY-ZSZ*1.5*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+! CASE(315)
+! ZCENT=-1.
+! ZX=ZX+ZSZ*1.0*(ZXMAX-ZXMIN)
+! ZY=ZY-ZSZ*1.0*(MAX(ZXMAX-ZXMIN,ZYMAX-ZYMIN))
+! END SELECT
+! IF(CNOMCAR(JCAR) /= ' ')THEN
+! YNOM=CNOMCAR(JCAR)
+! YNOM=ADJUSTL(YNOM)
+! CALL PCSETI('OF',2)
+! CALL PCSETI('OC',ICOLN)
+! CALL PCSETR('OL',1.5)
+!! CALL GSTXCI(ICOLN)
+!! CALL GSPLCI(ICOLN)
+! CALL PLCHHQ(ZX,ZY,YNOM(1:LEN_TRIM(YNOM)),ZSZ,0.,ZCENT)
+! ENDIF
+! CALL PCSETI('OF',0)
+! CALL PCSETR('OL',0.)
+! CALL PCSETI('OC',1)
+! CALL GSTXCI(1)
+! ENDDO
+!ENDIF
+!!!!!!!!!!!!!!! NOv R2000
+!-----------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE DEFENETRE
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/diaprog.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/diaprog.f90
new file mode 100644
index 0000000000000000000000000000000000000000..74294ec002818fc1f25cf426f950944e84133bb6
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/diaprog.f90
@@ -0,0 +1,1038 @@
+! ######spl
+ PROGRAM DIAPROG
+! ################
+!
+!!**** *DIAPROG* -
+!!
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHORS
+!! -------
+!! J. Duron *Lab. Aerologie*
+!!
+!! Copyright 1994, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 23/11/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+#ifdef NAGf95
+USE F90_UNIX ! for FLUSH and GETENV
+#endif
+
+USE MODD_CST
+USE MODD_CONF, ONLY : CPROGRAM
+USE MODD_MASK3D
+USE MODD_COORD
+USE MODD_TYPE_AND_LH
+USE MODD_GRID
+USE MODD_GRID1
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_ALLOC2_FORDIACHRO
+USE MODN_NCAR
+USE MODN_PARA
+USE MODD_OUT
+USE MODD_NMGRID
+USE MODD_FILES_DIACHRO
+USE MODD_RESOLVCAR
+USE MODI_EXTRACT_AND_OPEN_FILES
+USE MODI_READ_DIMGRIDREF
+USE MODI_READ_DIACHRO
+USE MODI_CARESOLV
+USE MODI_CARMEMORY
+USE MODI_LOAD_FMTAXES
+USE MODI_LOAD_SEGMENTS
+USE MODI_CONVLO2UP
+USE MODI_OPER_PROCESS
+USE MODI_PRINTS
+USE MODI_REALLOC_AND_LOAD
+USE MODI_ALLOC2_FORDIACHRO
+USE MODI_DIFF_OPER
+USE MODD_TIT
+USE MODD_PVT
+USE MODD_MEMCV
+USE MODD_EXPR
+USE MODI_RESOLV_TIT
+USE MODI_LOAD_TIT
+USE MODI_CONVIJ2XY
+USE MODD_SEVERAL_RECORDS
+USE MODI_VERIF_GROUP
+USE MODI_READ_UVW
+USE MODI_READ_TYPE
+USE MODD_PT_FOR_CH_FORDIACHRO
+!!!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!!!!!!!!
+USE MODD_TRAJ3D
+!!!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!!!!!!!!
+USE MODI_WRITEDIR
+
+IMPLICIT NONE
+!
+!* 0.1 Local variables declarations
+!
+INTEGER :: JI, JIA, JJ, J, JM, ITOP1, ITOP2
+INTEGER :: JLOOP, INDEXPR, IMULTDIV
+INTEGER :: INDE, ILENC240, ILENC
+INTEGER :: INDPRI, INDTIT, INDPRIL, IZERO
+INTEGER :: IDIR, IDIRESP, ITITDEF
+INTEGER :: ICONVIJ2XY, ICONVXY2IJ, ICONVALLIJ2LL
+INTEGER :: ICNOMCAR, ICSYMCAR
+INTEGER :: ICGROUPSV3, ILENT, IQUOT
+#ifdef RHODES
+INTEGER :: ISTAF
+#endif
+!!!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!!!!!!!!
+INTEGER :: ICTRAJ_GROUP
+!!!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!!!!!!!!
+
+REAL,DIMENSION(:),ALLOCATABLE :: ZBID2
+REAL,DIMENSION(:,:),ALLOCATABLE :: ZBID1
+CHARACTER(LEN=100) :: CAR100
+CHARACTER(LEN=80) :: CAR80
+CHARACTER(LEN=20) :: CAR20, VARTTY
+CHARACTER(LEN=2400) :: CAR240, YCAR240
+CHARACTER(LEN=16) :: YDIRNAM
+CHARACTER(LEN=8) :: YDAT
+CHARACTER(LEN=10) :: YTEM
+CHARACTER(LEN=6) :: YMULTDIV
+
+INTEGER :: ILINES=25 ! nb de lignes de directives avec &
+
+LOGICAL :: GMASK3D, GMASK3D_XY, GMASK3D_XZ, GMASK3D_YZ
+!-------------------------------------------------------------------------------
+!
+!* 1. P
+! ---------------------------------------
+!
+CPROGRAM='DIAPRO'
+!
+! Initialisation des parametres de Namelists
+!
+CALL INIDEF
+CTITALL='DEFAULT'; LTITDEF=.TRUE.
+CALL RESOLV_TIT('CTITALL',YTEM)
+!
+! Ouverture du fichier de conservation des directives
+! Son nom: dir.date
+!
+!CALL DATE(YDAT)
+YTEM=' '
+CALL DATE_AND_TIME(YDAT,YTEM)
+YDIRNAM(1:4)='dir.'
+!YTEM(1:2)=YDAT(7:8); YTEM(4:5)=YDAT(4:5); YTEM(7:8)=YDAT(1:2)
+!YTEM(1:2)=YDAT(7:8); YTEM(4:5)=YDAT(5:6); YTEM(7:8)=YDAT(3:4)
+!YTEM(3:3)=':'; YTEM(6:6)=':'
+YDIRNAM(5:6)=YDAT(7:8)
+YDIRNAM(7:8)=YDAT(5:6)
+YDIRNAM(9:10)=YDAT(3:4)
+YDIRNAM(11:11)=':'
+YDIRNAM(12:13)=YTEM(1:2)
+YDIRNAM(14:14)=':'
+YDIRNAM(15:16)=YTEM(3:4)
+!YDIRNAM(5:12)=YTEM
+CALL FMATTR(YDIRNAM,YDIRNAM,IDIR,IDIRESP)
+OPEN(UNIT=IDIR,FILE=YDIRNAM,FORM='FORMATTED')
+NDIR=IDIR
+!
+! Lecture et interpretation des directives
+!
+DO JJ = 1,100000
+ CAR240(1:LEN(CAR240))=' '
+ CGROUP(1:LEN(CGROUP))=' '
+ CGROUPS(:)(1:LEN(CGROUPS(1)))=' '
+ IF(JJ == 1)THEN
+ print *,' ENTREZ VOS DIRECTIVES '
+ ELSE
+ print *,' DIRECTIVE ? '
+ ENDIF
+ DO JI = 1,ILINES ! directive sur ILINES lignes
+ CAR80(1:LEN(CAR80))=' '
+ CAR100(1:LEN(CAR100))=' '
+ READ(5,'(A100)',END=10)CAR100
+ CAR100=ADJUSTL(CAR100)
+ IF( LEN_TRIM(CAR100)>80 .AND. CAR100(1:1) /= '!' ) THEN
+ print *,'-- Directive:'
+ print *,TRIM(CAR100)
+ print *,' depassant 80 car. : ABORT'
+ CAR80='QUIT'
+ GO TO 99
+ ENDIF
+ READ(CAR100,'(A80)')CAR80
+ CAR80=ADJUSTL(CAR80)
+ !WRITE(IDIR,'(A80)')CAR80
+ CALL WRITEDIR(IDIR,CAR80)
+ GO TO 20
+ 10 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",CAR20)
+ CAR20=ADJUSTL(CAR20)
+ OPEN(5,FILE=CAR20)
+ print *,' diaprog INTERACTIF : ENTREZ VOS DIRECTIVES '
+ 20 CONTINUE
+ CAR80=ADJUSTL(CAR80)
+ print *,CAR80(1:LEN_TRIM(CAR80))
+! Test FF et commentaires
+ IF(CAR80(1:1) == '!')EXIT
+ IF(CAR80(1:4) == 'QUIT' .OR. CAR80(1:4) == 'quit')GO TO 99
+ INDE = INDEX(CAR80,'&')
+ IF(INDE == 0)THEN
+ ! directive sur une ligne
+ ILENC=LEN_TRIM(CAR80)
+ ILENC240=LEN_TRIM(CAR240)
+ IF (ILENC240+ILENC .LE. LEN(CAR240)) THEN
+ CAR240(ILENC240+1:ILENC240+ILENC)=CAR80(1:ILENC)
+ ELSE
+ print *,'Erreur! '//CAR240(1:20)//'... depasse ',LEN(CAR240),' caracteres'
+ CAR240=' '
+ ENDIF
+ EXIT
+ ELSE
+ IF (JI==ILINES) THEN
+ print *,'-- Pas plus de ',ILINES,' lignes pour une directive : ABORT'
+ CAR80='QUIT'
+ GO TO 99
+ ENDIF
+ DO JIA=INDE-1,1,-1
+ IF(CAR80(JIA:JIA) /= ' ')THEN
+ ! suite des directives ligne suivante
+ ILENC240=LEN_TRIM(CAR240)
+ ILENC=JIA
+ IF (ILENC240+ILENC .LE. LEN(CAR240)) THEN
+ CAR240(ILENC240+1:ILENC240+ILENC)=CAR80(1:ILENC)
+ ELSE
+ print *,'Erreur! '//CAR240(1:20)//'... depasse ',LEN(CAR240),' caracteres'
+ CAR240=' '
+ ENDIF
+ EXIT
+ END IF
+ ENDDO
+ END IF
+ ENDDO
+#ifdef RHODES
+CALL FLUSH(IDIR,ISTAF)
+#else
+CALL FLUSH(IDIR)
+#endif
+
+IF(LEN_TRIM(CAR240) == 0)CYCLE
+!
+! Conversion des mots cles des instructions en MAJUSCULES
+!
+CDIRCUR(1:LEN(CDIRCUR))=' '
+CALL CONVLO2UP(CAR240(1:LEN_TRIM(CAR240)),YCAR240)
+IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ CYCLE
+ENDIF
+CDIRCUR(1:LEN_TRIM(YCAR240))=YCAR240(1:LEN_TRIM(YCAR240))
+!
+CAR240(1:LEN(CAR240))=' '
+CAR240=ADJUSTL(YCAR240)
+print* ,CAR240(1:LEN_TRIM(CAR240))
+!
+! Juillet 2001 * ou / par un processus DEB*****************
+!
+! Desallocation des tableaux si RM*EXPRx (avec x=1 a 9)
+INDEXPR=INDEX(CAR240,'RM*EXPR')
+IF(INDEXPR /= 0)THEN
+ IZERO=0
+ CALL LOAD_EXPR(IZERO,CAR240(1:LEN_TRIM(CAR240)))
+ CYCLE
+ENDIF
+! Desallocation des tableaux si RM/EXPRx (avec x=1 a 9)
+INDEXPR=INDEX(CAR240,'RM/EXPR')
+IF(INDEXPR /= 0)THEN
+ IZERO=0
+ CALL LOAD_EXPR(IZERO,CAR240(1:LEN_TRIM(CAR240)))
+ CYCLE
+ENDIF
+! Chargement du processus a * ou /
+INDEXPR=INDEX(CAR240,'*EXPR')
+IF(INDEXPR /= 0)THEN
+ IF(CAR240(INDEXPR+6:INDEXPR+6) == '=')THEN
+ IZERO=0
+ CALL LOAD_EXPR(IZERO,CAR240(1:LEN_TRIM(CAR240)))
+ CYCLE
+ ENDIF
+ENDIF
+INDEXPR=INDEX(CAR240,'/EXPR')
+IF(INDEXPR /= 0)THEN
+ IF(CAR240(INDEXPR+6:INDEXPR+6) == '=')THEN
+ IZERO=0
+ CALL LOAD_EXPR(IZERO,CAR240(1:LEN_TRIM(CAR240)))
+ CYCLE
+ ENDIF
+ENDIF
+!
+! Juillet 2001 * ou / par un processus FIN*****************
+!
+! Nov 2001 Deplacement des impressions + haut
+!
+! Traitement des impressions
+!
+INDPRI=INDEX(CAR240,'PRINT ')
+INDPRIL=INDEX(CAR240,'LPRINT ')
+IF(INDPRI /= 0 .AND. INDPRIL == 0)THEN
+ CALL PRINTS(CAR240(1:LEN_TRIM(CAR240)))
+ CYCLE
+ENDIF
+!
+! Lecture eventuelle du groupe SV3 a utiliser comme coord. vert.
+!
+ICGROUPSV3=INDEX(CAR240,'CGROUPSV3')
+IF(ICGROUPSV3 /= 0)THEN
+ CGROUPSV3(1:LEN(CGROUPSV3))=' '
+ ILENT=LEN_TRIM(CAR240)
+ IQUOT=INDEX(CAR240,"'")
+ IF(IQUOT == 0)THEN
+ IQUOT=INDEX(CAR240,'"')
+ ENDIF
+ CGROUPSV3=CAR240(IQUOT+1:ILENT-1)
+ CGROUPSV3=ADJUSTL(CGROUPSV3)
+ print *,' CGROUPSV3 FOURNI ',CGROUPSV3
+ CYCLE
+ENDIF
+!!!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!!!!!!!!
+!
+! Lecture eventuelle du groupe TRAJ_GROUP a utiliser pour les trajectoires
+!
+ICTRAJ_GROUP=INDEX(CAR240,'CTRAJ_GROUP')
+IF(ICTRAJ_GROUP /= 0)THEN
+ CTRAJ_GROUP(1:LEN(CTRAJ_GROUP))=' '
+ ILENT=LEN_TRIM(CAR240)
+ IQUOT=INDEX(CAR240,"'")
+ IF(IQUOT == 0)THEN
+ IQUOT=INDEX(CAR240,'"')
+ ENDIF
+ CTRAJ_GROUP=CAR240(IQUOT+1:ILENT-1)
+ CTRAJ_GROUP=ADJUSTL(CTRAJ_GROUP)
+ print *,' CTRAJ_GROUP FOURNI ',CTRAJ_GROUP
+ CYCLE
+ENDIF
+!!!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!!!!!!!!
+!
+! Conversion d'indices de grille I,J en coord. conf et geographiques
+!
+ICONVIJ2XY=INDEX(CAR240,'CONVIJ2XY')
+IF(ICONVIJ2XY /= 0)THEN
+ CALL CONVIJ2XY(CAR240)
+ IF(LPBREAD)LPBREAD=.FALSE.
+ CYCLE
+ENDIF
+!
+ICONVALLIJ2LL=INDEX(CAR240,'CONVALLIJ2LL')
+IF(ICONVALLIJ2LL /= 0)THEN
+ CALL CONVALLIJ2LL(CAR240)
+ IF(LPBREAD)LPBREAD=.FALSE.
+ CYCLE
+ENDIF
+!
+! Conversion de coord. conf et geographiques en indices de grille
+!
+ICONVXY2IJ=INDEX(CAR240,'CONVXY2IJ')
+IF(ICONVXY2IJ /= 0)THEN
+ CALL CONVXY2IJ(CAR240)
+ IF(LPBREAD)LPBREAD=.FALSE.
+ CYCLE
+ENDIF
+!
+! Memorisation des textes et symboles associes a un couple lat,lon
+!
+ICNOMCAR=INDEX(CAR240,'CNOMCAR')
+IF(ICNOMCAR /= 0)THEN
+ CALL CARESOLV(CAR240)
+! CALL CARESOLV(CAR240(1:LEN_TRIM(CAR240)))
+ IF(LPBREAD)LPBREAD=.FALSE.
+ NBGUIL=0
+ CYCLE
+ENDIF
+ICSYMCAR=INDEX(CAR240,'CSYMCAR')
+IF(ICSYMCAR /= 0)THEN
+ CALL CARESOLV(CAR240)
+! CALL CARESOLV(CAR240(1:LEN_TRIM(CAR240)))
+ IF(LPBREAD)LPBREAD=.FALSE.
+ if(nverbia >0)then
+ print *,' ***DIAPROG ICSYMCAR > 0 AV CYCLE'
+ endif
+ NBGUIL=0
+ CYCLE
+ENDIF
+!
+! Traitement des eventuels segments de dte a superposer sur une CH en PCart.
+!
+INDTIT=INDEX(CAR240,'XSEGM')
+IF(INDTIT /= 0)THEN
+ CALL LOAD_SEGMENTS(CAR240(1:LEN_TRIM(CAR240)),INDTIT)
+ CYCLE
+ENDIF
+!
+! Traitement des eventuels segments de dte a superposer sur une CH
+!
+INDTIT=INDEX(CAR240,'ISEGM')
+IF(INDTIT /= 0)THEN
+ CALL LOAD_SEGMENTS(CAR240(1:LEN_TRIM(CAR240)),INDTIT)
+ CYCLE
+ENDIF
+!
+! Traitement des eventuels formats des labels des axes
+!
+INDTIT=INDEX(CAR240,'CFMTAXEX')
+IF(INDTIT /= 0)THEN
+ CALL LOAD_FMTAXES(CAR240(1:LEN_TRIM(CAR240)),INDTIT)
+ CYCLE
+ENDIF
+INDTIT=INDEX(CAR240,'CFMTAXEY')
+IF(INDTIT /= 0)THEN
+ CALL LOAD_FMTAXES(CAR240(1:LEN_TRIM(CAR240)),INDTIT)
+ CYCLE
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!! pour les retrotrajectoires !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!
+! Traitement eventuel du format des labels des retrotrajectoires
+!
+INDTIT=INDEX(CAR240,'CFMTRTRAJ')
+IF(INDTIT /= 0)THEN
+ CALL LOAD_FMTAXES(CAR240(1:LEN_TRIM(CAR240)),INDTIT)
+ CYCLE
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Traitement des eventuels titres
+!
+ITITDEF=0
+INDTIT=INDEX(CAR240,'LTITDEF')
+IF(INDTIT /= 0)THEN
+ CALL LOAD_TIT(CAR240(1:LEN_TRIM(CAR240)),INDTIT)
+ ITITDEF=1
+ENDIF
+INDTIT=INDEX(CAR240,'CTIT')
+IF(INDTIT /= 0)THEN
+ CALL LOAD_TIT(CAR240(1:LEN_TRIM(CAR240)),INDTIT)
+ IF(INDTIT == 999)THEN
+ INDTIT=0
+ CYCLE
+ ENDIF
+ INDTIT=0
+ENDIF
+IF(ITITDEF == 1)THEN
+ ITITDEF=0
+ CYCLE
+ENDIF
+!print *,CAR240
+!print *,LEN_TRIM(CAR240)
+!READ(*,*)
+!
+! Ajout artificiel d'un niveau de modele avec _MSKTOP_ pour des facilites
+! de programmation (si absent)
+!
+ITOP1=INDEX(CAR240,'_MSKTOP_')
+IF(ITOP1 /= 0)THEN
+ ITOP2=INDEX(CAR240,'_K_')
+ IF(ITOP2 == 0)THEN
+ CAR240=ADJUSTL(ADJUSTR(CAR240)//'_K_2')
+ print *,' **diaprog . directive generee volontairement :',CAR240(1:LEN_TRIM(CAR240))
+ ENDIF
+ENDIF
+!
+! Traitement SAV et NOSAV (SAVE et NOSAVE)
+!
+IF(CAR240(1:LEN_TRIM(CAR240)) == 'NOSAV' .OR. &
+ CAR240(1:LEN_TRIM(CAR240)) == 'NOSAVE')THEN
+ CALL GDAWK(1)
+ CYCLE
+ELSE IF(CAR240(1:LEN_TRIM(CAR240)) == 'SAV' .OR. &
+ CAR240(1:LEN_TRIM(CAR240)) == 'SAVE')THEN
+ CALL GACWK(1)
+ CYCLE
+ENDIF
+!
+! Extraction des noms de fichiers; eventuelle ouverture; mise a jour du numero
+! de fichier courant dans la variable NUMFILECUR. Elimination du nom des
+! fichiers et des sequences _FILE_ _FILEx_ FILExx_ des instructions d'entree
+!
+if (nverbia >0)then
+ print *,' ****DIAPROG AV EXTRACT_AND_OPEN_FILES '
+ print *,CAR240(1:LEN_TRIM(CAR240))
+endif
+
+CALL EXTRACT_AND_OPEN_FILES(CAR240(1:LEN_TRIM(CAR240)),YCAR240)
+IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ CYCLE
+ENDIF
+
+if (nverbia >0)then
+ print *,' AP EXTRACT_AND_OPEN_FILES '
+ print *,YCAR240(1:LEN_TRIM(YCAR240))
+endif
+CAR240(1:LEN_TRIM(CAR240))=' '
+CAR240=ADJUSTL(YCAR240)
+!
+! Memorisation de l'instruction d'entree en vue de reutiliser les specifica-
+! -pour le groupe suivant avec l'option IDEM
+!
+!IF(JJ == 1)THEN
+! CALL CARMEMORY(CAR240,1)
+!ENDIF
+!
+!
+! Resolution des temps, processus, niveaux, altitudes ...
+!
+if (nverbia >0)then
+ print *,' AV CARESOLV'
+endif
+CALL CARESOLV(CAR240(1:LEN_TRIM(CAR240)))
+if (nverbia >0)then
+ print *,' AP CARESOLV'
+endif
+IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ CYCLE
+ENDIF
+!
+!
+DO JLOOP=1,NSUPERDIA
+
+ NLOOPSUPER=JLOOP
+ LXYZ=LXYZT(JLOOP)
+! Mars 2000
+ LUMVMPV=LUMVMPVT(JLOOP)
+! Mars 2000
+! Memorisation pour - et +
+ IF(JLOOP == 1)THEN
+ LTITDEFM=LTITDEF
+ CTITB3MEM=CTITB3
+ CTITB3MEM=ADJUSTL(CTITB3MEM)
+ if(nverbia >0)print *,' **diaprog LTITDEFM, CTITB3MEM ',LTITDEFM,CTITB3MEM
+ ENDIF
+!!!!!!Oct 2000 Prise en compte de superposition d'un pH issu du 2D Hor. sur
+! une CV
+ IF(NHISTORY(JLOOP) == 1)THEN
+ LCH=.FALSE.
+ LCV=.TRUE.
+ ELSEIF(NHISTORY(JLOOP) == 3)THEN
+ LCH=.TRUE.
+ LCV=.TRUE.
+ ENDIF
+!!!!!!Oct 2000
+
+ IF(NBPM > 1)THEN
+!!!!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!
+! IF(JLOOP >= 2)THEN
+ IF(JLOOP >= 1)THEN
+!!!!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!
+ IF(NUMPM(JLOOP) == 1)THEN
+ LPLUS=.TRUE.
+ LMINUS=.FALSE.
+ ELSE IF(NUMPM(JLOOP) == 2)THEN
+ LMINUS=.TRUE.
+ LPLUS=.FALSE.
+ ELSE
+ LMINUS=.FALSE.
+ LPLUS=.FALSE.
+!!!!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!
+ IF(JLOOP < NSUPERDIA)THEN
+ IF(NUMPM(JLOOP+1) == 1)THEN
+ LPLUS=.TRUE.
+ ELSE IF(NUMPM(JLOOP+1) == 2)THEN
+ LMINUS=.TRUE.
+ ENDIF
+ ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!
+ ENDIF
+ ENDIF
+ ENDIF
+! print *,' PG PAL LMINUS LPLUS JLOOP ',LMINUS,LPLUS,JLOOP
+
+ CGROUP=ADJUSTL(CGROUPS(JLOOP))
+ IF(CGROUP(1:LEN_TRIM(CGROUP)) == ' ')THEN
+ EXIT
+ ELSE
+ NUMFILECUR=NFILESCUR(JLOOP)
+ DO J=1,NBFILES
+ IF(NUMFILES(J) == NUMFILECUR)THEN
+ JM=J
+ ENDIF
+ ENDDO
+!
+! Lecture du type d'informations demandees
+!
+ CALL READ_TYPE(CFILEDIAS(JM),CLUOUTDIAS(JM),CGROUP(1:LEN_TRIM(CGROUP)))
+! Sorties sur surfaces isobares ou isentropes ou emagrammes
+! Chargement des infos utiles
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ EXIT
+ ENDIF
+ if(nverbia >0)then
+ print *,' **diaprog AP READ_TYPE LTK,LPR,LEV,LSV3 ',LTK,LPR,LEV,LSV3
+ endif
+!
+! Chargement de la temperature pour sorties en surfaces isentropes et
+! emagrammes
+!
+ ! test pour eviter les messages de READ_TH_PR dans ce cas
+ IF(CGROUP(1:LEN_TRIM(CGROUP)) == 'ZS' .OR. CGROUP(1:LEN_TRIM(CGROUP)) == &
+ 'ZSBIS')THEN
+ ELSE
+
+ IF((LTK .OR. LEV .OR. LSV3) .OR. LPR .OR. LPRESY .OR. ((LRS .OR. LRS1) .AND. CTYPE=='CART'))THEN
+ NMT=2
+ IF(CGROUP(LEN_TRIM(CGROUP):LEN_TRIM(CGROUP)) == 'M')NMT=1
+! NMT=1
+! IF(CGROUP(LEN_TRIM(CGROUP):LEN_TRIM(CGROUP)) == 'T')NMT=2
+ ENDIF
+
+! LTK = .TRUE. ou LRS = .TRUE. ou LRS1 = .TRUE. ou LEV=.TRUE.
+
+ IF((LTK .OR. LEV .OR. LSV3) .OR. ((LRS .OR. LRS1) .AND. CTYPE=='CART'))THEN
+ CALL READ_TH_PR(CFILEDIAS(JM),CLUOUTDIAS(JM),NMT,1)
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+! EXIT
+ IF(NMT == 1)THEN
+ NMT=2
+ ELSE
+ NMT=1
+ ENDIF
+ CALL READ_TH_PR(CFILEDIAS(JM),CLUOUTDIAS(JM),NMT,1)
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ EXIT
+ ENDIF
+ ENDIF
+ IF(LSV3 .AND. MAXVAL(XZHAT)/MAXVAL(XTH) > 1.E2)THEN
+ IF(.NOT.LXYZ00 .OR. CGROUPSV3 == 'Z00')THEN
+ if(nverbia >0)then
+ print *,' **diaprog MAXVAL(XZHAT)/MAXVAL(XTH) ',MAXVAL(XZHAT)/MAXVAL(XTH)
+ endif
+ WHERE(XTH /= XSPVAL)
+ XTH=XTH*1.E3
+ ENDWHERE
+ if(nverbia >0)then
+ print *,' **diaprog MAXVAL(XTH) ap *1.E3',MAXVAL(XTH)
+ print *,' **diaprog MINVAL(XTH) ap *1.E3',MINVAL(XTH)
+ endif
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ENDIF
+!
+! LPR = .TRUE. ou LRS = .TRUE. ou LRS1 = .TRUE. Calcul ou lecture de la pression
+!
+ IF(LPR .OR. LPRESY .OR. ((LRS .OR. LRS1) .AND. CTYPE=='CART'))THEN
+ CALL READ_TH_PR(CFILEDIAS(JM),CLUOUTDIAS(JM),NMT,2)
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+! EXIT
+ IF(NMT == 1)THEN
+ NMT=2
+ ELSE
+ NMT=1
+ ENDIF
+ CALL READ_TH_PR(CFILEDIAS(JM),CLUOUTDIAS(JM),NMT,2)
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ IF(LPRESY)THEN
+ print *,' Pression absente (PABSM et PABST) -> LPRESY remis a F '
+ LPRESY=.FALSE.
+ ENDIF
+ EXIT
+ ENDIF
+ ENDIF
+ ENDIF
+!
+! Chargement des composantes du vent dans le cas de combinaisons de celles-ci
+!
+ IF(LUMVM .OR. LMUMVM .OR. LULM .OR. LVTM .OR. LULMWM .OR. &
+ LUTVT .OR. LMUTVT .OR. LULT .OR. LVTT .OR. LULTWT .OR. &
+ LDIRWM .OR. LDIRWT .OR. &
+ LSUMVM .OR. LSUTVT .OR. LMLSUMVM .OR. LMLSUTVT)THEN
+ CALL READ_UVW(CFILEDIAS(JM),CLUOUTDIAS(JM),CGROUP(1:LEN_TRIM(CGROUP)))
+
+! Janvier 2001 Vecteurs vent horizontal et direction en CV
+ IF(LPBREAD)THEN
+! IF(LPBREAD .OR. (LUMVM .AND. LCV .AND..NOT. LCH) .OR. (LUTVT .AND. LCV &
+! .AND..NOT. LCH))THEN
+ LPBREAD=.FALSE.
+! IF(LUMVM .OR. LUTVT)THEN
+! print *,' VECTEURS VENT HORIZONTAL NON PREVUS EN COUPE VERTICALE'
+! ENDIF
+ IF(ALLOCATED(XU))THEN
+ DEALLOCATE(XU)
+ ENDIF
+ IF(ALLOCATED(XV))THEN
+ DEALLOCATE(XV)
+ ENDIF
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ IF(JLOOP > 1)CALL FRAME
+ EXIT
+ ENDIF
+ ENDIF
+!
+! Lecture des informations autres que pour RS + combinaisons composantes vent
+!
+ IF((.NOT.LRS .AND. .NOT.LRS1 .AND. .NOT.LUMVM .AND. .NOT.LMUMVM .AND. &
+ .NOT.LULM .AND. .NOT.LVTM .AND. .NOT.LULMWM .AND. .NOT.LUTVT .AND.&
+ .NOT.LMUTVT .AND. .NOT.LULT .AND. .NOT.LVTT .AND. .NOT.LULTWT .AND. &
+ .NOT.LDIRWM .AND. .NOT.LDIRWT .AND. &
+ .NOT.LSUMVM .AND. .NOT.LSUTVT .AND. .NOT.LMLSUMVM .AND. .NOT.LMLSUTVT)&
+ .OR. ((LRS .OR. LRS1) .AND. CTYPE /= 'CART'))THEN
+
+ IF(LXYZ .OR. LMSKTOP)THEN
+ IF(XXL == 0. .AND. XXH == 0. .AND. XYL == 0. .AND. XYH == 0. &
+ .AND. XZL == 0. .AND. XZH == 0.)THEN
+ print *,' Definissez une fenetre (en metres) dans XXL= XXH= XYL= XYH= XZL= XZH='
+ print *,' Et rentrez a nouveau votre directive '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ LXYZ=.FALSE. ; LMSKTOP=.FALSE.
+ EXIT
+ ELSE
+ GMASK3D=LMASK3D
+ GMASK3D_XY=LMASK3D_XY
+ GMASK3D_XZ=LMASK3D_XZ
+ GMASK3D_YZ=LMASK3D_YZ
+ LMASK3D=.FALSE.; LMASK3D_XY=.FALSE.; LMASK3D_XZ=.FALSE.
+ LMASK3D_YZ=.FALSE.
+ CALL TRAMASK3D
+ LMASK3D=GMASK3D
+ LMASK3D_XY=GMASK3D_XY
+ LMASK3D_XZ=GMASK3D_XZ
+ LMASK3D_YZ=GMASK3D_YZ
+ ENDIF
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ EXIT
+ ENDIF
+ ENDIF
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),CGROUP)
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ EXIT
+ ENDIF
+ IF(LGROUP)THEN
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),CGROUP)
+ ENDIF
+! print *,'SIZE(XVAR,1,2,3,4,5,6) ',SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3), &
+! SIZE(XVAR,4),SIZE(XVAR,5),SIZE(XVAR,6)
+! print *,' XVAR(1,1,1,1,1,1) ',XVAR(1,1,1,1,1,1)
+! print *,' XVAR(1,1,1,2,1,1) ',XVAR(1,1,1,2,1,1)
+! print *,' XVAR(5,5,5,1,1,1) ',XVAR(5,5,5,1,1,1)
+! print *,' XVAR(5,5,5,2,1,1) ',XVAR(5,5,5,2,1,1)
+ IF(LPBREAD)THEN
+ IF(LFT .OR. LFT1)THEN
+ ALLOCATE(ZBID1(1,1),ZBID2(1))
+ CALL VARFCT(ZBID1,ZBID2,1)
+ IF(JLOOP >1)CALL FRAME
+ DEALLOCATE(ZBID1,ZBID2)
+ ENDIF
+ LPBREAD=.FALSE.
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ EXIT
+ ENDIF
+
+! print *,' LFIC1 NBSIMULT ',LFIC1,NBSIMULT
+
+ IF(.NOT.LFIC1)THEN
+
+! print *,' AV REALLOC_AND_LOAD '
+ CALL REALLOC_AND_LOAD(CGROUP)
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ EXIT
+ ENDIF
+! print *,' AP REALLOC_AND_LOAD '
+
+ ELSE
+
+ NBRECOUV=1
+ NRECOUV(1)=1
+ NRECOUV(2)=SIZE(XTRAJT,1)
+
+ ENDIF
+! print *,' diaprog XSPVAL ',XSPVAL
+ IF(LXYZ)THEN
+! IF(ALLOCATED(LMASK3))THEN
+! WHERE(.NOT.LMASK3)XVAR(:,:,:,1,1,1)=XSPVAL
+! ELSE
+! CALL TRAMASK3D
+ WHERE(.NOT.LMASK3)XVAR(:,:,:,:,1,1)=XSPVAL
+! WHERE(.NOT.LMASK3)XVAR(:,:,:,1,1,1)=XSPVAL
+! ENDIF
+ ENDIF
+
+ ENDIF
+
+! Pour distinguer 1 profil 1D enregistre comme tel (LPV=T et LCV=F) et 1 profil
+! extrait d'une matrice 3D (LPV=T et LCV=t)
+!
+ IF(LPV .OR. LPVT .OR. LPVKT .OR. LPVKT1 .OR. LPXT .AND. (SIZE(XVAR,1)-1 > 0))LCV=.TRUE.
+ IF(LPYT)LCV=.TRUE.
+ IF(LPXT .OR. LPYT .AND. LCH)LCV=.FALSE.
+ IF(NVERBIA > 0)THEN
+ print *,' main LPXT LPYT LCV LCH ',LPXT,LPYT,LCV,LCH
+ ENDIF
+
+ if(nverbia >0)print *,' ****diaprog AV KZTNP'
+ CALL KZTNP(JLOOP)
+ if(nverbia >0)print *,' ****diaprog AP KZTNP LPBREAD ',LPBREAD
+ if(nverbia >0)then
+ print *,' **diaprog AP KZTNP LTK,LPR,LEV,LSV3 ',LTK,LPR,LEV,LSV3
+ endif
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ IF(ALLOCATED(XU))THEN
+ DEALLOCATE(XU)
+ ENDIF
+ IF(ALLOCATED(XV))THEN
+ DEALLOCATE(XV)
+ ENDIF
+ EXIT
+ ENDIF
+
+ IF((LRS .OR. LRS1) .AND. CTYPE == 'CART')THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+
+ IF(ALLOCATED(XVAR) .AND. NOPE(JLOOP) /= 0)THEN
+ IF(NOPE(JLOOP) == 1)THEN
+ !IF(LSV3 .OR. LXYZ)THEN
+ WHERE(XVAR(:,:,:,:,:,:) /= XSPVAL)
+ XVAR(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)+XCONSTANTE(JLOOP)
+ ENDWHERE
+ !ELSE
+ ! XVAR(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)+XCONSTANTE(JLOOP)
+ !ENDIF
+! Janvier 2001
+ IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. LSUMVM .OR. &
+ LSUTVT .OR. LMLSUMVM .OR. LMLSUTVT)THEN
+ IF(ALLOCATED(XU))THEN
+ XU(:,:,:,:,:,:)=XU(:,:,:,:,:,:)+XCONSTANTE(JLOOP)
+ ENDIF
+ ENDIF
+! print *,' XCONSTANTE(JLOOP) ',XCONSTANTE(JLOOP)
+ ELSE IF(NOPE(JLOOP) == 2)THEN
+ !IF(LSV3 .OR. LXYZ)THEN
+ WHERE(XVAR(:,:,:,:,:,:) /= XSPVAL)
+ XVAR(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)*XCONSTANTE(JLOOP)
+ ENDWHERE
+ !ELSE
+ ! XVAR(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)*XCONSTANTE(JLOOP)
+ !ENDIF
+! Janvier 2001
+ IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. LSUMVM .OR. &
+ LSUTVT .OR. LMLSUMVM .OR. LMLSUTVT)THEN
+ IF(ALLOCATED(XU))THEN
+ XU(:,:,:,:,:,:)=XU(:,:,:,:,:,:)*XCONSTANTE(JLOOP)
+ ENDIF
+ ENDIF
+ ELSE IF(NOPE(JLOOP) == 3)THEN
+ WHERE(XVAR(:,:,:,:,:,:) /= XSPVAL .AND. XVAR >0.)
+ XVAR(:,:,:,:,:,:)=LOG(XVAR(:,:,:,:,:,:))
+ ELSEWHERE
+ XVAR(:,:,:,:,:,:)=XSPVAL
+ ENDWHERE
+ ENDIF
+ ENDIF
+! Juillet 2001
+
+ IF(ALLOCATED(XVAR) .AND. NMULTDIV(JLOOP) /= 0)THEN
+ print *,' ++diaprog JLOOP,NMULTDIV(JLOOP),CMULTDIV(JLOOP) ',JLOOP,NMULTDIV(JLOOP),CMULTDIV(JLOOP)
+ IMULTDIV=NMULTDIV(JLOOP)
+ YMULTDIV=' '
+ YMULTDIV=CMULTDIV(JLOOP)
+ YMULTDIV=ADJUSTL(YMULTDIV)
+ CALL LOAD_EXPR(IMULTDIV,YMULTDIV(1:LEN_TRIM(YMULTDIV)))
+ ENDIF
+
+! Juillet 2001
+
+! Difference entre 2 champs (ou somme) . Presence de la chaine _MINUS_ (_PLUS_)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!
+! IF((LMINUS .OR. LPLUS) .AND. JLOOP == 1)THEN
+ IF((LMINUS .OR. LPLUS) .AND. (NUMPM(JLOOP) == 0 .OR. NUMPM(JLOOP) == 3))THEN
+!!!!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!
+! On memorise le 1er champ
+ IF(NBPROCDIA(JLOOP) == 1)THEN
+ NGRIDIAM=NGRIDIA(NPROCDIA(NBPROCDIA(JLOOP),JLOOP))
+ ELSE
+ print *,' ** diaprog Nb de processus > 1 pour une somme ou difference'
+ ENDIF
+ CALL ALLOC2_FORDIACHRO(1)
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ IF(ALLOCATED(XU))THEN
+ DEALLOCATE(XU)
+ ENDIF
+ IF(ALLOCATED(XV))THEN
+ DEALLOCATE(XV)
+ ENDIF
+ CYCLE
+ ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!
+! IF((LMINUS .OR. LPLUS) .AND. JLOOP >= 2)THEN
+ IF((LMINUS .OR. LPLUS) .AND. (NUMPM(JLOOP) == 1 .OR. NUMPM(JLOOP) == 2))THEN
+!!!!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!
+ CALL DIFF_OPER(JLOOP)
+ CALL ALLOC2_FORDIACHRO(3)
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ CTITB3=CTITB3MEM
+ LTITDEF=LTITDEFM
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ IF(ALLOCATED(XU))THEN
+ DEALLOCATE(XU)
+ ENDIF
+ IF(ALLOCATED(XV))THEN
+ DEALLOCATE(XV)
+ ENDIF
+ IF(ALLOCATED(XUMEM))THEN
+ CALL ALLOC2_FORDIACHRO(3)
+ ENDIF
+ if(nverbia > 0)then
+ print *,' ** diaprog LPBREAD=T DEALLOCATE '
+ endif
+ CYCLE
+ ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!
+! IF(JLOOP < NBPM)THEN
+ IF(JLOOP < NBPM .AND.(NUMPM(JLOOP+1) == 1 .OR. NUMPM(JLOOP+1) == 2))THEN
+!!!!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!
+ CALL ALLOC2_FORDIACHRO(1)
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ IF(ALLOCATED(XU))THEN
+ DEALLOCATE(XU)
+ ENDIF
+ IF(ALLOCATED(XV))THEN
+ DEALLOCATE(XV)
+ ENDIF
+ CYCLE
+ ENDIF
+ ENDIF
+
+ if(nverbia >0)print *,' ****diaprog AV OPER_PROCESS'
+ if(nverbia >0)then
+ print *,' **diaprog AV OPER_PROC LTK,LPR,LEV,LSV3 ',LTK,LPR,LEV,LSV3
+ endif
+ CALL OPER_PROCESS(JLOOP,CTYPE)
+ if(nverbia >0)print *,' ****diaprog AP OPER_PROCESS'
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ ENDIF
+ LDIRWIND=.FALSE.
+! Oct 2000
+ LCHXY=.FALSE.
+
+! 15022000
+!! Nov 2001
+ IF(NBPMT > 0 .AND. JLOOP == NSUPERDIA)THEN
+! IF(LMINUS .OR. LPLUS .AND. JLOOP == NSUPERDIA)THEN
+!! Nov 2001
+! IF(LMINUS .OR. LPLUS)THEN
+ CTITB3=CTITB3MEM
+ LTITDEF=LTITDEFM
+ if(nverbia > 0)then
+ print *,' ** diaprog FIN boucle JLOOP == NSUPERDIA CTITB3 LTITDEF NBPMT ',CTITB3,LTITDEF,NBPMT
+ endif
+ ENDIF
+
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ IF(ALLOCATED(XU))THEN
+ DEALLOCATE(XU)
+ ENDIF
+ IF(ALLOCATED(XV))THEN
+ DEALLOCATE(XV)
+ ENDIF
+ IF(ALLOCATED(XUMEM))THEN
+ CALL ALLOC2_FORDIACHRO(3)
+ ENDIF
+ IF(JLOOP == NSUPERDIA)THEN
+ XIDEBCOU=-999.;XJDEBCOU=-999.
+!6666666666666666666666666666666666666666666666
+! NIINF=0; NJINF=0; NISUP=0; NJSUP=0
+!6666666666666666666666666666666666666666666666
+ ENDIF
+
+ ENDIF
+
+ENDDO
+
+CDIRPREC=' '
+CDIRPREC=CDIRCUR
+CDIRPREC=ADJUSTL(CDIRPREC)
+
+ENDDO
+99 CONTINUE
+CAR240(1:80)=CAR80
+CALL CONVLO2UP(CAR240(1:LEN_TRIM(CAR240)),YCAR240)
+CAR240=ADJUSTL(YCAR240)
+if (nverbia >0)then
+ print *,' ****DIAPROG 2 AV EXTRACT_AND_OPEN_FILES '
+ print *,CAR240(1:LEN_TRIM(CAR240))
+endif
+CALL EXTRACT_AND_OPEN_FILES(CAR240(1:LEN_TRIM(CAR240)),YCAR240)
+if (nverbia >0)then
+ print *,' ****DIAPROG 2 AP EXTRACT_AND_OPEN_FILES '
+ print *,YCAR240(1:LEN_TRIM(YCAR240))
+endif
+CAR240(1:LEN(CAR240))=' '
+CAR240=ADJUSTL(YCAR240)
+!READ(*,*)
+!CALL CARESOLV(CAR240(1:LEN_TRIM(CAR240)))
+CLOSE(IDIR)
+if (nverbia >0)then
+ print *,' ****DIAPROG 3 AP EXTRACT_AND_OPEN_FILES '
+endif
+
+STOP
+END PROGRAM DIAPROG
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/diff_oper.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/diff_oper.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3f7768f8949618b80e4d1360af2732a620247681
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/diff_oper.f90
@@ -0,0 +1,1230 @@
+! ######spl
+ MODULE MODI_DIFF_OPER
+! ##############################
+!
+INTERFACE
+!
+SUBROUTINE DIFF_OPER(K)
+INTEGER :: K
+END SUBROUTINE DIFF_OPER
+!
+END INTERFACE
+!
+END MODULE MODI_DIFF_OPER
+! #######################
+ SUBROUTINE DIFF_OPER(K)
+! #######################
+!
+!!**** *DIFF_OPER* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/01/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_ALLOC2_FORDIACHRO
+USE MODD_RESOLVCAR
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODD_FILES_DIACHRO
+USE MODD_TIT
+USE MODD_TYPE_AND_LH
+USE MODD_MEMCV
+USE MODN_NCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+INTEGER :: K
+!
+!* 0.1 Local variables
+! ---------------
+INTEGER :: JLOOPT, ILENT, ILENT2, ILENC, ILENFI, ILENTIM, ILENTIT
+INTEGER :: JA, JME, JME2, IP
+INTEGER :: INDK, INDKM1, INDNN
+INTEGER :: IFAC, INUMPM
+INTEGER,SAVE :: IDIFK, INIV1, INIV2
+CHARACTER(LEN=800),SAVE :: YCAR
+CHARACTER(LEN=100),SAVE :: YTITB3
+CHARACTER(LEN=8) :: YTIM
+REAL :: ZSPVAL
+!
+!------------------------------------------------------------------------------
+IDIFK=1
+INIV1=0; INIV2=0
+IF(LEV .OR. LPR .OR. LTK)THEN
+ print *,' NON NON NON NON NON NON NON NON NON NON NON NON NON NON NON NON NON'
+ print *,' **Diff_oper Operation IMPOSSIBLE . Seules sont autorisees les differences '
+ print *,' entre 2 niveaux de modele (identiques ou non) ou entre 2 altitudes semblables'
+ LPBREAD=.TRUE.
+ RETURN
+ENDIF
+if(nverbia > 0)then
+ print *,' ** Diff_oper NUMPM(MAX(K-1,1)),K-1,K ',NUMPM(MAX(K-1,1)),NUMPM(K-1),NUMPM(K),' K argument ',K
+endif
+IF(LFT .OR. LPVKT .OR. LFT1 .OR. LPVKT1 .AND. LSPVALT)THEN
+ ZSPVAL=XSPVAL
+ XSPVAL=XSPVALT
+ENDIF
+! Initialisation unquement si il n'y a pas eu de + ou - avant
+INUMPM=0
+DO JA=1,K-1
+ IF(NUMPM(JA) == 1 .OR. NUMPM(JA) == 2)THEN
+ INUMPM=INUMPM+1
+ ENDIF
+ENDDO
+IF(INUMPM == 0)THEN
+ YCAR(1:LEN(YCAR))=' '
+ ILENC=0
+ ILENC=ILENC+1
+ELSE
+ ILENC=LEN_TRIM(YCAR)
+ ILENC=ILENC+1
+ YCAR(ILENC:ILENC+2)=' , '
+ ILENC=ILENC+3
+ENDIF
+if(nverbia > 0)then
+ print *,' **Diff_oper ILENC entree ',ILENC
+endif
+YTIM(1:LEN(YTIM))=' '
+IF(NUMFILECUR2 /= NUMFILECUR)THEN
+ DO JA=1,NBFILES
+ IF(NUMFILES(JA) == NUMFILECUR)THEN
+ JME=JA
+ ENDIF
+ IF(NUMFILES(JA) == NUMFILECUR2)THEN
+ JME2=JA
+ ENDIF
+ ENDDO
+ENDIF
+!
+! Traitement d'un seul temps
+!
+IF(NBNDIA(K) /= 1 .OR. NBNDIA(K-1) /= 1 )THEN
+ LPBREAD=.TRUE.
+ print *,' NB DE MASQUES (ou STATIONS) DEMANDES > 1 . PAS DE TRACE '
+ IF(LFT .OR. LPVKT .OR. LFT1 .OR. LPVKT1 .AND. LSPVALT)THEN
+ XSPVAL=ZSPVAL
+ ENDIF
+ RETURN
+ENDIF
+
+INDK=NNDIA(1,K); INDKM1=NNDIA(1,K-1)
+
+!Je mets directement 1 pour le 1er indice de xlvlzdia puisque= nblvlzdia(k,indk)
+ if(nblvlzdia(k) == 1 .and. nblvlzdia(k-1) == 1 .AND. &
+ xlvlzdia(1,k) /= xlvlzdia(1,k-1) )then
+ print *,' NON NON NON NON NON NON NON NON NON NON NON NON NON NON NON NON NON'
+ print *,' **Diff_oper Operation IMPOSSIBLE . Seules sont autorisees les differences '
+ print *,' entre 2 niveaux de modele (identiques ou non) ou entre 2 altitudes semblables'
+ print *,' **Altitudes demandees : xlvlzdia(1,k-1),xlvlzdia(1,k) ',xlvlzdia(1,k-1),xlvlzdia(1,k)
+ LPBREAD=.TRUE.
+ IF(LFT .OR. LPVKT .OR. LFT1 .OR. LPVKT1 .AND. LSPVALT)THEN
+ XSPVAL=ZSPVAL
+ ENDIF
+ RETURN
+ endif
+
+IP=NPROCDIA(NBPROCDIA(K),K)
+
+IF(NGRIDIA(IP) /= NGRIDIAM)THEN
+ IF(CTYPE == 'MASK')THEN
+ SELECT CASE(NGRIDIAM)
+ CASE(1,2,3,5)
+ SELECT CASE(NGRIDIA(IP))
+ CASE(1,2,3,5)
+ print *,' *** diff_oper Type MASK NGRIDIAM, NGRIDIA(IP), pas d interpolation ',NGRIDIAM,NGRIDIA(IP)
+ CASE(4,6,7)
+ print *,' *** diff_oper Type MASK NGRIDIAM, NGRIDIA(IP),&
+& interpolation en K sur la grille du 1er processus traite (NGRIDIAM) ',NGRIDIAM,NGRIDIA(IP)
+ CALL INTERP_GRIDS(K)
+ END SELECT
+ CASE(4,6,7)
+ SELECT CASE(NGRIDIA(IP))
+ CASE(1,2,3,5)
+ print *,' *** diff_oper Type MASK NGRIDIAM, NGRIDIA(IP), interpolation en K&
+& sur la grille du 1er processus traite (NGRIDIAM) ',NGRIDIAM,NGRIDIA(IP)
+ CALL INTERP_GRIDS(K)
+ CASE(4,6,7)
+ print *,' *** diff_oper Type MASK NGRIDIAM, NGRIDIA(IP), pas d interpolation ',NGRIDIAM,NGRIDIA(IP)
+ END SELECT
+ END SELECT
+ ELSE
+ print *,' *** diff_oper NGRIDIAM, NGRIDIA(IP), interpolation ',NGRIDIAM,NGRIDIA(IP)
+ CALL INTERP_GRIDS(K)
+ ENDIF
+ENDIF
+
+if(nverbia >0)then
+print *,' DIFF_OPER INDK INDKM1 ',INDK,INDKM1
+print *,' DIFF_OPER NBTIMEDIA(K,INDK) NBTIMEDIA(K-1,INDKM1) ', &
+NBTIMEDIA(K,INDK),NBTIMEDIA(K-1,INDKM1)
+endif
+
+!******************************** 1 seul temps
+
+IF(NBTIMEDIA(K,INDK) == 1 .AND. NBTIMEDIA(K-1,INDKM1) == 1)THEN
+! print *,' DIFF_OPER XVAR ',XVAR
+! print *,' DIFF_OPER XVAR2 ',XVAR2
+
+ IF(NBPROCDIA(K) /= 1 .OR. NBPROCDIA(K-1) /= 1 )THEN !++++++++++
+ LPBREAD=.TRUE.
+ print *,' NB DE PROCESSUS DEMANDES > 1 . PAS DE TRACE '
+ IF(LFT .OR. LPVKT .OR. LFT1 .OR. LPVKT1 .AND. LSPVALT)THEN
+ XSPVAL=ZSPVAL
+ ENDIF
+ RETURN
+
+ ELSE !++++++++++
+!-----------------------------------------------------------------------
+! IF(K <= 2)THEN
+ IF(NUMPM(K-1) == 0 .OR. NUMPM(MAX(K-1,1)) == 3)THEN
+ if(nverbia > 0)then
+ print *,' diff_oper1 K NUMPM(K-1) ',K,NUMPM(K-1)
+ endif
+ if(nblvlkdia(k,indk) == 1 .and. nblvlkdia(k-1,indk) == 1)then
+ print *,' diff_oper1 Niveaux en K de part et d autre de MINUS '
+ print *,' K1= ',NLVLKDIA(1,K-1,INDK),' K2= ',NLVLKDIA(1,K,INDK)
+! INIV1=le 1er dans la directive <-> K-1 , INIV2=le 2e=courant <-> K
+! Janv 2001
+ IF(CTYPE == 'CART' .OR. CTYPE == 'MASK')THEN
+ INIV1=NLVLKDIA(1,K-1,INDK)-NKL+1
+ INIV2=NLVLKDIA(1,K,INDK)-NKL+1
+ ELSE
+! Janv 2001
+ INIV1=NLVLKDIA(1,K-1,INDK)
+ INIV2=NLVLKDIA(1,K,INDK)
+! Janv 2001
+ ENDIF
+! Janv 2001
+ IDIFK=2
+ endif
+
+ IF(LMUMVM .OR. LMUTVT .OR. LUMVM .OR. LUTVT .OR. &
+ LSUMVM .OR. LSUTVT .OR. LMLSUMVM .OR. LMLSUTVT)THEN
+ CGROUPS(K-1)=ADJUSTL(CGROUPS(K-1))
+ ILENTIT=LEN_TRIM(CGROUPS(K-1))
+ YCAR(ILENC:ILENC+ILENTIT-1)=CGROUPS(K-1)(1:ILENTIT)
+ ELSE
+ CTITRE2(NPROCDIA(1,K-1))=ADJUSTL(CTITRE2(NPROCDIA(1,K-1)))
+ ILENTIT=LEN_TRIM(CTITRE2(NPROCDIA(1,K-1)))
+ YCAR(ILENC:ILENC+ILENTIT-1)=CTITRE2(NPROCDIA(1,K-1))(1:ILENTIT)
+ ENDIF
+ YCAR=ADJUSTL(YCAR)
+ ILENC=LEN_TRIM(YCAR)
+ ILENC=ILENC+2
+ YCAR(ILENC:ILENC)='('
+ ILENC=ILENC+1
+ IF(NUMFILECUR2 /= NUMFILECUR)THEN
+ CFILEDIAS(JME2)=ADJUSTL(CFILEDIAS(JME2))
+ ILENFI=LEN_TRIM(CFILEDIAS(JME2))
+ YCAR(ILENC:ILENC+ILENFI-1)=CFILEDIAS(JME2)(1:ILENFI)
+ ILENC=ILENC+ILENFI
+ YCAR(ILENC:ILENC+1)=')('
+ ILENC=ILENC+2
+ ENDIF
+
+ IF(IDIFK == 2 .AND. INIV1 /= INIV2)THEN
+ YCAR(ILENC:ILENC+1)='K='
+ ILENC=ILENC+2
+ WRITE(YCAR(ILENC:ILENC+1),'(I2)')INIV1
+ ILENC=ILENC+2
+ YCAR(ILENC:ILENC+1)=')('
+ ILENC=ILENC+2
+ ENDIF
+
+ IF(CTYPE == 'DRST' .OR. CTYPE == 'RSPL' .OR. CTYPE == 'RAPL')THEN
+ WRITE(YTIM,'(F8.0)')XTRAJT2(NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),INDKM1)
+ ELSE
+ WRITE(YTIM,'(F8.0)')XTRAJT2(NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1)
+ ENDIF
+ YTIM=ADJUSTL(YTIM)
+! print *,' YTIM ',YTIM
+ ILENTIM=LEN_TRIM(YTIM)
+ YCAR(ILENC:ILENC+ILENTIM-1)=YTIM(1:ILENTIM)
+ YTIM(1:LEN(YTIM))=' '
+ ILENC=ILENC+ILENTIM
+ IF(LMINUS)THEN
+ YCAR(ILENC:ILENC+3)=') - '
+ ELSE IF(LPLUS)THEN
+ YCAR(ILENC:ILENC+3)=') + '
+ ENDIF
+ ILENC=ILENC+4
+
+ ELSE
+
+ YCAR=ADJUSTL(CTITB3)
+ ILENC=LEN_TRIM(YCAR)+1
+ IF(LMINUS)THEN
+ YCAR(ILENC:ILENC+2)=' - '
+ ELSE IF(LPLUS)THEN
+ YCAR(ILENC:ILENC+2)=' + '
+ ENDIF
+ ILENC=ILENC+3
+
+ ENDIF
+!-----------------------------------------------------------------------
+ IF(LMUMVM .OR. LMUTVT .OR. LUMVM .OR. LUTVT .OR. &
+ LSUMVM .OR. LSUTVT .OR. LMLSUMVM .OR. LMLSUTVT)THEN
+ ILENTIT=LEN_TRIM(CGROUPS(K))
+ YCAR(ILENC:ILENC+ILENTIT-1)=CGROUPS(K)(1:ILENTIT)
+ ELSE
+ CTITRE(NPROCDIA(1,K))=ADJUSTL(CTITRE(NPROCDIA(1,K)))
+ ILENTIT=LEN_TRIM(CTITRE(NPROCDIA(1,K)))
+ YCAR(ILENC:ILENC+ILENTIT-1)=CTITRE(NPROCDIA(1,K))(1:ILENTIT)
+ ENDIF
+ YCAR=ADJUSTL(YCAR)
+ ILENC=LEN_TRIM(YCAR)
+ ILENC=ILENC+2
+ YCAR(ILENC:ILENC)='('
+ ILENC=ILENC+1
+! print *,' AV 2eme IF'
+ IF(NUMFILECUR2 /= NUMFILECUR)THEN
+ CFILEDIAS(JME)=ADJUSTL(CFILEDIAS(JME))
+ ILENFI=LEN_TRIM(CFILEDIAS(JME))
+ YCAR(ILENC:ILENC+ILENFI-1)=CFILEDIAS(JME)(1:ILENFI)
+ ILENC=ILENC+ILENFI
+ YCAR(ILENC:ILENC+1)=')('
+ ILENC=ILENC+2
+ ENDIF
+
+ IF(IDIFK == 2 .AND. INIV1 /= INIV2)THEN
+ YCAR(ILENC:ILENC+1)='K='
+ ILENC=ILENC+2
+ WRITE(YCAR(ILENC:ILENC+1),'(I2)')INIV2
+ ILENC=ILENC+2
+ YCAR(ILENC:ILENC+1)=')('
+ ILENC=ILENC+2
+ ENDIF
+
+ IF(CTYPE == 'DRST' .OR. CTYPE == 'RSPL' .OR. CTYPE == 'RAPL')THEN
+ WRITE(YTIM,'(F8.0)')XTRAJT(NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),INDK)
+ ELSE
+ WRITE(YTIM,'(F8.0)')XTRAJT(NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1)
+ ENDIF
+ YTIM=ADJUSTL(YTIM)
+! print *,' YTIM ',YTIM,' ILENC ',ILENC
+ ILENTIM=LEN_TRIM(YTIM)
+ YCAR(ILENC:ILENC+ILENTIM-1)=YTIM(1:ILENTIM)
+ print *,' YCAR ',YCAR(1:LEN_TRIM(YCAR))
+! YTIM(1:LEN(YTIM))=' '
+ ILENC=ILENC+ILENTIM
+! print *,' ILENC ',ILENC
+ YCAR(ILENC:ILENC)=')'
+! print *,' YCAR ',YCAR
+
+! IF(K <= 2)THEN
+ IF(NUMPM(K-1) == 0 .OR. NUMPM(MAX(K-1,1)) == 3)THEN
+ if(nverbia > 0)then
+ print *,' diff_oper1 K NUMPM(K-1) ',K,NUMPM(K-1)
+ endif
+ if(nblvlkdia(k,indk) == 1 .and. nblvlkdia(k-1,indk) == 1)then
+ print *,' diff_oper1-2 Niveaux en K de part et d autre de MINUS '
+ print *,' K1= ',NLVLKDIA(1,K-1,INDK),' K2= ',NLVLKDIA(1,K,INDK)
+! Janv 2001
+ IF(CTYPE == 'CART' .OR. CTYPE == 'MASK')THEN
+ INIV1=NLVLKDIA(1,K-1,INDK)-NKL+1
+ INIV2=NLVLKDIA(1,K,INDK)-NKL+1
+ ELSE
+! Janv 2001
+ INIV1=NLVLKDIA(1,K-1,INDK)
+ INIV2=NLVLKDIA(1,K,INDK)
+! Janv 2001
+ ENDIF
+! Janv 2001
+ IDIFK=2
+ endif
+ LTITDEF=.FALSE.
+! YTITB3(1:LEN(YTITB3))=' '
+! YTITB3=ADJUSTL(CTITB3)
+ ENDIF
+!!! 1/3/04
+ IF(CTITB3 /= 'DEFAULT')THEN
+ ELSE
+!!! 1/3/04
+ CTITB3=ADJUSTL(YCAR(1:100))
+ CTITB3=ADJUSTL(CTITB3)
+!!! 1/3/04
+ ENDIF
+!!! 1/3/04
+ print *,' CTITB3 ',CTITB3
+ IF(LMINUS)THEN
+ IFAC=-1
+ ELSE IF(LPLUS)THEN
+ IFAC=1
+ ENDIF
+
+ IF(IDIFK == 2)THEN
+!!Mai 2003
+ WHERE((XVAR(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),INDK, &
+! WHERE((XVAR(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K)) == XSPVAL) .OR. &
+ (XVAR2(:,:,INIV1,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),INDKM1, &
+! (XVAR2(:,:,INIV1,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1, &
+ NPROCDIA(NBPROCDIA(K-1),K-1)) == XSPVAL))
+ XVAR(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),INDK, &
+! XVAR(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))= XSPVAL
+ ELSEWHERE
+ XVAR(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),INDK, &
+! XVAR(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))= &
+ XVAR2(:,:,INIV1,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),INDKM1, &
+! XVAR2(:,:,INIV1,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1, &
+ NPROCDIA(NBPROCDIA(K-1),K-1))+ &
+ IFAC * XVAR(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),INDK, &
+! IFAC * XVAR(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))
+ END WHERE
+ ELSE
+ WHERE((XVAR(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),INDK, &
+! WHERE((XVAR(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K)) == XSPVAL) .OR. &
+ (XVAR2(:,:,:,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),INDKM1, &
+! (XVAR2(:,:,:,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1, &
+ NPROCDIA(NBPROCDIA(K-1),K-1)) == XSPVAL))
+ XVAR(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),INDK, &
+! XVAR(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))= XSPVAL
+ ELSEWHERE
+ XVAR(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),INDK, &
+! XVAR(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))= &
+ XVAR2(:,:,:,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),INDKM1, &
+! XVAR2(:,:,:,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1, &
+ NPROCDIA(NBPROCDIA(K-1),K-1))+ &
+ IFAC * XVAR(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),INDK, &
+! IFAC * XVAR(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+!!Mai 2003
+ NPROCDIA(NBPROCDIA(K),K))
+ END WHERE
+ ENDIF
+
+ IF(ALLOCATED(XUMEM))THEN
+ IF(IDIFK == 2)THEN
+ WHERE((XU(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K)) == XSPVAL) .OR. &
+ (XUMEM(:,:,INIV1,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1, &
+ NPROCDIA(NBPROCDIA(K-1),K-1)) == XSPVAL))
+ XU(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))= XSPVAL
+ ELSEWHERE
+ XU(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))= &
+ XUMEM(:,:,INIV1,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1, &
+ NPROCDIA(NBPROCDIA(K-1),K-1))+ &
+ IFAC * XU(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))
+ END WHERE
+ ELSE
+ WHERE((XU(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K)) == XSPVAL) .OR. &
+ (XUMEM(:,:,:,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1, &
+ NPROCDIA(NBPROCDIA(K-1),K-1)) == XSPVAL))
+ XU(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))= XSPVAL
+ ELSEWHERE
+ XU(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))= &
+ XUMEM(:,:,:,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1, &
+ NPROCDIA(NBPROCDIA(K-1),K-1))+ &
+ IFAC * XU(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))
+ END WHERE
+ ENDIF
+ ENDIF
+ IF(ALLOCATED(XVMEM))THEN
+ IF(IDIFK == 2)THEN
+ WHERE((XV(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K)) == XSPVAL) .OR. &
+ (XVMEM(:,:,INIV1,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1, &
+ NPROCDIA(NBPROCDIA(K-1),K-1)) == XSPVAL))
+ XV(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))= XSPVAL
+ ELSEWHERE
+ XV(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))= &
+ XVMEM(:,:,INIV1,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1, &
+ NPROCDIA(NBPROCDIA(K-1),K-1))+ &
+ IFAC * XV(:,:,INIV2,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))
+ END WHERE
+ ELSE
+ WHERE((XV(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K)) == XSPVAL) .OR. &
+ (XVMEM(:,:,:,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1, &
+ NPROCDIA(NBPROCDIA(K-1),K-1)) == XSPVAL))
+ XV(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))= XSPVAL
+ ELSEWHERE
+ XV(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))= &
+ XVMEM(:,:,:,NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1, &
+ NPROCDIA(NBPROCDIA(K-1),K-1))+ &
+ IFAC * XV(:,:,:,NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1, &
+ NPROCDIA(NBPROCDIA(K),K))
+ END WHERE
+ ENDIF
+ ENDIF
+ ENDIF !++++++++++
+
+!******************************** plusieurs temps
+
+ELSE
+
+! Expression du temps en sequentiel SSSSSSSSSSSS
+ IF(.NOT.LTINCRDIA(K,INDK))THEN
+
+ IF(NBTIMEDIA(K,INDK) == NBTIMEDIA(K-1,INDKM1))THEN
+! Intervalle de temps de meme longueur pour les 2 champs OK
+
+ IF(NBPROCDIA(K) /= 1 .OR. NBPROCDIA(K-1) /= 1 )THEN
+ LPBREAD=.TRUE.
+ print *,' NB DE PROCESSUS DEMANDES > 1 . PAS DE TRACE '
+ IF(LFT .OR. LPVKT .OR. LFT1 .OR. LPVKT1 .AND. LSPVALT)THEN
+ XSPVAL=ZSPVAL
+ ENDIF
+ RETURN
+ ELSE
+! print *,' PASSAGE ICI'
+ IF(LMUMVM .OR. LMUTVT .OR. LUMVM .OR. LUTVT .OR. &
+ LSUMVM .OR. LSUTVT .OR. LMLSUMVM .OR. LMLSUTVT)THEN
+ CGROUPS(K-1)=ADJUSTL(CGROUPS(K-1))
+ ILENTIT=LEN_TRIM(CGROUPS(K-1))
+ YCAR(ILENC:ILENC+ILENTIT-1)=CGROUPS(K-1)(1:ILENTIT)
+ ELSE
+ CTITRE2(NPROCDIA(1,K-1))=ADJUSTL(CTITRE2(NPROCDIA(1,K-1)))
+ ILENTIT=LEN_TRIM(CTITRE2(NPROCDIA(1,K-1)))
+ YCAR(ILENC:ILENC+ILENTIT-1)=CTITRE2(NPROCDIA(1,K-1))(1:ILENTIT)
+ ENDIF
+ YCAR=ADJUSTL(YCAR)
+ ILENC=LEN_TRIM(YCAR)
+ ILENC=ILENC+2
+ YCAR(ILENC:ILENC)='('
+ ILENC=ILENC+1
+ IF(NUMFILECUR2 /= NUMFILECUR)THEN
+ CFILEDIAS(JME2)=ADJUSTL(CFILEDIAS(JME2))
+ ILENFI=LEN_TRIM(CFILEDIAS(JME2))
+ YCAR(ILENC:ILENC+ILENFI-1)=CFILEDIAS(JME2)(1:ILENFI)
+ ILENC=ILENC+ILENFI
+ YCAR(ILENC:ILENC+1)=')('
+ ILENC=ILENC+2
+ ENDIF
+
+ IF(IDIFK == 2 .AND. INIV1 /= INIV2)THEN
+ YCAR(ILENC:ILENC+1)='K='
+ ILENC=ILENC+2
+ WRITE(YCAR(ILENC:ILENC+1),'(I2)')INIV1
+ ILENC=ILENC+2
+ YCAR(ILENC:ILENC+1)=')('
+ ILENC=ILENC+2
+ ENDIF
+
+! Ecriture de la premiere serie de temps
+!-----------------------------------------------------------------------
+! IF(K <=2)THEN
+ IF(NUMPM(K-1) == 0 .OR. NUMPM(MAX(K-1,1)) == 3)THEN
+ if(nverbia > 0)then
+ print *,' diff_oper2 K NUMPM(K-1) ',K,NUMPM(K-1)
+ endif
+ if(nblvlkdia(k,indk) == 1 .and. nblvlkdia(k-1,indk) == 1)then
+ print *,' diff_oper2 Niveaux en K de part et d autre de MINUS '
+ print *,' K1= ',NLVLKDIA(1,K-1,INDK),' K2= ',NLVLKDIA(1,K,INDK)
+! Janv 2001
+ IF(CTYPE == 'CART' .OR. CTYPE == 'MASK')THEN
+ INIV1=NLVLKDIA(1,K-1,INDK)-NKL+1
+ INIV2=NLVLKDIA(1,K,INDK)-NKL+1
+ ELSE
+! Janv 2001
+ INIV1=NLVLKDIA(1,K-1,INDK)
+ INIV2=NLVLKDIA(1,K,INDK)
+! Janv 2001
+ ENDIF
+! Janv 2001
+ IDIFK=2
+ endif
+
+ IF(CTYPE == 'DRST' .OR. CTYPE == 'RSPL' .OR. CTYPE == 'RAPL')THEN
+ WRITE(YTIM,'(F8.0)')XTRAJT2(NTIMEDIA(1,K-1,INDKM1),INDKM1)
+ ELSE
+ WRITE(YTIM,'(F8.0)')XTRAJT2(NTIMEDIA(1,K-1,INDKM1),1)
+ ENDIF
+ YTIM=ADJUSTL(YTIM)
+ ILENTIM=LEN_TRIM(YTIM)
+ YCAR(ILENC:ILENC+ILENTIM-1)=YTIM(1:ILENTIM)
+ YTIM(1:LEN(YTIM))=' '
+ ILENC=ILENC+ILENTIM
+ IF(CTYPE == 'DRST' .OR. CTYPE == 'RSPL' .OR. CTYPE == 'RAPL')THEN
+ INDNN=INDKM1
+ ELSE
+ INDNN=1
+ ENDIF
+! IF(XTRAJT2(NTIMEDIA(1,K-1,INDKM1),1) /= XTRAJT2(NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),1))THEN
+ IF(XTRAJT2(NTIMEDIA(1,K-1,INDKM1),INDNN) /= XTRAJT2(NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),INDNN))THEN
+ YCAR(ILENC:ILENC+2)=' - '
+ ILENC=ILENC+3
+ WRITE(YTIM,'(F8.0)')XTRAJT2(NTIMEDIA(NBTIMEDIA(K-1,INDKM1),K-1,INDKM1),INDNN)
+ YTIM=ADJUSTL(YTIM)
+ ILENTIM=LEN_TRIM(YTIM)
+ YCAR(ILENC:ILENC+ILENTIM-1)=YTIM(1:ILENTIM)
+ YTIM(1:LEN(YTIM))=' '
+ ILENC=ILENC+ILENTIM
+
+ ELSE
+
+ ILENC=ILENC+1
+ ENDIF
+ IF(LMINUS)THEN
+ YCAR(ILENC:ILENC+3)=') - '
+ ELSE IF(LPLUS)THEN
+ YCAR(ILENC:ILENC+3)=') + '
+ ENDIF
+ ILENC=ILENC+4
+
+ ELSE
+
+ YCAR=ADJUSTL(CTITB3)
+ ILENC=LEN_TRIM(YCAR)+1
+ IF(LMINUS)THEN
+ YCAR(ILENC:ILENC+2)=' - '
+ ELSE IF(LPLUS)THEN
+ YCAR(ILENC:ILENC+2)=' + '
+ ENDIF
+ ILENC=ILENC+3
+
+ ENDIF
+!-----------------------------------------------------------------------
+! FIN Ecriture de la premiere serie de temps
+ IF(LMUMVM .OR. LMUTVT .OR. LUMVM .OR. LUTVT .OR. &
+ LSUMVM .OR. LSUTVT .OR. LMLSUMVM .OR. LMLSUTVT)THEN
+ ILENTIT=LEN_TRIM(CGROUPS(K))
+ YCAR(ILENC:ILENC+ILENTIT-1)=CGROUPS(K)(1:ILENTIT)
+ ELSE
+ CTITRE(NPROCDIA(1,K))=ADJUSTL(CTITRE(NPROCDIA(1,K)))
+ ILENTIT=LEN_TRIM(CTITRE(NPROCDIA(1,K)))
+ YCAR(ILENC:ILENC+ILENTIT-1)=CTITRE(NPROCDIA(1,K))(1:ILENTIT)
+ ENDIF
+ YCAR=ADJUSTL(YCAR)
+ ILENC=LEN_TRIM(YCAR)
+ ILENC=ILENC+2
+ YCAR(ILENC:ILENC)='('
+ ILENC=ILENC+1
+ IF(NUMFILECUR2 /= NUMFILECUR)THEN
+ CFILEDIAS(JME)=ADJUSTL(CFILEDIAS(JME))
+ ILENFI=LEN_TRIM(CFILEDIAS(JME))
+ YCAR(ILENC:ILENC+ILENFI-1)=CFILEDIAS(JME)(1:ILENFI)
+ ILENC=ILENC+ILENFI
+ YCAR(ILENC:ILENC+1)=')('
+ ILENC=ILENC+2
+ ENDIF
+
+ IF(IDIFK == 2 .AND. INIV1 /= INIV2)THEN
+ YCAR(ILENC:ILENC+1)='K='
+ ILENC=ILENC+2
+ WRITE(YCAR(ILENC:ILENC+1),'(I2)')INIV2
+ ILENC=ILENC+2
+ YCAR(ILENC:ILENC+1)=')('
+ ILENC=ILENC+2
+ ENDIF
+
+! Ecriture de la deuxieme serie de temps
+ IF(CTYPE == 'DRST' .OR. CTYPE == 'RSPL' .OR. CTYPE == 'RAPL')THEN
+ WRITE(YTIM,'(F8.0)')XTRAJT(NTIMEDIA(1,K,INDK),INDK)
+ ELSE
+ WRITE(YTIM,'(F8.0)')XTRAJT(NTIMEDIA(1,K,INDK),1)
+ ENDIF
+ YTIM=ADJUSTL(YTIM)
+ ILENTIM=LEN_TRIM(YTIM)
+ YCAR(ILENC:ILENC+ILENTIM-1)=YTIM(1:ILENTIM)
+ YTIM(1:LEN(YTIM))=' '
+ ILENC=ILENC+ILENTIM
+
+ IF(CTYPE == 'DRST' .OR. CTYPE == 'RSPL' .OR. CTYPE == 'RAPL')THEN
+ INDNN=INDK
+ ELSE
+ INDNN=1
+ ENDIF
+! IF(XTRAJT(NTIMEDIA(1,K,INDK),1) /= XTRAJT(NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1))THEN
+ IF(XTRAJT(NTIMEDIA(1,K,INDK),INDNN) /= XTRAJT(NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),INDNN))THEN
+ YCAR(ILENC:ILENC+2)=' - '
+ ILENC=ILENC+3
+ WRITE(YTIM,'(F8.0)')XTRAJT(NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),INDNN)
+! WRITE(YTIM,'(F8.0)')XTRAJT(NTIMEDIA(NBTIMEDIA(K,INDK),K,INDK),1)
+ YTIM=ADJUSTL(YTIM)
+ ILENTIM=LEN_TRIM(YTIM)
+ YCAR(ILENC:ILENC+ILENTIM-1)=YTIM(1:ILENTIM)
+ YTIM(1:LEN(YTIM))=' '
+ ILENC=ILENC+ILENTIM
+
+ ELSE
+
+ ILENC=ILENC+1
+ ENDIF
+ YCAR(ILENC:ILENC)=')'
+
+! IF(K <= 2)THEN
+ IF(NUMPM(K-1) == 0 .OR. NUMPM(MAX(K-1,1)) == 3)THEN
+ if(nverbia > 0)then
+ print *,' diff_oper2 K NUMPM(K-1) ',K,NUMPM(K-1)
+ endif
+ if(nblvlkdia(k,indk) == 1 .and. nblvlkdia(k-1,indk) == 1)then
+ print *,' diff_oper2-2 Niveaux en K de part et d autre de MINUS '
+ print *,' K1= ',NLVLKDIA(1,K-1,INDK),' K2= ',NLVLKDIA(1,K,INDK)
+! Janv 2001
+ IF(CTYPE == 'CART' .OR. CTYPE == 'MASK')THEN
+ INIV1=NLVLKDIA(1,K-1,INDK)-NKL+1
+ INIV2=NLVLKDIA(1,K,INDK)-NKL+1
+ ELSE
+! Janv 2001
+ INIV1=NLVLKDIA(1,K-1,INDK)
+ INIV2=NLVLKDIA(1,K,INDK)
+! Janv 2001
+ ENDIF
+! Janv 2001
+ IDIFK=2
+ endif
+ LTITDEF=.FALSE.
+! YTITB3(1:LEN(YTITB3))=' '
+! YTITB3=ADJUSTL(CTITB3)
+ ENDIF
+
+!!! 1/3/04
+ IF(CTITB3 /= 'DEFAULT')THEN
+ ELSE
+!!! 1/3/04
+ CTITB3=ADJUSTL(YCAR(1:100))
+ CTITB3=ADJUSTL(CTITB3)
+!!! 1/3/04
+ ENDIF
+!!! 1/3/04
+ print *,' CTITB3 ',CTITB3
+ DO JLOOPT=1,NBTIMEDIA(K,INDK)
+ IF(LMINUS)THEN
+ IFAC=-1
+ ELSE IF(LPLUS)THEN
+ IFAC=1
+ ENDIF
+ IF(IDIFK == 2)THEN
+! Mai 2003
+ WHERE((XVAR(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),INDK,NPROCDIA(1,K))==XSPVAL)&
+! WHERE((XVAR(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))==XSPVAL)&
+ .OR. (XVAR2(:,:,INIV1,NTIMEDIA(JLOOPT,K-1,INDKM1),INDKM1, &
+! .OR. (XVAR2(:,:,INIV1,NTIMEDIA(JLOOPT,K-1,INDKM1),1, &
+ NPROCDIA(1,K-1))==XSPVAL))
+ XVAR(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),INDK,NPROCDIA(1,K))=XSPVAL
+! XVAR(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))=XSPVAL
+ ELSEWHERE
+ XVAR(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),INDK,NPROCDIA(1,K)) = &
+! XVAR(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K)) = &
+ XVAR2(:,:,INIV1,NTIMEDIA(JLOOPT,K-1,INDKM1),INDKM1,NPROCDIA(1,K-1)) + &
+! XVAR2(:,:,INIV1,NTIMEDIA(JLOOPT,K-1,INDKM1),1,NPROCDIA(1,K-1)) + &
+ IFAC * XVAR(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),INDK,NPROCDIA(1,K))
+! IFAC * XVAR(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))
+ END WHERE
+ ELSE
+ WHERE((XVAR(:,:,:,NTIMEDIA(JLOOPT,K,INDK),INDK,NPROCDIA(1,K))==XSPVAL)&
+! WHERE((XVAR(:,:,:,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))==XSPVAL)&
+ .OR. (XVAR2(:,:,:,NTIMEDIA(JLOOPT,K-1,INDKM1),INDKM1, &
+! .OR. (XVAR2(:,:,:,NTIMEDIA(JLOOPT,K-1,INDKM1),1, &
+ NPROCDIA(1,K-1))==XSPVAL))
+ XVAR(:,:,:,NTIMEDIA(JLOOPT,K,INDK),INDK,NPROCDIA(1,K))=XSPVAL
+! XVAR(:,:,:,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))=XSPVAL
+ ELSEWHERE
+ XVAR(:,:,:,NTIMEDIA(JLOOPT,K,INDK),INDK,NPROCDIA(1,K)) = &
+! XVAR(:,:,:,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K)) = &
+ XVAR2(:,:,:,NTIMEDIA(JLOOPT,K-1,INDKM1),INDKM1,NPROCDIA(1,K-1)) + &
+! XVAR2(:,:,:,NTIMEDIA(JLOOPT,K-1,INDKM1),1,NPROCDIA(1,K-1)) + &
+ IFAC * XVAR(:,:,:,NTIMEDIA(JLOOPT,K,INDK),INDK,NPROCDIA(1,K))
+! IFAC * XVAR(:,:,:,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))
+ END WHERE
+ ENDIF
+ IF(ALLOCATED(XUMEM))THEN
+ IF(IDIFK == 2)THEN
+ WHERE((XU(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))==XSPVAL)&
+ .OR. (XUMEM(:,:,INIV1,NTIMEDIA(JLOOPT,K-1,INDKM1),1, &
+ NPROCDIA(1,K-1))==XSPVAL))
+ XU(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))=XSPVAL
+ ELSEWHERE
+ XU(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K)) = &
+ XUMEM(:,:,INIV1,NTIMEDIA(JLOOPT,K-1,INDKM1),1,NPROCDIA(1,K-1)) + &
+ IFAC * XU(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))
+ END WHERE
+ ELSE
+ WHERE((XU(:,:,:,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))==XSPVAL)&
+ .OR. (XUMEM(:,:,:,NTIMEDIA(JLOOPT,K-1,INDKM1),1, &
+ NPROCDIA(1,K-1))==XSPVAL))
+ XU(:,:,:,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))=XSPVAL
+ ELSEWHERE
+ XU(:,:,:,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K)) = &
+ XUMEM(:,:,:,NTIMEDIA(JLOOPT,K-1,INDKM1),1,NPROCDIA(1,K-1)) + &
+ IFAC * XU(:,:,:,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))
+ END WHERE
+ ENDIF
+ ENDIF
+ IF(ALLOCATED(XVMEM))THEN
+ IF(IDIFK == 2)THEN
+ WHERE((XV(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))==XSPVAL)&
+ .OR. (XVMEM(:,:,INIV1,NTIMEDIA(JLOOPT,K-1,INDKM1),1, &
+ NPROCDIA(1,K-1))==XSPVAL))
+ XV(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))=XSPVAL
+ ELSEWHERE
+ XV(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K)) = &
+ XVMEM(:,:,INIV1,NTIMEDIA(JLOOPT,K-1,INDKM1),1,NPROCDIA(1,K-1)) + &
+ IFAC * XV(:,:,INIV2,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))
+ END WHERE
+ ELSE
+ WHERE((XV(:,:,:,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))==XSPVAL)&
+ .OR. (XVMEM(:,:,:,NTIMEDIA(JLOOPT,K-1,INDKM1),1, &
+ NPROCDIA(1,K-1))==XSPVAL))
+ XV(:,:,:,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))=XSPVAL
+ ELSEWHERE
+ XV(:,:,:,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K)) = &
+ XVMEM(:,:,:,NTIMEDIA(JLOOPT,K-1,INDKM1),1,NPROCDIA(1,K-1)) + &
+ IFAC * XV(:,:,:,NTIMEDIA(JLOOPT,K,INDK),1,NPROCDIA(1,K))
+ END WHERE
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ ELSE
+! Intervalle de temps de longueur differente pour les 2 champs. On ne trace pas
+ LPBREAD=.TRUE.
+ print *,' INTERVALLE DE TEMPS DIFFERENT POUR LES 2 CHAMPS. PAS DE TRACE '
+ IF(LFT .OR. LPVKT .OR. LFT1 .OR. LPVKT1 .AND. LSPVALT)THEN
+ XSPVAL=ZSPVAL
+ ENDIF
+ RETURN
+ ENDIF
+
+! A VERIFIER SSSSSSSSSSSS
+ ELSE
+! Temps incremental
+ IF(NBPROCDIA(K) /= 1 .OR. NBPROCDIA(K-1) /= 1 )THEN
+ LPBREAD=.TRUE.
+ print *,' NB DE PROCESSUS DEMANDES > 1 . PAS DE TRACE '
+ IF(LFT .OR. LPVKT .OR. LFT1 .OR. LPVKT1 .AND. LSPVALT)THEN
+ XSPVAL=ZSPVAL
+ ENDIF
+ RETURN
+ ELSE
+ ILENT=(NTIMEDIA(2,K,INDK)-NTIMEDIA(1,K,INDK))/NTIMEDIA(3,K,INDK)
+ ILENT2=(NTIMEDIA(2,K-1,INDKM1)-NTIMEDIA(1,K-1,INDKM1))/NTIMEDIA(3,K-1,INDKM1)
+ IF(ILENT2 /= ILENT)THEN
+ LPBREAD=.TRUE.
+ print *,' INTERVALLE DE TEMPS DIFFERENT POUR LES 2 CHAMPS. PAS DE TRACE '
+ print *,' (',XTIMEDIA(1,K-1,INDKM1),' - (',XTIMEDIA(2,K-1,INDKM1),') ET (', &
+ XTIMEDIA(1,K,INDK),' - (',XTIMEDIA(2,K,INDK),')'
+ IF(LFT .OR. LPVKT .OR. LFT1 .OR. LPVKT1 .AND. LSPVALT)THEN
+ XSPVAL=ZSPVAL
+ ENDIF
+ RETURN
+ ELSE
+!-----------------------------------------------------------------------
+! IF(K <= 2)THEN
+ IF(NUMPM(K-1) == 0 .OR. NUMPM(MAX(K-1,1)) == 3)THEN
+ if(nverbia > 0)then
+ print *,' diff_oper3 K NUMPM(K-1) ',K,NUMPM(K-1)
+ endif
+ if(nblvlkdia(k,indk) == 1 .and. nblvlkdia(k-1,indk) == 1)then
+ print *,' diff_oper3 Niveaux en K de part et d autre de MINUS '
+ print *,' K1= ',NLVLKDIA(1,K-1,INDK),' K2= ',NLVLKDIA(1,K,INDK)
+! INIV1=le 1er dans la directive <-> K-1 , INIV2=le 2e=courant <-> K
+! Janv 2001
+ IF(CTYPE == 'CART' .OR. CTYPE == 'MASK')THEN
+ INIV1=NLVLKDIA(1,K-1,INDK)-NKL+1
+ INIV2=NLVLKDIA(1,K,INDK)-NKL+1
+ ELSE
+! Janv 2001
+ INIV1=NLVLKDIA(1,K-1,INDK)
+ INIV2=NLVLKDIA(1,K,INDK)
+! Janv 2001
+ ENDIF
+! Janv 2001
+ IDIFK=2
+ endif
+
+
+ IF(LMUMVM .OR. LMUTVT .OR. LUMVM .OR. LUTVT .OR. &
+ LSUMVM .OR. LSUTVT .OR. LMLSUMVM .OR. LMLSUTVT)THEN
+ CGROUPS(K-1)=ADJUSTL(CGROUPS(K-1))
+ ILENTIT=LEN_TRIM(CGROUPS(K-1))
+ YCAR(ILENC:ILENC+ILENTIT-1)=CGROUPS(K-1)(1:ILENTIT)
+ ELSE
+ CTITRE2(NPROCDIA(1,K-1))=ADJUSTL(CTITRE2(NPROCDIA(1,K-1)))
+ ILENTIT=LEN_TRIM(CTITRE2(NPROCDIA(1,K-1)))
+ YCAR(ILENC:ILENC+ILENTIT-1)=CTITRE2(NPROCDIA(1,K-1))(1:ILENTIT)
+ ENDIF
+ YCAR=ADJUSTL(YCAR)
+ ILENC=LEN_TRIM(YCAR)
+ ILENC=ILENC+2
+ YCAR(ILENC:ILENC)='('
+ ILENC=ILENC+1
+ IF(NUMFILECUR2 /= NUMFILECUR)THEN
+ CFILEDIAS(JME2)=ADJUSTL(CFILEDIAS(JME2))
+ ILENFI=LEN_TRIM(CFILEDIAS(JME2))
+ YCAR(ILENC:ILENC+ILENFI-1)=CFILEDIAS(JME2)(1:ILENFI)
+ ILENC=ILENC+ILENFI
+ YCAR(ILENC:ILENC+1)=')('
+ ILENC=ILENC+2
+ ENDIF
+
+ IF(IDIFK == 2 .AND. INIV1 /= INIV2) THEN
+ YCAR(ILENC:ILENC+1)='K='
+ ILENC=ILENC+2
+ WRITE(YCAR(ILENC:ILENC+1),'(I2)')INIV1
+ ILENC=ILENC+2
+ YCAR(ILENC:ILENC+1)=')('
+ ILENC=ILENC+2
+ ENDIF
+
+! Ecriture de la premiere serie de temps
+ IF(CTYPE == 'DRST' .OR. CTYPE == 'RSPL' .OR. CTYPE == 'RAPL')THEN
+ WRITE(YTIM,'(F8.0)')XTRAJT2(NTIMEDIA(1,K-1,INDKM1),INDKM1)
+ ELSE
+ WRITE(YTIM,'(F8.0)')XTRAJT2(NTIMEDIA(1,K-1,INDKM1),1)
+ ENDIF
+ YTIM=ADJUSTL(YTIM)
+ ILENTIM=LEN_TRIM(YTIM)
+ YCAR(ILENC:ILENC+ILENTIM-1)=YTIM(1:ILENTIM)
+ YTIM(1:LEN(YTIM))=' '
+ ILENC=ILENC+ILENTIM
+
+ IF(CTYPE == 'DRST' .OR. CTYPE == 'RSPL' .OR. CTYPE == 'RAPL')THEN
+ INDNN=INDKM1
+ ELSE
+ INDNN=1
+ ENDIF
+! IF(XTRAJT2(NTIMEDIA(2,K-1,INDKM1),1) /= XTRAJT2(NTIMEDIA(1,K-1,INDKM1),1))THEN
+ IF(XTRAJT2(NTIMEDIA(2,K-1,INDKM1),INDNN) /= XTRAJT2(NTIMEDIA(1,K-1,INDKM1),INDNN))THEN
+
+ YCAR(ILENC:ILENC+2)=' - '
+ ILENC=ILENC+3
+ WRITE(YTIM,'(F8.0)')XTRAJT2(NTIMEDIA(2,K-1,INDKM1),INDNN)
+! WRITE(YTIM,'(F8.0)')XTRAJT2(NTIMEDIA(2,K-1,INDKM1),1)
+ YTIM=ADJUSTL(YTIM)
+ ILENTIM=LEN_TRIM(YTIM)
+ YCAR(ILENC:ILENC+ILENTIM-1)=YTIM(1:ILENTIM)
+ YTIM(1:LEN(YTIM))=' '
+ ILENC=ILENC+ILENTIM
+
+ ELSE
+ ILENC=ILENC+1
+ ENDIF
+
+ IF(LMINUS)THEN
+ YCAR(ILENC:ILENC+3)=') - '
+ ELSE IF(LPLUS)THEN
+ YCAR(ILENC:ILENC+3)=') + '
+ ENDIF
+ ILENC=ILENC+4
+
+ ELSE
+
+ YCAR=ADJUSTL(CTITB3)
+ ILENC=LEN_TRIM(YCAR)+1
+ IF(LMINUS)THEN
+ YCAR(ILENC:ILENC+2)=' - '
+ ELSE IF(LPLUS)THEN
+ YCAR(ILENC:ILENC+2)=' + '
+ ENDIF
+ ILENC=ILENC+3
+
+ ENDIF
+!-----------------------------------------------------------------------
+! FIN Ecriture de la premiere serie de temps
+ IF(LMUMVM .OR. LMUTVT .OR. LUMVM .OR. LUTVT .OR. &
+ LSUMVM .OR. LSUTVT .OR. LMLSUMVM .OR. LMLSUTVT)THEN
+ ILENTIT=LEN_TRIM(CGROUPS(K))
+ YCAR(ILENC:ILENC+ILENTIT-1)=CGROUPS(K)(1:ILENTIT)
+ ELSE
+ CTITRE(NPROCDIA(1,K))=ADJUSTL(CTITRE(NPROCDIA(1,K)))
+ ILENTIT=LEN_TRIM(CTITRE(NPROCDIA(1,K)))
+ YCAR(ILENC:ILENC+ILENTIT-1)=CTITRE(NPROCDIA(1,K))(1:ILENTIT)
+ ENDIF
+ YCAR=ADJUSTL(YCAR)
+ ILENC=LEN_TRIM(YCAR)
+ ILENC=ILENC+2
+ YCAR(ILENC:ILENC)='('
+ ILENC=ILENC+1
+ IF(NUMFILECUR2 /= NUMFILECUR)THEN
+ CFILEDIAS(JME)=ADJUSTL(CFILEDIAS(JME))
+ ILENFI=LEN_TRIM(CFILEDIAS(JME))
+ YCAR(ILENC:ILENC+ILENFI-1)=CFILEDIAS(JME)(1:ILENFI)
+ ILENC=ILENC+ILENFI
+ YCAR(ILENC:ILENC+1)=')('
+ ILENC=ILENC+2
+ ENDIF
+
+ IF(IDIFK == 2 .AND. INIV1 /= INIV2)THEN
+ YCAR(ILENC:ILENC+1)='K='
+ ILENC=ILENC+2
+ WRITE(YCAR(ILENC:ILENC+1),'(I2)')INIV2
+ ILENC=ILENC+2
+ YCAR(ILENC:ILENC+1)=')('
+ ILENC=ILENC+2
+ ENDIF
+
+
+! Ecriture de la deuxieme serie de temps
+ IF(CTYPE == 'DRST' .OR. CTYPE == 'RSPL' .OR. CTYPE == 'RAPL')THEN
+ WRITE(YTIM,'(F8.0)')XTRAJT(NTIMEDIA(1,K,INDK),INDK)
+ ELSE
+ WRITE(YTIM,'(F8.0)')XTRAJT(NTIMEDIA(1,K,INDK),1)
+ ENDIF
+ YTIM=ADJUSTL(YTIM)
+ ILENTIM=LEN_TRIM(YTIM)
+ YCAR(ILENC:ILENC+ILENTIM-1)=YTIM(1:ILENTIM)
+ YTIM(1:LEN(YTIM))=' '
+ ILENC=ILENC+ILENTIM
+
+ IF(CTYPE == 'DRST' .OR. CTYPE == 'RSPL' .OR. CTYPE == 'RAPL')THEN
+ INDNN=INDK
+ ELSE
+ INDNN=1
+ ENDIF
+! IF(XTRAJT(NTIMEDIA(2,K,INDK),1) /= XTRAJT(NTIMEDIA(1,K,INDK),1))THEN
+ IF(XTRAJT(NTIMEDIA(2,K,INDK),INDNN) /= XTRAJT(NTIMEDIA(1,K,INDK),INDNN))THEN
+
+ YCAR(ILENC:ILENC+2)=' - '
+ ILENC=ILENC+3
+ WRITE(YTIM,'(F8.0)')XTRAJT(NTIMEDIA(2,K,INDK),INDNN)
+! WRITE(YTIM,'(F8.0)')XTRAJT(NTIMEDIA(2,K,INDK),1)
+ YTIM=ADJUSTL(YTIM)
+ ILENTIM=LEN_TRIM(YTIM)
+ YCAR(ILENC:ILENC+ILENTIM-1)=YTIM(1:ILENTIM)
+ YTIM(1:LEN(YTIM))=' '
+ ILENC=ILENC+ILENTIM
+
+ ELSE
+ ILENC=ILENC+1
+ ENDIF
+
+ YCAR(ILENC:ILENC)=')'
+
+! IF(K <= 2)THEN
+ IF(NUMPM(K-1) == 0 .OR. NUMPM(MAX(K-1,1)) == 3)THEN
+ if(nverbia > 0)then
+ print *,' diff_oper3 K NUMPM(K-1) ',K,NUMPM(K-1)
+ endif
+ LTITDEF=.FALSE.
+! YTITB3(1:LEN(YTITB3))=' '
+! YTITB3=ADJUSTL(CTITB3)
+ ENDIF
+ if(nblvlkdia(k,indk) == 1 .and. nblvlkdia(k-1,indk) == 1)then
+ print *,' diff_oper3-2 Niveaux en K de part et d autre de MINUS '
+ print *,' K1= ',NLVLKDIA(1,K-1,INDK),' K2= ',NLVLKDIA(1,K,INDK)
+! Janv 2001
+ IF(CTYPE == 'CART' .OR. CTYPE == 'MASK')THEN
+ INIV1=NLVLKDIA(1,K-1,INDK)-NKL+1
+ INIV2=NLVLKDIA(1,K,INDK)-NKL+1
+ ELSE
+! Janv 2001
+ INIV1=NLVLKDIA(1,K-1,INDK)
+ INIV2=NLVLKDIA(1,K,INDK)
+! Janv 2001
+ ENDIF
+! Janv 2001
+ if(nverbia >0)then
+ print *,' INIV1 INIV2 diff_oper',INIV1,INIV2
+ endif
+ IDIFK=2
+ endif
+!!! 1/3/04
+ IF(CTITB3 /= 'DEFAULT')THEN
+ ELSE
+!!! 1/3/04
+
+ CTITB3=ADJUSTL(YCAR(1:100))
+ CTITB3=ADJUSTL(CTITB3)
+!!! 1/3/04
+ ENDIF
+!!! 1/3/04
+ print *,' CTITB3 ',CTITB3
+ IF(LMINUS)THEN
+ IFAC=-1
+ ELSE IF(LPLUS)THEN
+ IFAC=1
+ ENDIF
+! 220900
+ IF(IDIFK == 2)THEN
+ if(nverbia > 0)then
+ print *,' **diff_oper IDIFK size(XVAR) ',IDIFK,size(xvar,1),&
+ size(xvar,2),size(xvar,3),size(xvar,4),size(xvar,5),size(xvar,6)
+ print *,' AV ',xvar(1,1,1,:,1,3)
+ print *,' INDKM1 ',INDKM1,' K ',K,' NPROCDIA(1,K) ',NPROCDIA(1,K)
+ endif
+! Mai 2003
+ WHERE((XVAR(:,:,INIV2,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),INDK,NPROCDIA(1,K)) == XSPVAL) &
+! NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K)) == XSPVAL) &
+ .OR. (XVAR2(:,:,INIV1,NTIMEDIA(1,K-1,INDKM1): &
+ NTIMEDIA(2,K-1,INDKM1):&
+ NTIMEDIA(3,K-1,INDKM1),INDKM1,NPROCDIA(1,K-1)) == XSPVAL))
+! NTIMEDIA(3,K-1,INDKM1),1,NPROCDIA(1,K-1)) == XSPVAL))
+ XVAR(:,:,INIV2,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),INDK,NPROCDIA(1,K))=XSPVAL
+! NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))=XSPVAL
+ ELSEWHERE
+ XVAR(:,:,INIV2,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),INDK,NPROCDIA(1,K))= &
+! NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))= &
+ XVAR2(:,:,INIV1,NTIMEDIA(1,K-1,INDKM1):NTIMEDIA(2,K-1,INDKM1):&
+ NTIMEDIA(3,K-1,INDKM1),INDKM1,NPROCDIA(1,K-1)) + &
+! NTIMEDIA(3,K-1,INDKM1),1,NPROCDIA(1,K-1)) + &
+ IFAC * XVAR(:,:,INIV2,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),INDK,NPROCDIA(1,K))
+! NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))
+ END WHERE
+ if(nverbia > 0)then
+ print *,' AP ',xvar(1,1,1,:,1,3)
+ endif
+ ELSE
+ WHERE((XVAR(:,:,:,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),INDK,NPROCDIA(1,K)) == XSPVAL) &
+! NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K)) == XSPVAL) &
+ .OR. (XVAR2(:,:,:,NTIMEDIA(1,K-1,INDKM1): &
+ NTIMEDIA(2,K-1,INDKM1):&
+ NTIMEDIA(3,K-1,INDKM1),INDKM1,NPROCDIA(1,K-1)) == XSPVAL))
+! NTIMEDIA(3,K-1,INDKM1),1,NPROCDIA(1,K-1)) == XSPVAL))
+ XVAR(:,:,:,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),INDK,NPROCDIA(1,K))=XSPVAL
+! NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))=XSPVAL
+ ELSEWHERE
+ XVAR(:,:,:,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),INDK,NPROCDIA(1,K))= &
+! NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))= &
+ XVAR2(:,:,:,NTIMEDIA(1,K-1,INDKM1):NTIMEDIA(2,K-1,INDKM1):&
+ NTIMEDIA(3,K-1,INDKM1),INDKM1,NPROCDIA(1,K-1)) + &
+! NTIMEDIA(3,K-1,INDKM1),1,NPROCDIA(1,K-1)) + &
+ IFAC * XVAR(:,:,:,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),INDK,NPROCDIA(1,K))
+! NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))
+ END WHERE
+ ENDIF
+ IF(ALLOCATED(XUMEM))THEN
+ IF(IDIFK == 2)THEN
+ WHERE((XU(:,:,INIV2,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K)) == XSPVAL) &
+ .OR. (XUMEM(:,:,INIV1,NTIMEDIA(1,K-1,INDKM1): &
+ NTIMEDIA(2,K-1,INDKM1):&
+ NTIMEDIA(3,K-1,INDKM1),1,NPROCDIA(1,K-1)) == XSPVAL))
+ XU(:,:,INIV2,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))=XSPVAL
+ ELSEWHERE
+ XU(:,:,INIV2,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))= &
+ XUMEM(:,:,INIV1,NTIMEDIA(1,K-1,INDKM1):NTIMEDIA(2,K-1,INDKM1):&
+ NTIMEDIA(3,K-1,INDKM1),1,NPROCDIA(1,K-1)) + &
+ IFAC * XU(:,:,INIV2,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))
+ END WHERE
+ ELSE
+ WHERE((XU(:,:,:,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K)) == XSPVAL) &
+ .OR. (XUMEM(:,:,:,NTIMEDIA(1,K-1,INDKM1): &
+ NTIMEDIA(2,K-1,INDKM1):&
+ NTIMEDIA(3,K-1,INDKM1),1,NPROCDIA(1,K-1)) == XSPVAL))
+ XU(:,:,:,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))=XSPVAL
+ ELSEWHERE
+ XU(:,:,:,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))= &
+ XUMEM(:,:,:,NTIMEDIA(1,K-1,INDKM1):NTIMEDIA(2,K-1,INDKM1):&
+ NTIMEDIA(3,K-1,INDKM1),1,NPROCDIA(1,K-1)) + &
+ IFAC * XU(:,:,:,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))
+ END WHERE
+ ENDIF
+ ENDIF
+ IF(ALLOCATED(XVMEM))THEN
+ IF(IDIFK == 2)THEN
+ WHERE((XV(:,:,INIV2,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K)) == XSPVAL) &
+ .OR. (XVMEM(:,:,INIV1,NTIMEDIA(1,K-1,INDKM1): &
+ NTIMEDIA(2,K-1,INDKM1):&
+ NTIMEDIA(3,K-1,INDKM1),1,NPROCDIA(1,K-1)) == XSPVAL))
+ XV(:,:,INIV2,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))=XSPVAL
+ ELSEWHERE
+ XV(:,:,INIV2,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))= &
+ XVMEM(:,:,INIV1,NTIMEDIA(1,K-1,INDKM1):NTIMEDIA(2,K-1,INDKM1):&
+ NTIMEDIA(3,K-1,INDKM1),1,NPROCDIA(1,K-1)) + &
+ IFAC * XV(:,:,INIV2,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))
+ END WHERE
+ ELSE
+ WHERE((XV(:,:,:,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K)) == XSPVAL) &
+ .OR. (XVMEM(:,:,:,NTIMEDIA(1,K-1,INDKM1): &
+ NTIMEDIA(2,K-1,INDKM1):&
+ NTIMEDIA(3,K-1,INDKM1),1,NPROCDIA(1,K-1)) == XSPVAL))
+ XV(:,:,:,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))=XSPVAL
+ ELSEWHERE
+ XV(:,:,:,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))= &
+ XVMEM(:,:,:,NTIMEDIA(1,K-1,INDKM1):NTIMEDIA(2,K-1,INDKM1):&
+ NTIMEDIA(3,K-1,INDKM1),1,NPROCDIA(1,K-1)) + &
+ IFAC * XV(:,:,:,NTIMEDIA(1,K,INDK):NTIMEDIA(2,K,INDK): &
+ NTIMEDIA(3,K,INDK),1,NPROCDIA(1,K))
+ END WHERE
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+! A VERIFIER SSSSSSSSSSSS
+ ENDIF
+
+!******************************** A VERIFIER
+ENDIF
+
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+!IF(K == NSUPERDIA .AND. YTITB3 /= ' ' .AND. YTITB3 /= 'DEFAULT')THEN
+! CTITB3=YTITB3
+!ENDIF
+
+IF(LFT .OR. LPVKT .OR. LFT1 .OR. LPVKT1 .AND. LSPVALT)THEN
+ XSPVAL=ZSPVAL
+ENDIF
+RETURN
+END SUBROUTINE DIFF_OPER
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/echelleph.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/echelleph.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9c4e25751f4247f7bf73a2597bdf17df08763b05
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/echelleph.f90
@@ -0,0 +1,288 @@
+! ######spl
+ SUBROUTINE ECHELLEPH(KLEN,PVHCPH)
+! #################################
+!
+!!**** *ECHELLEPH* - Sets the arrow scales for horizontal profile of vectors
+!! (ds le pg LCV+LCH+LUMVM(or LUTVT)+LTRACECV=T)
+!! ex: LTRACECV=T
+!! definition d'une CV (par l'une des 5 methodes possibles)
+!! UMVM_CV__Z_5000
+!! Possibilite de definir l'echelle avec XVRLPH et XVHCPH
+!! Par defaut, XVHCPH=20M/S et XVRLPH a une valeur <0
+!! XVRLPH peut etre change et doit etre exprime en fraction axe X
+!! Si XVHCPH n'est pas mofifie, XVRLPH est la dimension papier
+!! correspondant a 20M/S , sinon a la valeur modifiee
+!!
+!! PURPOSE
+!! -------
+!
+! This routine initialize the emagram wind vector plotting by invoking
+! the NCAR "DRWVEC" utility (drawing of a single vector). KLEN and PHA
+! are returned to the calling program.
+!
+!!** METHOD
+!! ------
+!! The scaling is made is made by converting to the old-fashioned
+!! NCAR "metacode coordinate", see NCAR documentation volume I, page 345.
+!! A scaling vector is drawn to the page bottom as a visual guidance.
+!! Returned values are: KLEN maximum arrow size which can be plotted
+!! (given in metacode units), PHA maximum wind modulus which can be
+!! plotted (given in m/s). Values of KLEN and PHA have to be mutually
+!! consistent.
+!!
+!! EXTERNAL
+!! --------
+!! GETSI : Retrieves the parameters defining the size of the plotter
+!! in the plotter coordinate system. Size assumed between 1 and
+!! 2**ISX-1 and 2**ISY-1. This old-fashioned NCAR routine is
+!! documented in the SSPS reference manual of the Version 2
+!! (not in version 3!) of the NCAR package. We sincerely
+!! apologize for the inconvenience.
+!! GSCLIP : Controls NCAR window clipping.
+!! GETSET : Returns the current mapping of the NCAR user coordinate
+!! onto the current GKS viewport in normalized device coordinate.
+!! See NCAR reference manual volume 1, page 343 for details.
+!! CFUX : Converts a X "fractional coordinate" value into its
+!! X "user coordinate" counterpart. See NCAR manual volume 1,
+!! page 346 for details.
+!! CFUY : Converts a Y "fractional coordinate" value into its
+!! Y "user coordinate" counterpart. See NCAR manual volume 1,
+!! page 346 for details.
+!! FL2INT : Given a coordinate pair in the NCAR user system, returns the
+!! coresponding coordinate pair in the metacode system;
+!! DRWVEC : Draws a single vector given by two pairs of metacode
+!! coordinates, CALL DRWVEC (M1,M2,M3,M4,LABEL,NC), where
+!! (M1,M2) coordinate of arrow base on a 2**15x2**15 grid,
+!! (M3,M4) coordinate of arrow head on a 2**15x2**15 grid,
+!! LABEL character label to be put above arrow, and
+!! NC number of character in label. This routine is
+!! and documented in the VELVECT NCAR sources, but
+!! not really documented elsewhere... Sorry for this!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! For the vector utilities not documented in the NCAR package
+!! Version 3 idocumentation, a better reference is:
+!! The NCAR GKS-Compatible Graphics System Version 2,
+!! SPPS an NCAR System Plot Package Simulator.
+!! NCAR Technical note 267+1A, April 1986, NCAR/UCAR, Boulder, USA.
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 11/01/59
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODD_MEMCV
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments and results
+!
+INTEGER, INTENT(OUT) :: KLEN ! KLEN maximum arrow size which can be plotted
+ ! (given in metacode units)
+!REAL, INTENT(OUT) :: PHA ! PHA maximum wind modulus which can be plotted
+REAL, INTENT(OUT) :: PVHCPH ! PVHCPH maximum wind modulus which can be plotted
+ ! (given in m/s)
+!
+!* 0.2 Local variables
+!
+INTEGER :: ILENGTH, IDUM5, IM1, IM2, IM3, IM4, IPHAS4
+
+CHARACTER(LEN=10) :: YLABEL
+
+REAL :: ZU, ZV
+REAL :: ZX1,ZX2,ZY1,ZY2
+!REAL :: PVHCPH
+REAL :: PHA
+REAL :: ZFXMIN,ZFXMAX,ZFYMIN,ZFYMAX,ZUMIN,ZUMAX,ZVMIN,ZVMAX
+!
+!* 0.3 TRACE interface with the DRWVEC routine of the NCAR package
+!
+! NOTICE: The DRWVEC and the NCAR graphical utilities are NOT written
+! ------ in Fortran 90, but in Fortran 77.. This sub-section of TRACE
+! does not follow the Meso-NH usual rules: communication has
+! to be made using the /VEC1/ COMMON stack with static memory
+! allocation. Actually used variables are:
+! ICTRFG arrow centering control flag
+! ISX plotter size along x in plotter units
+! ISY plotter size along y in plotter units
+! ZMN plotter size along x in metacode units
+! ZMX plotter size along y in metacode units
+!
+INTEGER :: ICTRFG, ILAB, IOFFD, IOFFM, ISX, ISY
+REAL :: ASH, EXT, RMN, RMX, SIDE, SIZE, XLT, YBT, ZMN, ZMX
+!
+COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB , &
+IOFFD ,IOFFM ,ISX ,ISY , &
+RMN ,RMX ,SIDE ,SIZE , &
+XLT ,YBT ,ZMN ,ZMX
+!
+!* 0.4 Interface declarations
+!
+INTERFACE
+ FUNCTION CFUX (RX)
+ REAL :: RX, CFUX
+ END FUNCTION CFUX
+END INTERFACE
+!
+INTERFACE
+ FUNCTION CFUY (RY)
+ REAL :: RY, CFUY
+ END FUNCTION CFUY
+END INTERFACE
+!
+INTERFACE
+ SUBROUTINE DRWVEC (M1,M2,M3,M4,LABEL,NC)
+ CHARACTER*10 LABEL
+ INTEGER :: M1,M2,M3,M4,NC
+ END SUBROUTINE DRWVEC
+END INTERFACE
+!---------------------------------------------------------------------------
+!
+!* 1. ARROW SCALE CALCULATION
+!
+!* 1.0 Sets the plotter dimensions in metacode units
+!* and some upper bound wind value
+!
+ILENGTH=160 ! ILENGTH is the maximum possible arrow length in plotter units
+ ! (i.e.: with respect to the 2**10-1 default value)
+PHA=80. ! PHA is the maximum possible wind value corresponding to the
+ ! maximum possible arrow size given above. Thes two values have
+ ! to be consistent
+!
+! Retrieves plotter size, first in plotter units
+!
+CALL GETSI(ISX,ISY)
+if(nverbia > 0)then
+print *, '*** Echelleph AP GETSI ISX, ISY ',ISX,ISY
+endif
+ISX=2**(15-ISX)
+ISY=2**(15-ISY)
+if(nverbia > 0)then
+print *, '*** Echelleph AP ISX, ISY ',ISX,ISY
+endif
+!
+! Converts the maximum possiblble arrow length in metacode units
+! (i.e. with respect to 2**15-1)
+!
+!jjdjdjdjdjdjjd
+IF(XVRLPH > 0.)THEN
+CALL GETSET(ZFXMIN,ZFXMAX,ZFYMIN,ZFYMAX,ZUMIN,ZUMAX,ZVMIN,ZVMAX,IDUM5)
+ZX1=ZFXMIN
+ZX2=ZFXMIN+xvrlph*(zfxmax-zfxmin)
+zy1=zfymin
+zy2=zy1
+ZX1=CFUX(ZX1)
+ZX2=CFUX(ZX2)
+ZY1=CFUY(ZY1)
+ZY2=CFUY(ZY2)
+CALL FL2INT(ZX1,ZY1,IM1,IM2)
+CALL FL2INT(ZX2,ZY2,IM3,IM4)
+KLEN=IM3-IM1
+KLEN=KLEN*4
+IF(XVHCPH /= 20. .AND. XVHCPH > 0.)THEN
+ PVHCPH=XVHCPH*4.
+ELSE
+ PVHCPH=PHA
+ENDIF
+if(nverbia > 0)then
+print *,'** Echelleph KLEN calcule '
+endif
+ELSE
+ KLEN=ILENGTH*ISX
+ PVHCPH=PHA
+ENDIF
+!jjdjdjdjdjdjjd
+ZMN=0.
+ZMX=FLOAT(KLEN)+0.01
+if(nverbia > 0)then
+print *,' ** Echelleph KLEN,ZMX ',KLEN,ZMX
+endif
+!
+!* 1.1 Computes appropriate scale
+!
+CALL GSCLIP(0) ! Enables leader writing out of the frame
+!
+! Prepares header and scale.
+! Retrieves current window limits in normalized
+! device coordinate and NCAR user coordinate.
+!
+CALL GETSET(ZFXMIN,ZFXMAX,ZFYMIN,ZFYMAX,ZUMIN,ZUMAX,ZVMIN,ZVMAX,IDUM5)
+!
+! Computes the normalized device coordinates of the point located by
+! user coordinates (ZFXMAX-0.05,ZFYMIN-0.04)
+!
+!ZU=CFUX(ZFXMAX-0.05)
+ZU=CFUX(ZFXMAX-0.15)
+ZV=CFUY(ZFYMIN-0.03)
+!ZV=CFUY(ZFYMIN-0.04)
+!
+! Then, convert result to metacode coordinates
+!
+CALL FL2INT(ZU,ZV,IM1,IM2)
+IM3=IM1+KLEN/4
+IM4=IM2
+IPHAS4=IFIX(PVHCPH/4)
+!IPHAS4=IFIX(PHA/4)
+if(nverbia > 0)then
+print *,' Echelleph IM1,IM2,IM3,IM4 ',IM1,IM2,IM3,IM4
+endif
+!
+!* 1.2 Draws a unit vector under the plot
+!
+!
+! The unit vector is 1/4 of the maximum possible wind PHA
+!
+WRITE(YLABEL,'(I2,'' M/S '')')IPHAS4
+print *,' Echelleph YLABEL ',YLABEL
+!CALL DRWVEC(IM1,IM2,IM3,IM4,YLABEL,10) !10=LEN(YLABEL)
+!CALL VVSETI('VPO',1)
+CALL DRWVEC(IM1,IM2,IM3,IM4,YLABEL,0)
+ZU=CFUX(ZFXMAX-0.125)
+ZV=CFUY(ZFYMIN-0.02)
+CALL PLCHHQ(ZU,ZV,YLABEL(1:LEN_TRIM(YLABEL)),7.,0.,0.)
+!
+! Setting the ICTRFG flag controls the arrow centering.
+! Arrow is centered with ICTRFG=0, and the tail of the
+! arrow is placed at the grid point location with ICTRFG=1.
+!
+!ICTRFG=1
+! remplaced by CALL VVSETI('VPO',1)
+!
+! Window clipping restored after header writing
+!
+CALL GSCLIP(1)
+!
+!----------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+!
+END SUBROUTINE ECHELLEPH
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/extract_and_open_files.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/extract_and_open_files.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ab6a79f238a30554808f455b1efecfdd0ceeb249
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/extract_and_open_files.f90
@@ -0,0 +1,546 @@
+! ######spl
+ MODULE MODI_EXTRACT_AND_OPEN_FILES
+! ##################################
+!
+INTERFACE
+!
+SUBROUTINE EXTRACT_AND_OPEN_FILES(HCARIN,HCAROUT)
+CHARACTER(LEN=*) :: HCARIN
+CHARACTER(LEN=*) :: HCAROUT
+END SUBROUTINE EXTRACT_AND_OPEN_FILES
+!
+END INTERFACE
+!
+END MODULE MODI_EXTRACT_AND_OPEN_FILES
+! ######spl
+ SUBROUTINE EXTRACT_AND_OPEN_FILES(HCARIN,HCAROUT)
+! #################################################
+!
+!!**** *EXTRACT_AND_OPEN_FILES* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FILES_DIACHRO ! NBGUIL
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_RESOLVCAR
+USE MODD_PARAMETERS,ONLY:JPHEXT
+!USE MODD_DIM1
+!USE MODN_PARA
+!USE MODN_NCAR
+USE MODI_CREATLINK
+USE MODI_FMREAD
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+!
+CHARACTER(LEN=*) :: HCARIN
+CHARACTER(LEN=*) :: HCAROUT
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+CHARACTER(LEN=LEN_TRIM(HCARIN)) :: YCARIN
+CHARACTER(LEN=28) :: YNAMFILE,YDUMMYFILE
+CHARACTER(LEN=32) :: YDESFM
+CHARACTER(LEN=1) :: YC1
+CHARACTER(LEN=2) :: YC2
+INTEGER :: ILENC
+INTEGER :: INCR, INDFI, INDQUI, IDIF, INDFIS, INDON
+INTEGER :: ILUDES, IRESP, INUMFILECUR
+INTEGER :: J, JJ, JM, JMM, JA, JME
+INTEGER,DIMENSION(13),SAVE :: IASF
+
+INTEGER :: ISTA, IER, INB, IWK
+INTEGER :: ILU, INUM, IRESP2
+LOGICAL :: GPLUS
+!INTEGER :: IIINF, IJINF, IISUP, IJSUP
+!REAL :: ZIDEBCOU, ZJDEBCOU
+CHARACTER(LEN=20) :: YCOMMENT
+INTEGER :: ILENCH,ILENG,IGRID
+!------------------------------------------------------------------------------
+!
+YCARIN = HCARIN
+if(nverbia >0)then
+ print *,' ENTREE EXTRACT LEN et YCARIN ',LEN(YCARIN),YCARIN
+! print *,' ENTREE EXTRACT HCAROUT ',HCAROUT
+endif
+ILENC = LEN(YCARIN)
+! En cas de superpositions ou presence _MINUS_ , on ne traite pas immediatement
+INDON=INDEX(YCARIN,'_ON_')
+IF(INDON == 0)THEN
+ INDON=INDEX(YCARIN,'_MINUS_')
+ENDIF
+IF(INDON == 0)THEN
+ INDON=INDEX(YCARIN,'_PLUS_')
+ENDIF
+IF(INDON /= 0)THEN
+ HCAROUT(1:LEN(HCAROUT))=' '
+ HCAROUT=YCARIN
+ HCAROUT=ADJUSTL(HCAROUT)
+!print *,' PRESENCE _ON_ HCAROUT ',HCAROUT
+!print *,' YCARIN ',YCARIN(1:LEN_TRIM(YCARIN))
+ RETURN
+ENDIF
+!
+HCAROUT(1:LEN(HCAROUT))=' '
+!print *,' HCARIN ',LEN(HCARIN)
+!print *,' YCARIN ILENC ',ILENC,YCARIN
+!
+! Extraction des noms de fichiers
+!
+! Absence nom de fichier mais presence chaine _FILEx_ ou _FILExx_
+!
+if(nverbia >0)then
+ print *,' ** EXTRACT NBGUILlemets= ',NBGUIL
+endif
+IF(NBGUIL == 0)THEN
+ INDQUI=0
+ INDQUI=INDEX(YCARIN,'_QUIT')
+ IF(INDQUI == 0)THEN
+ INDQUI=INDEX(YCARIN,'QUIT')
+ ENDIF
+ IF(INDQUI /= 0)THEN
+! Fermeture des fichiers et arret du programme
+! Inutile pour les fichiers FM ouverts en lecture
+ !DO J=1,NBFILES
+ !CALL FMCLOS(CFILEDIAS(J),'KEEP',CLUOUTDIAS(J),NRESPDIAS(J))
+ ! plante car le .des est deja ferme
+ !ENDDO
+ YDUMMYFILE=''
+ CALL CREATLINK(' ',YDUMMYFILE,'CLEAN',NVERBIA)
+ CALL FMLOOK('FICVAL','FICVAL',ILU,IRESP2)
+ IF(IRESP2 == 0)THEN
+ CLOSE(ILU)
+ ENDIF
+ CALL SFLUSH
+ CALL GQOPS(ISTA)
+ ! INB donne le nombre de stations ouvertes
+ ! Eventuellement on ferme la WISS N9
+ CALL GQOPWK(1,IER,INB,IWK)
+if(nverbia >0)then
+ print *,' ** EXTRACT nb de stations ouvertes INB= ',INB
+endif
+ IF(INB >1)THEN
+ DO JJ=1,INB
+ CALL GQOPWK(JJ,IER,INB,IWK)
+ IF(IWK == 9)THEN
+ CALL GCLWK(9)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ! INB donne le nombre de stations actives
+ CALL GQACWK(1,IER,INB,IWK)
+if(nverbia >0)then
+ print *,' ** EXTRACT nb de stations actives INB= ',INB
+endif
+ IF(ISTA >1 .AND. INB > 1)THEN
+ CALL GDAWK(2)
+ CALL GCLWK(2)
+ ENDIF
+! CALL FRAME
+ CALL NGPICT(1,1)
+ CALL CLSGKS
+if(nverbia >0)then
+ print *,' ** EXTRACT AV RETURN'
+endif
+ RETURN
+ ENDIF ! fin de 'QUIT'
+ !
+ INDFI=0
+ INDFI=INDEX(YCARIN,'_FILE')
+ INUMFILECUR=NUMFILECUR
+ IF(INDFI /= 0)THEN
+ INDFIS=0
+! On reutilise un fichier deja ouvert; on renvoit l'instruction sans la chaine
+! _FILEx_ ou _FILExx_; on positionne le numero du fichier courant
+! Cas numero suivant _FILE a 1 chiffre
+ IF(YCARIN(INDFI+6:INDFI+6) == '_')THEN
+ READ(YCARIN(INDFI+5:INDFI+5),'(I1)')NUMFILECUR
+! Modif le 3/1/96. Pour conserver la chaine _FILEx_
+! HCAROUT(1:INDFI-1)=YCARIN(1:INDFI-1)
+! HCAROUT(INDFI:ILENC-7)=YCARIN(INDFI+7:ILENC)
+ HCAROUT(1:ILENC)=YCARIN(1:ILENC)
+ INDFIS=MIN(INDFI+6+1,ILENC)
+! Cas numero suivant _FILE a 2 chiffres
+ ELSE IF(YCARIN(INDFI+7:INDFI+7) == '_')THEN
+ READ(YCARIN(INDFI+5:INDFI+6),'(I2)')NUMFILECUR
+! Modif le 3/1/96. Pour conserver la chaine _FILEx_
+! HCAROUT(1:INDFI-1)=YCARIN(1:INDFI-1)
+! HCAROUT(INDFI:ILENC-8)=YCARIN(INDFI+8:ILENC)
+ HCAROUT(1:ILENC)=YCARIN(1:ILENC)
+ INDFIS=MIN(INDFI+7+1,ILENC)
+ ENDIF
+
+ JME=0
+ DO JA=1,NBFILES
+ IF(NUMFILES(JA) == NUMFILECUR)THEN
+ JME=JA
+ ENDIF
+ ENDDO
+ IF(JME==0) THEN
+ PRINT*,'*PB avec la directive:'
+ PRINT*,' _file',NUMFILECUR,'_ n est pas associe a un nom de fichier'
+ LPBREAD=.TRUE.
+ RETURN
+ ENDIF
+
+! IIINF=NIINF; IJINF=NJINF; IISUP=NISUP; IJSUP=NJSUP
+! ZIDEBCOU=XIDEBCOU; ZJDEBCOU=XJDEBCOU
+! CALL INI_CST
+! CALL READ_DIMGRIDREF(JME,CFILEDIAS(JME),CLUOUTDIAS(JME))
+! CALL INIDEF
+! NIMNMX=-1
+! LMINMAX=.TRUE.
+! CALL COMPCOORD_FORDIACHRO(0)
+! NIINF=IIINF; NJINF=IJINF; NISUP=IISUP; NJSUP=IJSUP
+! XIDEBCOU=ZIDEBCOU; XJDEBCOU=ZJDEBCOU
+ IF (INUMFILECUR /= NUMFILECUR) THEN
+ ! lecture de l en-tete si le fichier traite n est pas l ancien fichier
+ ! courant
+ IF(NVERBIA>0) THEN
+ print *,' ** EXTRACT avant lecture de l entete de ',TRIM(CFILEDIAS(JME))
+ ENDIF
+ CALL READ_FILEHEAD(JME,CFILEDIAS(JME),CLUOUTDIAS(JME))
+ ENDIF
+
+ INDFI=INDEX(YCARIN(INDFIS:ILENC),'_FILE')
+ IF(INDFI == 0)THEN
+
+ LFIC1=.TRUE.
+
+ ELSE
+
+ DO J=1,90 ! cf nb max de fic dans modd_files_diachro
+ INDFI=INDEX(YCARIN(INDFIS:ILENC),'_FILE')
+
+ IF(INDFI == 0)THEN
+ EXIT
+
+ ELSE
+
+ LFIC1=.FALSE.
+ INDFI=INDFIS+INDFI-1
+ IF(J == 1)THEN
+ NBSIMULT=1
+ NUMFILESIMULT(:)=0
+ NINDFILESIMULT(:)=0
+ NUMFILESIMULT(NBSIMULT)=NUMFILECUR
+ ENDIF
+ NBSIMULT=NBSIMULT+1
+ IF(YCARIN(INDFI+6:INDFI+6) == '_')THEN
+ READ(YCARIN(INDFI+5:INDFI+5),'(I1)')NUMFILESIMULT(NBSIMULT)
+ INDFIS=MIN(INDFI+6+1,ILENC)
+ ELSE IF(YCARIN(INDFI+7:INDFI+7) == '_')THEN
+ READ(YCARIN(INDFI+5:INDFI+6),'(I2)')NUMFILESIMULT(NBSIMULT)
+ INDFIS=MIN(INDFI+7+1,ILENC)
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
+ IF(.NOT.LFIC1)THEN
+ DO J=1,NBSIMULT
+ DO JA=1,NBFILES
+ IF(NUMFILESIMULT(J) == NUMFILES(JA))THEN
+ NINDFILESIMULT(J)=JA
+ EXIT
+ ENDIF
+ ENDDO
+ IF(NINDFILESIMULT(J)==0) THEN
+ PRINT*,'*PB avec la directive:'
+ PRINT*,' _file',NUMFILECUR,'_ n est pas associe a un nom de fichier'
+ LPBREAD=.TRUE.
+ RETURN
+ ENDIF
+ ENDDO
+ ENDIF
+
+ ELSE
+! Cas absence nom de fichier; on renvoit l'instruction telle quelle
+ HCAROUT=ADJUSTL(YCARIN)
+ ENDIF
+ RETURN
+ENDIF
+!
+! Presence d'au moins un nom de fichier
+!
+DO J=1,NBGUIL,2 !***********************************************************
+!
+ IF(YCARIN(NMGUIL(J)-1:NMGUIL(J)-1) /= '_')THEN
+ print *,'*PB. UN GUILLEMET DOIT ETRE PRECEDE D UN _', &
+ ' (Cas instruction _FILEx_)'
+ print *,'ou ERREUR DANS LE NOM SYMBOLIQUE UTILISE. ', &
+ ' VERIFIEZ LA SYNTAXE OU L''ORTHOGRAPHE DE VOS INSTRUCTIONS'
+ LPBREAD=.TRUE.
+ RETURN
+ ENDIF
+! Cas nom d'un processus
+ IF(YCARIN(NMGUIL(J)-3:NMGUIL(J)-3) == '_' .AND. &
+ YCARIN(NMGUIL(J)-2:NMGUIL(J)-2) == 'P')THEN
+ CYCLE
+ ELSE
+! Cas nom d'un fichier
+ INCR=1
+ DO JJ=1,10
+ INCR=INCR+1
+ IF(YCARIN(NMGUIL(J)-INCR:NMGUIL(J)-INCR) == '_')EXIT
+ ENDDO
+!
+! JM = indice debut chaine _FILEx_ ou _FILExx_
+!
+ JM=NMGUIL(J)-INCR;!print *,' JM ',JM
+ IF(YCARIN(JM+1:JM+4) /= 'FILE')THEN
+ print *,' CHAINE DE CARACTERES _FILEx_ ATTENDUE DEVANT LES GUILLEMETS', &
+ ' ABSENTE. VERIFIEZ LA SYNTAXE DE VOS INSTRUCTIONS'
+ STOP
+ ELSE
+
+ YNAMFILE(1:LEN(YNAMFILE))=' '
+ YNAMFILE=ADJUSTL(YCARIN(NMGUIL(J)+1:NMGUIL(J+1)-1))
+ IF(NVERBIA>0) THEN
+ print *,' ** EXTRACT YNAMFILE ',YNAMFILE
+ ENDIF
+
+ IF(NBFILES == 0)THEN
+!
+! INIT GKS et ouverture du premier fichier
+!
+ IASF(:)=1
+ CALL GQOPS(ISTA)
+ IF(ISTA == 0)THEN
+ CALL OPNGKS
+ CALL TABCOL_FORDIACHRO
+ ENDIF
+ CALL GSTXFP(-13,2)
+ CALL GSASF(IASF)
+
+ NBFILES=NBFILES+1
+ CFILEDIAS(NBFILES)=ADJUSTL(YNAMFILE)
+ IF (ABS(JM-NMGUIL(J))-1-1 == 4)THEN
+ NUMFILES(NBFILES)=NBFILES
+ ELSE IF (ABS(JM-NMGUIL(J))-1-1 == 5)THEN
+ READ(YCARIN(NMGUIL(J)-2:NMGUIL(J)-2),'(I1)')NUMFILES(NBFILES)
+ ELSE IF (ABS(JM-NMGUIL(J))-1-1 == 6)THEN
+ READ(YCARIN(NMGUIL(J)-3:NMGUIL(J)-2),'(I2)')NUMFILES(NBFILES)
+ ENDIF
+ NUMFILECUR=NUMFILES(NBFILES)
+
+! ouverture du listing
+ CALL FMATTR(CLUOUTDIAS(NBFILES),CLUOUTDIAS(NBFILES), &
+ NLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
+ OPEN(UNIT=NLUOUTDIAS(NBFILES),FILE=CLUOUTDIAS(NBFILES),FORM='FORMATTED')
+ WRITE(UNIT=NLUOUTDIAS(NBFILES),FMT=1)NBFILES,' ',CFILEDIAS(NBFILES)
+ 1 FORMAT(' OPEN DIACHRONIC FILE ',I2.2,A,A28)
+
+! Ouverture du fichier .lfi et fermeture du fichier .des correspondant
+ IF(NVERBIA>0) THEN
+ print *,' ** EXTRACT avant link et open premier fichier ', &
+ CFILEDIAS(NBFILES)
+ ENDIF
+ CALL CREATLINK('DIRLFI',CFILEDIAS(NBFILES),'CREAT',NVERBIA)
+ CALL FMOPEN(CFILEDIAS(NBFILES),'OLD',CLUOUTDIAS(NBFILES), &
+ NNPRARDIAS(NBFILES),NFTYPEDIAS(NBFILES),NVERBDIAS(NBFILES),&
+ NNINARDIAS(NBFILES),NRESPDIAS(NBFILES))
+ IF (NRESPDIAS(NBFILES) .NE. 0) THEN
+ PRINT*,'*PB a l ouverture de ',CFILEDIAS(NBFILES)
+ LPBREAD=.TRUE.
+ RETURN
+ ENDIF
+ YDESFM(1:LEN(YDESFM))=' '
+ YDESFM=ADJUSTL(ADJUSTR(CFILEDIAS(NBFILES))//'.des')
+ CALL FMLOOK(YDESFM,YDESFM,ILUDES,IRESP)
+ CLOSE(ILUDES)
+ CALL FMFREE(YDESFM,CLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
+
+! Modif le 3/1/96. Pour conserver la chaine _FILEx_
+ IF(JM>=1)THEN
+ HCAROUT(1:NMGUIL(J)-1)=YCARIN(1:NMGUIL(J)-1)
+ ENDIF
+! READ JPHEXT
+ CALL FMREAD(CFILEDIAS(NBFILES),'JPHEXT',CLUOUTDIAS(NBFILES),ILENG,JPHEXT,IGRID,ILENCH,YCOMMENT,NRESPDIAS(NBFILES))
+ ELSE ! NBFILES/=0
+!
+! Fichiers autres que le premier
+!
+ INUMFILECUR=NUMFILECUR
+ NUMFILECUR=0
+ DO JJ=1,NBFILES
+ IF(YNAMFILE == CFILEDIAS(JJ))THEN
+ PRINT*,'*PB avec la directive:'
+ IF (NUMFILES(JJ)<10)THEN
+ WRITE(YC1,'(I1)')NUMFILES(JJ)
+ PRINT*,' ce nom de fichier ',TRIM(YNAMFILE), &
+ ' est deja ouvert avec _FILE'//YC1,'_'
+ ELSE
+ WRITE(YC2,'(I2)')NUMFILES(JJ)
+ PRINT*,' ce nom de fichier ',TRIM(YNAMFILE), &
+ ' est deja ouvert avec _FILE'//YC2,'_'
+ ENDIF
+ LPBREAD=.TRUE.
+ NUMFILECUR=INUMFILECUR
+ RETURN
+ END IF
+ ENDDO
+
+! IF(INUMFILECUR /= NUMFILECUR)THEN
+ IF(NUMFILECUR == 0)THEN
+ IF (ABS(JM-NMGUIL(J))-1-1 == 4)THEN ! _file_
+ ! pas d incrementation de NBFILES
+ NUMFILES(NBFILES)=NBFILES
+ ELSE IF (ABS(JM-NMGUIL(J))-1-1 == 5)THEN ! _filex_
+ NBFILES=NBFILES+1
+ READ(YCARIN(NMGUIL(J)-2:NMGUIL(J)-2),'(I1)')NUMFILES(NBFILES)
+ ELSE IF (ABS(JM-NMGUIL(J))-1-1 == 6)THEN ! _filexx_
+ NBFILES=NBFILES+1
+ READ(YCARIN(NMGUIL(J)-3:NMGUIL(J)-2),'(I2)')NUMFILES(NBFILES)
+ ENDIF
+ ! on ne passe pas dans la boucle pour _file_ car NBFILES=1
+ !(sauf si _file_ et _filex_ melanges ...)
+ DO JJ=1,NBFILES-1
+ IF(NUMFILES(NBFILES)==NUMFILES(JJ))THEN
+ PRINT*,'*PB avec la directive:'
+ IF (NUMFILES(NBFILES)<10)THEN
+ WRITE(YC1,'(I1)')NUMFILES(JJ)
+ PRINT*,' _FILE'//YC1,'_ deja associe au ', &
+ 'nom de fichier ',TRIM(CFILEDIAS(JJ))
+ ELSE
+ WRITE(YC2,'(I2)')NUMFILES(JJ)
+ PRINT*,' _FILE'//YC2,'_ deja associe au ', &
+ 'nom de fichier ',TRIM(CFILEDIAS(JJ))
+ ENDIF
+ NBFILES=NBFILES-1
+ LPBREAD=.TRUE.
+ NUMFILECUR=INUMFILECUR
+ RETURN
+ ENDIF
+ ENDDO
+ !
+ NUMFILECUR=NUMFILES(NBFILES)
+ CFILEDIAS(NBFILES)=ADJUSTL(YNAMFILE)
+
+! Ouverture du fichier lfi et fermeture du fichier des correspondant
+ CALL FMLOOK(CLUOUTDIAS(NBFILES),CLUOUTDIAS(NBFILES), &
+ NLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
+ IF (NRESPDIAS(NBFILES) .NE. 0) THEN
+ PRINT*,'*PB pour l ecriture dans ',CLUOUTDIAS(NBFILES)
+ LPBREAD=.TRUE.
+ RETURN
+ ENDIF
+ WRITE(UNIT=NLUOUTDIAS(NBFILES),FMT=1)NBFILES,' ',CFILEDIAS(NBFILES)
+
+ IF(NVERBIA>0) THEN
+ print *,' ** EXTRACT avant link et open fichier suivant'
+ ENDIF
+ CALL CREATLINK('DIRLFI',CFILEDIAS(NBFILES),'CREAT',NVERBIA)
+ CALL FMOPEN(CFILEDIAS(NBFILES),'OLD',CLUOUTDIAS(NBFILES), &
+ NNPRARDIAS(NBFILES),NFTYPEDIAS(NBFILES), &
+ NVERBDIAS(NBFILES),NNINARDIAS(NBFILES),NRESPDIAS(NBFILES))
+ IF (NRESPDIAS(NBFILES) .NE. 0) THEN
+ PRINT*,'*PB a l ouverture de ',CFILEDIAS(NBFILES)
+ LPBREAD=.TRUE.
+ RETURN
+ ENDIF
+ YDESFM(1:LEN(YDESFM))=' '
+ YDESFM=ADJUSTL(ADJUSTR(CFILEDIAS(NBFILES))//'.des')
+ CALL FMLOOK(YDESFM,YDESFM,ILUDES,IRESP)
+ CLOSE(ILUDES)
+ CALL FMFREE(YDESFM,CLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
+ ENDIF
+ IF(NVERBIA>0) THEN
+ print *,' ** EXTRACT fichier suivant numero: ',NUMFILECUR
+ ENDIF
+
+ IF(MAX(1,J-1) == 1)THEN
+! Modif le 3/1/96. Pour conserver la chaine _FILEx_
+ IDIF=NMGUIL(J)-1-1
+ IF(IDIF >0)THEN
+ JMM=LEN_TRIM(HCAROUT)+1
+! Modif le 3/1/96. Pour conserver la chaine _FILEx_
+ HCAROUT(JMM:JMM+IDIF)=YCARIN(1:NMGUIL(J)-1)
+ ENDIF
+ ELSE
+! Modif le 3/1/96. Pour conserver la chaine _FILEx_
+ IDIF=NMGUIL(J)-1-(NMGUIL(MAX(1,J-1))+1)
+ IF(IDIF >0)THEN
+ JMM=LEN_TRIM(HCAROUT)+1
+! Modif le 3/1/96. Pour conserver la chaine _FILEx_
+ HCAROUT(JMM:JMM+IDIF)=YCARIN(NMGUIL(MAX(1,J-1))+1:NMGUIL(J)-1)
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ DO JA=1,NBFILES
+ IF(NUMFILES(JA) == NUMFILECUR)THEN
+ JME=JA
+ ENDIF
+ ENDDO
+ IF(NVERBIA>0) THEN
+ print *,' ** EXTRACT avant lecture de l entete de ',TRIM(CFILEDIAS(JME))
+ ENDIF
+ CALL READ_FILEHEAD(JME,CFILEDIAS(JME),CLUOUTDIAS(JME))
+ LFIC1=.TRUE.
+
+ ENDIF
+
+ ENDIF
+ENDDO !***********************************************************
+
+
+IDIF=ILENC-(NMGUIL(NBGUIL)+1)
+!print *,' IDIF ILENC ',IDIF,ILENC,NMGUIL(NBGUIL)
+IF(IDIF >0)THEN
+ JMM=LEN_TRIM(HCAROUT)+1
+ HCAROUT(JMM:JMM+IDIF)=YCARIN(NMGUIL(NBGUIL)+1:ILENC)
+ENDIF
+!
+IF(nverbia >0)then
+ print *,' END of EXTRACT_AND_OPEN_FILES HCAROUT ',TRIM(HCAROUT)
+ENDIF
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE EXTRACT_AND_OPEN_FILES
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/factimp.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/factimp.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b5bd4821327af2b17b423618155fbf277b08201c
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/factimp.f90
@@ -0,0 +1,178 @@
+! ######spl
+ SUBROUTINE FACTIMP
+! #################
+!
+!!**** *FACTIMP* - Impression du facteur a * ou + ou -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_MEMCV : CDIRCUR
+!!
+!! Module MODN_RESOLVCAR
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 20/10/99
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_MEMCV
+USE MODD_TYPE_AND_LH
+USE MODD_RESOLVCAR
+USE MODD_EXPR
+
+IMPLICIT NONE
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: J, ILEN, IL
+INTEGER :: ID
+CHARACTER(LEN=500) :: YCAR200
+REAL :: ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+!
+!------------------------------------------------------------------------------
+!
+!* 1.
+! -----------------------------------------
+IL = 0
+!
+IF (NVERBIA >=5) THEN
+ print*, 'FACTIMP ',NSUPERDIA,CFACT(1:NSUPERDIA),LEN_TRIM(CFACT(1))
+ENDIF
+!
+YCAR200(1:LEN(YCAR200))=' '
+IF(NSUPERDIA == 1)THEN
+ IF(NOPE(1) /= 0)THEN
+ CALL PLCHHQ(.99,.032,CDIRCUR(NPARG:NPARD),.010,0.,+1.)
+ IF(NMULTDIV(1) /= 0)THEN
+ CALL PLCHHQ(.002,.93,CMULTDIV(1),.007,0.,-1.)
+ ENDIF
+ ELSE
+ IF(NMULTDIV(1) /= 0)THEN
+ CALL PLCHHQ(.99,.032,CMULTDIV(1),.010,0.,+1.)
+ ENDIF
+ ENDIF
+ELSE
+!JD Juillet 2009
+ ILEN=0
+!JD Juillet 2009
+ DO J = 1,NSUPERDIA
+ IF(NOPE(J) /= 0) THEN
+ NOPEL=NOPEL+1
+ IF(NOPEL == 1)THEN
+ IL=LEN_TRIM(CFACT(J))
+
+!JD Juillet 2009
+ IF(IL > 0)THEN
+!JD Juillet 2009
+ YCAR200(1:IL)=CFACT(J)(1:IL)
+ ILEN=LEN_TRIM(YCAR200)
+ ILEN=ILEN+3
+!JD Juillet 2009
+ ENDIF
+!JD Juillet 2009
+ ELSE
+ IL=LEN_TRIM(CFACT(J))
+!JD Juillet 2009
+ IF(IL > 0)THEN
+!JD Juillet 2009
+ IF (NVERBIA >=5) THEN
+ print*, 'FACTIMP ',J,IL,ILEN,CFACT(J)
+ END IF
+ YCAR200(ILEN:ILEN-1+IL)=CFACT(J)(1:IL)
+ ILEN=LEN_TRIM(YCAR200)
+ ILEN=ILEN+3
+!JD Juillet 2009
+ ENDIF
+!JD Juillet 2009
+ ENDIF
+ IF(NMULTDIV(J) /= 0)THEN
+ ILEN=ILEN-2
+ IL=LEN_TRIM(CMULTDIV(J))
+ YCAR200(ILEN:ILEN-1+IL)=CMULTDIV(J)(1:IL)
+ ILEN=LEN_TRIM(YCAR200)
+ ILEN=ILEN+3
+ ENDIF
+ ENDIF
+ ENDDO
+!JD Juillet 2009
+ IF(ILEN > 3)THEN
+!JD Juillet 2009
+ ILEN=ILEN-3
+!JD Juillet 2009
+ ENDIF
+!JD Juillet 2009
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ if(nverbia >0)then
+ print *,' ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT ',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+ endif
+!JD Juillet 2009
+ IF(ILEN > 0)THEN
+!JD Juillet 2009
+ IF(CTYPE == 'MASK')THEN
+ IF(ILEN > 100)THEN
+ YCAR200(97:100)='....'
+ CALL PLCHHQ(.002,.93,YCAR200(1:100),.007,0.,-1.)
+ ELSE
+ CALL PLCHHQ(.002,.93,YCAR200(1:ILEN),.007,0.,-1.)
+ ENDIF
+ ELSE
+ IF(LVARNPVUSER)THEN
+ CALL PLCHHQ(.02,.935,YCAR200(1:ILEN),.007,0.,-1.)
+ ELSE
+ IF(ILEN > 100)THEN
+ J=INDEX(YCAR200(100-IL:100),')')
+ YCAR200(100-IL+J+1:100-IL+J+3)='...'
+ CALL PLCHHQ(.002,.93,YCAR200(1:100-IL+J+3),.007,0.,-1.)
+ ELSE
+ CALL PLCHHQ(.002,.93,YCAR200(1:ILEN),.007,0.,-1.)
+ ENDIF
+ ENDIF
+ ENDIF
+!JD Juillet 2009
+ ENDIF
+!JD Juillet 2009
+ENDIF
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE FACTIMP
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/formatxy.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/formatxy.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4b4f15d28547c03ea02d99c6609fdff41a5e36f9
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/formatxy.f90
@@ -0,0 +1,403 @@
+! ######spl
+ SUBROUTINE FORMATXY(PWL,PWR,PWW,PWT)
+! ####################################
+!
+!!**** *FORMATXY* -
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! MODIFIED (I. Mallet 06/02) PWB to PWW
+!! otherwise PWB is changed to 1 by cpp on HP
+!!
+!
+USE MODD_RESOLVCAR
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+!
+REAL :: PWL,PWR,PWW,PWT
+!
+!* 0.2 local variables
+!
+!
+INTEGER :: J
+CHARACTER(LEN=10) :: FORMAX, FORMAY
+CHARACTER(LEN=10) :: YFORMAX
+!
+!-------------------------------------------------------------------------------
+YFORMAX(1:LEN(YFORMAX))=' '
+IF(NHISTORY(NLOOPSUPER) == 3)THEN
+ DO J=1,MAX(1,NLOOPSUPER-1)
+ IF(NHISTORY(J) == 1)THEN
+ CALL GAGETC('XLF',YFORMAX)
+ print *,' ** formatxy FORMAX ',YFORMAX
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+!
+! PWR /= 0.
+! ******************************************************************
+ IF(PWR /= 0.)THEN
+! ******************************************************************
+ IF(LOG10(ABS(PWR)) >= 6. .OR. LOG10(ABS(PWR)) <= -1.)THEN
+
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(E8.2)'
+ ENDIF
+
+! ------------------------------------------------------------------
+! PWT /= 0.
+ IF(PWT /= 0.)THEN
+ FORMAY=' '
+ IF(LOG10(ABS(PWT)) >= 6. .OR. LOG10(ABS(PWT)) <= -1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+! CALL LABMOD('(E8.2)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(ABS(PWT-PWW) < 1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+! CALL LABMOD('(E8.2)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+! CALL LABMOD('(E8.2)','(F8.1)',0,0,10,10,0,0,0)
+ ENDIF
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! ------------------------------------------------------------------
+ ELSE
+! PWT == 0.
+ FORMAY=' '
+ IF(LOG10(ABS(PWW)) >= 6. .OR. LOG10(ABS(PWW)) <= -1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+! CALL LABMOD('(E8.2)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(ABS(PWT-PWW) < 1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+! CALL LABMOD('(E8.2)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+! CALL LABMOD('(E8.2)','(F8.1)',0,0,10,10,0,0,0)
+ ENDIF
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+ ENDIF
+! ------------------------------------------------------------------
+
+ ELSE
+
+ IF(ABS(PWR-PWL) < 1.)THEN
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F8.2)'
+ ENDIF
+! ------------------------------------------------------------------
+! PWT /= 0.
+ IF(PWT /= 0.)THEN
+ FORMAY=' '
+ IF(LOG10(ABS(PWT)) >= 6. .OR. LOG10(ABS(PWT)) <= -1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+! CALL LABMOD('(F8.2)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(ABS(PWT-PWW) < 1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+! CALL LABMOD('(F8.2)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+! CALL LABMOD('(F8.2)','(F8.1)',0,0,10,10,0,0,0)
+ ENDIF
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! ------------------------------------------------------------------
+ ELSE
+! PWT == 0.
+ FORMAY=' '
+ IF(LOG10(ABS(PWW)) >= 6. .OR. LOG10(ABS(PWW)) <= -1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+! CALL LABMOD('(F8.2)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(ABS(PWT-PWW) < 1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+! CALL LABMOD('(F8.2)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+! CALL LABMOD('(F8.2)','(F8.1)',0,0,10,10,0,0,0)
+ ENDIF
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+ ENDIF
+! ------------------------------------------------------------------
+
+ ELSE
+
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F8.1)'
+ ENDIF
+
+! ------------------------------------------------------------------
+! PWT /= 0.
+ IF(PWT /= 0.)THEN
+ FORMAY=' '
+ IF(LOG10(ABS(PWT)) >= 6. .OR. LOG10(ABS(PWT)) <= -1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+! CALL LABMOD('(F8.1)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(ABS(PWT-PWW) < 1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+! CALL LABMOD('(F8.1)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+! CALL LABMOD('(F8.1)','(F8.1)',0,0,10,10,0,0,0)
+ ENDIF
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+
+! ------------------------------------------------------------------
+ ELSE
+! PWT == 0.
+ FORMAY=' '
+ IF(LOG10(ABS(PWW)) >= 6. .OR. LOG10(ABS(PWW)) <= -1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+! CALL LABMOD('(F8.1)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(ABS(PWT-PWW) < 1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+! CALL LABMOD('(F8.1)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+! CALL LABMOD('(F8.1)','(F8.1)',0,0,10,10,0,0,0)
+ ENDIF
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+ ENDIF
+! ------------------------------------------------------------------
+ ENDIF
+
+ ENDIF
+
+! ******************************************************************
+ ELSE
+! ******************************************************************
+! PWR = 0
+ IF(LOG10(ABS(PWR-PWL)) >= 6. .OR. LOG10(ABS(PWR-PWL)) <= -1.)THEN
+
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(E8.2)'
+ ENDIF
+ FORMAY=' '
+ IF(LOG10(ABS(PWT-PWW)) >= 6. .OR. LOG10(ABS(PWT-PWW)) <= -1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+! CALL LABMOD('(E8.2)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE IF(ABS(PWT-PWW) <1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+! CALL LABMOD('(E8.2)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+! CALL LABMOD('(E8.2)','(F8.1)',0,0,10,10,0,0,0)
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+
+ ELSE IF(ABS(PWR-PWL) < 1.)THEN
+
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F8.2)'
+ ENDIF
+ FORMAY=' '
+ IF(LOG10(ABS(PWT-PWW)) >= 6. .OR. LOG10(ABS(PWT-PWW)) <= -1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+! CALL LABMOD('(F8.2)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE IF(ABS(PWT-PWW) <1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+! CALL LABMOD('(F8.2)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+! CALL LABMOD('(F8.2)','(F8.1)',0,0,10,10,0,0,0)
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+
+ ELSE
+
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F8.1)'
+ ENDIF
+ FORMAY=' '
+ IF(LOG10(ABS(PWT-PWW)) >= 6. .OR. LOG10(ABS(PWT-PWW)) <= -1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+! CALL LABMOD('(F8.1)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE IF(ABS(PWT-PWW) <1.)THEN
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+! CALL LABMOD('(F8.1)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+! CALL LABMOD('(F8.1)','(F8.1)',0,0,10,10,0,0,0)
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+
+ ENDIF
+
+! ******************************************************************
+ ENDIF
+! ******************************************************************
+! Prise en compte d'une superposition d'un PH=CV+K sur une CV pour des
+! labels interieurs
+IF(NHISTORY(NLOOPSUPER) == 3)THEN
+ DO J=1,MAX(1,NLOOPSUPER-1)
+ IF(NHISTORY(J) == 1)THEN
+ CALL LABMOD(YFORMAX,FORMAY,0,0,NSZLBX,NSZLBY,-25,0,0)
+! CALL LABMOD(YFORMAX,FORMAY,0,0,10,10,-25,0,0)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+!!----------------------------------------------------------------------------
+RETURN
+!
+!* 4. EXIT
+! ----
+!
+END SUBROUTINE FORMATXY
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/genformat_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/genformat_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9bd3359c52137310598fc093f0bcfac637a120d5
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/genformat_fordiachro.f90
@@ -0,0 +1,106 @@
+! ######spl
+ SUBROUTINE GENFORMAT_FORDIACHRO(PCLV,HLLBS)
+! ###########################################
+!
+!!**** *GENFORMAT* - Determination du format des valeurs d'isocontours en
+! legende
+!!
+!! PURPOSE
+!! -------
+! Pour une valeur d'isocontour donnee, recherche le format le mieux
+! adapte pour cette valeur et l'ecrit dans une chaine de caracteres
+! suivant le dit format
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 25/01/95
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+COMMON/GENF/NBCU
+!
+!* 0.1 Dummy arguments
+!
+
+REAL :: PCLV
+REAL :: ZEPS
+CHARACTER(LEN=*) :: HLLBS
+!
+!* 0.2 local variables
+!
+REAL :: ZALOG10
+INTEGER :: I7,I8, NBCU
+!
+!-------------------------------------------------------------------------------
+!print *,' ENTREE genformat PCLV HLLBS',PCLV,HLLBS
+I7=0; I8=0
+ZEPS=1.E-30
+HLLBS(1:LEN(HLLBS))=' '
+IF(PCLV == 0. .OR. (ABS(PCLV) >=0.01 .AND. ABS(PCLV) <= 1.))THEN
+ WRITE(HLLBS,'(F6.3)')PCLV
+ I7=6
+ELSE
+ ZALOG10=ALOG10(ABS(PCLV))
+ IF(ZALOG10 < 0.)THEN
+ IF(PCLV >= 0.)THEN
+ WRITE(HLLBS,'(E7.2)')PCLV
+ I7=7
+ ELSE
+ IF(ABS(ZALOG10) <= 10)THEN
+ WRITE(HLLBS,'(E7.2E1)')PCLV
+ I7=7
+ ELSE
+ WRITE(HLLBS,'(E8.2)')PCLV
+ I8=8
+ ENDIF
+ ENDIF
+ ELSE
+ IF(ZALOG10 >= 5.)THEN
+ IF(PCLV >= 0.)THEN
+ WRITE(HLLBS,'(E7.2)')PCLV
+ I7=7
+ ELSE
+ WRITE(HLLBS,'(E8.2)')PCLV
+ I8=8
+ ENDIF
+ ENDIF
+ IF(ZALOG10 >= 4. .AND. ZALOG10 < 5.)THEN
+ WRITE(HLLBS,'(F7.0)')PCLV
+ I7=7
+ ENDIF
+ IF(ZALOG10 < 4)THEN
+ IF(ZALOG10 >= 3.-ZEPS .AND. ZALOG10 < 4.)WRITE(HLLBS,'(F6.0)')PCLV
+ IF(ZALOG10 >= 2.-ZEPS .AND. ZALOG10 < 3.)WRITE(HLLBS,'(F6.1)')PCLV
+ IF(ZALOG10 >= 1.-ZEPS .AND. ZALOG10 < 2.)WRITE(HLLBS,'(F6.2)')PCLV
+ IF(ZALOG10 >= 0. .AND. ZALOG10 < 1.-ZEPS)WRITE(HLLBS,'(F6.3)')PCLV
+ I7=6
+ ENDIF
+ END IF
+END IF
+HLLBS=ADJUSTL(HLLBS)
+!print *,' SORTIE genformat PCLV HLLBS',PCLV,HLLBS
+NBCU=MAX(I7,I8)
+!print *,' NBCU ',NBCU
+RETURN
+END SUBROUTINE GENFORMAT_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/image_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/image_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..14c67b0d852a19915381689df77ffd7b3566502f
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/image_fordiachro.f90
@@ -0,0 +1,3033 @@
+! ######spl
+ SUBROUTINE IMAGE_FORDIACHRO(PTAB,KLREF,PTABINT,KNHI,KNDOT,HTEXTE)
+! #################################################################
+!
+!!**** *IMAGE_FORDIACHRO* - Isoncontour plots manager for horizontal
+!! cross-sections
+!!
+!! PURPOSE
+!! -------
+! Calls the NCAR contour routines and defines the display environment
+! for the horizontal cross-section case
+!
+!!** METHOD
+!! ------
+!! First, the field is checked for extrema, and the plot geometry is
+!! generated, drawing a cartographic stencil and the continental/state
+!! outlines when required by the 'LCARTESIAN' parameters. Next, NCAR
+!! variables are set according to the user requests, and contours are
+!! drawn by a call to Conpack utilities (CPRECT/CPCLDR). If a 'Z' section
+!! is requested, the topography outlines are examined to mask the contours
+!! where map altitude intercepts terrain.
+!!
+!! Notice that a TRACE-provided CPMPXY routine is used within the NCAR
+!! Conpack call to map the contoured array matrix onto the stretched model
+!! cartographic space. The plotted data are NOT interpolated onto a regular
+!! grid before plotting, instead a coordinate stretching technique is used.
+!! Basically, the contour calculation are made in a "grid index space"
+!! where the meshsize is uniform and equal to 1 between successive model
+!! points (this corresponds to the x_hat_* and y_hat_* coordinates of the
+!! Meso-NH technical specification book, page 41). In this "grid index space"
+!! contourlines points are located by two floating-point index coordinates
+!! vaying between 1 and the corresponding array dimension. This "grid index"
+!! coordinates are latter converted back to screen coordinates by CPMPXY to
+!! obtain a correct display.
+!!
+!! EXTERNAL
+!! --------
+!! GMNMX : computes min, max and contour increment for current field
+!! BCGRD : when a cartographic projection applies, defines displayed
+!! window and draws the continent/state outlines
+!! DEFENETRE : when cartesian geometry applies, defines the display window
+!! TRACEXY : draws the model gridpont stencil as a dashline overlay
+!!
+!! CPSETI ! INTEGER !
+!! CPSETR ! : sets the value of a NCAR parameter, REEL !
+!! CPSETC ! CHARACTER ! NCAR
+!! !
+!! CPGETI ! INTEGER !
+!! CPGETR ! : gets the value of a NCAR parameter, REEL !
+!! CPGETC ! CHARACTER !
+!! !
+!! CPRECT : Conpack initialization !
+!! CPPKCL : contour level selection !
+!! CPCLDR : draws contours ! Routines
+!! GSLWSC : sets line width !
+!! !
+!! ARINAM : initialize the contour calculation as a subset !
+!! of areas, which may be adressed individually to !
+!! modify their display characteristics (used for !
+!! topography masking here). !
+!! ARSCAM : scans the plotting domain and defines the !
+!! different areas, then performs the processing !
+!! defined in the SFILL routine (here, hatch fill) !
+!! CPCLAM : adds contour in a previously defined area ! NCAR
+!! !
+!! SET : defines the display window in normalized and !
+!! user NCAR coordinates !
+!! GETSET : retrieves the normalized and user NCAR !
+!! coordinates of a previously used window ! Routines
+!! PLCHHQ : prints high-quality character strings !
+!! GSCLIP : clips items getting out of the drawing window !
+!!
+!! CPMPXY : TRACE provided FORTRAN-77 routine directly called
+!! within CONPACK to map the array space onto the
+!! cartographic space
+!! SFILL : TRACE provided FORTAN-77 routine directly called
+!! CONPACK to define the hatched area used to locate
+!! points where the plot level intercepts topography
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_TITLE : Declares heading variables for the plots (TRACE)
+!! NCONT : Current plot number
+!! CLEGEND: Current plot heading title
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX,XXY : coordinate values for all the MESO-NH grids
+!! XXZS : topography values for all the MESO_NH grids
+!!
+!! Module MODD_CONF : declares configuration variables of all models
+!! LCARTESIAN: Logical for cartesian geometry :
+!! .TRUE. = cartesian geometry
+!! .FALSE. = conformal projection
+!!
+!! Module MODD_NMGRID : declares global variable NMGRID
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!! Module MODN_PARA : defines NAM_DOMAIN_POS namelist
+!! LHORIZ : must be .TRUE. to perform horizontal cross esctions
+!! LVERTI : must be .FALSE. to perform horizontal cross sections
+!! Module MODD_DIM1 : Contains dimensions
+!! NIMAX, NJMAX : x, and y array dimensions
+!! NIINF, NISUP : Lower and upper array bounds in x direction
+!! NJINF, NJSUP : Lower bound and upper bound in y direction
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!! NIOFFD : Label normalisation (=0 none, =/=0 active)
+!! NULBLL : Nb of contours between 2 labelled contours
+!! NIOFFM : =0 --> message at picture bottom
+!! =/= 0 --> no message
+!! NIOFFP : Special point value detection
+!! (=0 none, =/=0 active)
+!! CTYPHOR : Horizontal cross-section type
+!! (='K' --> model level section;
+!! ='Z' --> constant-altitude section;
+!! ='P' --> isobar section (planned)
+!! ='T' --> isentrope section (planned)
+!! XSPVAL : Special value
+!! XSIZEL : Label size
+!! LXY : If =.TRUE., plots a grid-mesh stencil background
+!!
+!! Module MODD_OUT : Defines a log. unit for printing
+!! NIMAXT : x-size of the displayed section of the model array
+!! NJMAXT : y-size of the displayed section of the model array
+!!
+!! Module MODD_SUPER : defines plot overlay control variables
+!! LSUPER : =.TRUE. --> plot overlay is active
+!! =.FALSE. --> plot overlay is not active
+!! NSUPER : Rank of the current plot in the overlay
+!! sequence. The initial plot is rank 1.
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 06/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+#ifdef NAGf95
+USE F90_UNIX ! for FLUSH and GETENV
+#endif
+
+USE MODD_TITLE
+USE MODD_MASK3D
+USE MODD_COORD
+USE MODD_NMGRID
+USE MODD_CONF
+USE MODN_PARA
+USE MODN_NCAR
+USE MODD_TIME
+USE MODD_TIME1
+USE MODD_OUT
+USE MODD_SUPER
+USE MODD_LUNIT1
+USE MODD_RESOLVCAR
+USE MODD_HACH
+USE MODD_TIT
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODI_READMNMXINT_ISO
+USE MODI_READREFINT_ISO
+USE MODI_READXISOLEVP
+USE MODD_CTL_AXES_AND_STYL
+USE MODD_RSISOCOL
+!
+USE MODI_CREATLINK
+USE MODI_WRITEDIR
+!
+IMPLICIT NONE
+!
+! 0.0 TRACE interface with the "CPMPXY" routine of the NCAR package
+!
+! NOTICE: The CPMPXY and the NCAR graphical utilities are NOT written
+! ------ in Fortran 90, but in Fortran 77.. This sub-section of TRACE
+! does not follow the Meso-NH usual rules: it has to be made using
+! a COMMON stack with static memory allocation of XZZXX and
+! XZZXY arrays.
+!
+COMMON/TEMH/XZZXX,XZZXY,NIIMAX,NIJMAX
+COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+COMMON/COLAREA/ICOL(300)
+COMMON/HACHAREA/IHACH(300)
+#include "big.h"
+!
+REAL,DIMENSION(N2DVERTX) :: XZZXX
+REAL,DIMENSION(N2DVERTX) :: XZZXY
+INTEGER :: NIIMAX, NIJMAX
+LOGICAL :: LVERT, LHOR, LPT, LXABS
+INTEGER :: ICOL
+INTEGER :: IHACH
+!
+!* 0.1 Declarations of dummy arguments and results
+!
+INTEGER :: KNHI ! Extrema processing option
+INTEGER :: KNDOT ! Line style option
+INTEGER :: KLREF ! Cross-section altitude (or Model Level
+ ! or Pressure depending on user's vertical
+ ! coordinate choice)
+
+CHARACTER(LEN=*) :: HTEXTE ! Plot heading with variable name
+
+REAL :: PTABINT ! Contour increments for current plot
+
+REAL,DIMENSION(:,:) :: PTAB ! Variable array to be plotted
+
+!
+!* 0.2 Local variables
+!
+INTEGER :: IM, IL, ILE
+INTEGER :: J, JJ, JI, JU, JK
+INTEGER :: JLBL, JL
+INTEGER :: I, ICLD, INCL
+INTEGER :: INBC
+INTEGER :: INBX,INBY
+INTEGER,SAVE :: IDX
+INTEGER,SAVE :: INBCT
+INTEGER,SAVE :: ILUCOL, IRESP
+INTEGER,DIMENSION(:),ALLOCATABLE :: ICOL2
+INTEGER :: ILENT
+INTEGER :: ISTA, IER, IWK, INB, INBB
+INTEGER :: INUM, ILOOP, JLOOPI, JLOOPJ, IDEB, IFIN, II
+INTEGER,SAVE :: IH, IHT
+INTEGER,DIMENSION(32):: INDHACHREF=(/0,54,52,60,14,59,58,1,57,56,55,54,53,52,51,50, &
+ 1,49,48,47,46,45,44,43,42,41,40,39,38,37,36,35/)
+#ifdef RHODES
+INTEGER :: ISTAF
+#endif
+CHARACTER(LEN=80) :: YCAR80
+CHARACTER(LEN=320) :: YCAR320
+CHARACTER(LEN=70) :: YPLANH
+CHARACTER(LEN=100) :: YTEM
+CHARACTER(LEN=40) :: YTEM40
+CHARACTER(LEN=8),DIMENSION(300) :: YLLBS
+CHARACTER(LEN=32),SAVE :: YNAMTABCOL
+CHARACTER(LEN=32) :: YLBL
+CHARACTER(LEN=32) :: YTEXT
+CHARACTER(LEN=20) :: YCAR20
+CHARACTER(LEN=4) :: YC4, YC42
+CHARACTER(LEN=1) :: YREP
+
+LOGICAL :: GISO
+
+REAL,DIMENSION(300) :: ZLEV, ZISOLEVP
+REAL :: ZTABMIN, ZTABMAX, ZTABINT
+REAL :: ZTABMN, ZTABMX
+REAL :: ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+REAL :: ZZSPVAL, ZISO
+REAL :: ZLREF,ZWIDTH
+REAL :: ZCLV
+REAL :: RED,GREEN,BLUE
+REAL :: ZINTERV
+REAL :: ZMIN, ZMAX
+REAL,SAVE :: ZSC
+REAL,SAVE :: ZVLDEF, ZVRDEF, ZVBDEF, ZVTDEF
+REAL,SAVE :: ZD, ZF, ZVERA, ZINTE
+REAL :: ZX, ZY
+REAL :: ZXPOSTITT1, ZXYPOSTITT1
+REAL :: ZXPOSTITT2, ZXYPOSTITT2
+REAL :: ZXPOSTITT3, ZXYPOSTITT3
+REAL :: ZXPOSTITB1, ZXYPOSTITB1
+REAL :: ZXPOSTITB2, ZXYPOSTITB2
+REAL,SAVE :: ZXPOSTITB3, ZXYPOSTITB3
+REAL :: ZSZTITVAR1, ZSZTITVAR
+REAL,DIMENSION(5) :: ZX5, ZY5
+REAL :: ZEPX, ZEPY
+!
+! 0.3 Work arrays for NCAR
+!
+! See aforementioned notice. The dimensions of these arrays are
+! subject to possible tuning, but have to be prescribed. Add
+! extra size if necessary.
+!
+
+INTEGER :: ID, ICL, III
+INTEGER,PARAMETER :: JPLRWK=50000, JPLIWK=50000
+INTEGER,PARAMETER :: JPMAP=8000000, JPAREAGRP=300, JPWRK=50000
+
+INTEGER,DIMENSION(JPLIWK) :: IWRK
+INTEGER,DIMENSION(JPMAP) :: IIMAP
+INTEGER,DIMENSION(JPAREAGRP):: IAREA, IGRP
+
+REAL,DIMENSION(JPLRWK) :: ZRWRK
+REAL,DIMENSION(JPWRK) :: ZXWRK, ZYWRK
+!
+! SFILL subroutine declared as external provides area control
+! in some parts of the contour plot.
+!
+EXTERNAL SFILL
+EXTERNAL SFILLH
+EXTERNAL CCOLR
+!
+!---------------------------------------------------------------------------
+!
+!* 1. DISPLAY ENVIRONMENT SETUP
+! -------------------------
+!
+! Recuperation du nom du processus dans YTEXT
+!
+NLUOUT=6
+YTEXT(1:LEN(YTEXT))=' '
+HTEXTE=ADJUSTL(HTEXTE)
+DO JJ=1,LEN_TRIM(HTEXTE)
+ IF(HTEXTE(JJ:JJ) == ' ')THEN
+ YTEXT(1:JJ-1)=HTEXTE(1:JJ-1)
+ EXIT
+ ENDIF
+ IF(JJ == LEN_TRIM(HTEXTE))THEN
+ YTEXT=HTEXTE
+ ENDIF
+ENDDO
+YTEXT=ADJUSTL(YTEXT)
+!
+!* 1.1 Size computations and gridpoint location loading for NCAR
+!
+IM=SIZE(PTAB,1)
+IL=SIZE(PTAB,2)
+ZTABINT=PTABINT
+LHORIZ=.TRUE.; LVERTI=.FALSE.
+LVERT=LVERTI
+LHOR=LHORIZ
+LPT=LPXT
+! Min and max
+ZMIN=PTAB(IM/2,IL/2); ZMAX=PTAB(IM/2,IL/2)
+IF(ZMIN == XSPVAL)ZMIN=1.E16
+IF(ZMAX == XSPVAL)ZMAX=-1.E16
+!ZMIN=999999.; ZMAX=-999999.
+if(nverbia > 0)then
+ print *,' ** image AV DO JJ=1,IL'
+endif
+DO JJ=1,IL
+ DO JI=1,IM
+ IF(PTAB(JI,JJ) /= 888. .AND. PTAB(JI,JJ) /= XSPVAL)THEN
+ IF(PTAB(JI,JJ) < ZMIN)ZMIN=PTAB(JI,JJ)
+ IF(PTAB(JI,JJ) > ZMAX)ZMAX=PTAB(JI,JJ)
+ ENDIF
+ ENDDO
+ENDDO
+YLBL(1:5)='(Min:'
+WRITE(YLBL(6:15),'(E10.3)')ZMIN
+YLBL(16:21)=', Max:'
+WRITE(YLBL(22:31),'(E10.3)')ZMAX
+YLBL(32:32)=')'
+
+!
+
+!NIIMAX=NIMAXT
+!NIJMAX=NJMAXT
+NIIMAX=SIZE(PTAB,1)
+NIJMAX=SIZE(PTAB,2)
+XZZXX(1:NIIMAX)=XXX(NIINF:NISUP,NMGRID)
+XZZXY(1:NIJMAX)=XXY(NJINF:NJSUP,NMGRID)
+!
+
+IF(LPRINT)THEN
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ ILOOP=SIZE(PTAB,1)/5
+
+!!Octobre 2001 Cas des trajectoires ??
+ print *,' ** image, ILOOP,NLOOPT, SIZE(PTAB,1) ',ILOOP,NLOOPT, SIZE(PTAB,1)
+!!Octobre 2001
+ IF(ILOOP * 5 < SIZE(PTAB,1))ILOOP=ILOOP+1
+ WRITE(INUM,'(''CH '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'')')CGROUP,&
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ IF(LMINUS .OR. LPLUS)THEN
+ WRITE(INUM,'(A55,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITB3(1:55)
+ ELSE
+ WRITE(INUM,'(A40,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITGAL
+ ENDIF
+ WRITE(INUM,'(''niinf'',i4,'' njinf'',i4,'' nisup'',i4,'' njsup'',i4,&
+&'' '',A1,'' '',i6)')&
+ &NIINF,NJINF,NISUP,NJSUP,CTYPHOR,KLREF
+ WRITE(INUM,'(''NBVAL en I '',i4,'' NBVAL en J '',i4,'' iter'',i3)') &
+ &NISUP-NIINF+1,NJSUP-NJINF+1,ILOOP
+! JUin 2001 Ecriture des dates (Demande G.Jaubert ) si LPRDAT=T
+ IF(LPRDAT)THEN
+ IF(.NOT.ALLOCATED(XPRDAT))THEN
+ print *,'**IMAGE XPRDAT NON ALLOUE.Dates non ecrites ds FICVAL .Prevenir J.Duron'
+ ELSE
+ WRITE(INUM,'(1X,75(1H*))')
+ WRITE(INUM,'(1X,'' Dates courante * modele * experience * segment'')')
+ WRITE(INUM,'(1X,'' J An M J Sec. * An M J Sec. * An M J Sec. * An M J Sec.'')')
+ WRITE(INUM,'(1X,75(1H*))')
+ DO J=1,SIZE(XPRDAT,2)
+ WRITE(INUM,'(1X,I3,1X,3(I4,I3,I3,I6,'' *''),I4,I3,I3,I6)')J,INT(XPRDAT(:,J))
+ ENDDO
+ ENDIF
+ ENDIF
+! JUin 2001 Ecriture des dates
+ DO JLOOPI=1,ILOOP
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=5
+ IDEB=IDEB+NIINF-1; IFIN=IFIN+NIINF-1
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+5
+ ENDIF
+ IF(JLOOPI == ILOOP)THEN
+ IFIN=SIZE(PTAB,1)+NIINF-1
+ ENDIF
+
+ WRITE(INUM,'(1X,78(1H*))')
+ WRITE(INUM,'('' J I-> '',3X,I4,6X,4(6X,I4,6X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'(''.'',78(1H*))')
+ DO JLOOPJ=SIZE(PTAB,2),1,-1
+ WRITE(INUM,'(I4,2X,5(1X,E14.7))')JLOOPJ+NJINF-1,(PTAB(II,JLOOPJ),II=IDEB-NIINF+1,IFIN-NIINF+1)
+! WRITE(INUM,'(I3,2X,5E15.8)')JLOOPJ+NJINF-1,(PTAB(II,JLOOPJ),II=IDEB-NIINF+1,IFIN-NIINF+1)
+ ENDDO
+ WRITE(INUM,'(1X,78(1H*))')
+ ENDDO
+ENDIF
+IF(LPRINTXY)THEN
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ WRITE(INUM,'(''CH XY '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'')')CGROUP,&
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ IF(LMINUS .OR. LPLUS)THEN
+ WRITE(INUM,'(A55,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITB3(1:55)
+ ELSE
+ WRITE(INUM,'(A40,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITGAL
+ ENDIF
+ WRITE(INUM,'(''niinf'',i4,'' njinf'',i4,'' nisup'',i4,'' njsup'',i4,&
+&'' '',A1,'' '',i6)')&
+ &NIINF,NJINF,NISUP,NJSUP,CTYPHOR,KLREF
+ WRITE(INUM,'(''NBVAL en I '',i4,'' NBVAL en J '',i4)') &
+ &NISUP-NIINF+1,NJSUP-NJINF+1
+
+ II=MAX(SIZE(PTAB,1),SIZE(PTAB,2))
+ WRITE(INUM,'(1X,73(1H*))')
+ WRITE(INUM,'(26X,''X'',38X,''Y'')')
+ WRITE(INUM,'(1X,73(1H*))')
+ DO JLOOPJ=1,II
+ IF(JLOOPJ ==1)THEN
+ YC4=' '
+ YC42=' '
+ WRITE(YC4,'(I4,'')'')')NIINF
+ WRITE(YC42,'(I4,'')'')')NJINF
+ WRITE(INUM,'(''NIINF('',A4,I4,5X,E15.8,5X,''NJINF('',A4,I4,5X,E15.8)') &
+ YC4,JLOOPJ,XZZXX(JLOOPJ),YC42,JLOOPJ,XZZXY(JLOOPJ)
+ YC4=' '
+ YC42=' '
+ WRITE(YC4,'(I4,'')'')')NISUP
+ WRITE(YC42,'(I4,'')'')')NJSUP
+ ELSE
+ IF(SIZE(PTAB,1) > SIZE(PTAB,2))THEN
+ IF(JLOOPJ < SIZE(PTAB,2))THEN
+ WRITE(INUM,'(5X,I9,5X,E15.8,5X,5X,I9,5X,E15.8)')JLOOPJ,XZZXX(JLOOPJ), &
+ JLOOPJ,XZZXY(JLOOPJ)
+ ELSE IF(JLOOPJ == SIZE(PTAB,1))THEN
+ WRITE(INUM,'(''NISUP('',A4,I4,5X,E15.8)')YC4,JLOOPJ,XZZXX(JLOOPJ)
+ WRITE(INUM,'(1X,73(1H*))')
+ ELSE IF(JLOOPJ == SIZE(PTAB,2))THEN
+ WRITE(INUM,'(5X,I9,5X,E15.8,5X,''NJSUP('',A4,I4,5X,E15.8)')&
+ JLOOPJ,XZZXX(JLOOPJ), &
+ YC42,JLOOPJ,XZZXY(JLOOPJ)
+ ELSE IF(JLOOPJ > SIZE(PTAB,2))THEN
+ WRITE(INUM,'(5X,I9,5X,E15.8)')JLOOPJ,XZZXX(JLOOPJ)
+ ENDIF
+ ELSE IF(SIZE(PTAB,2) > SIZE(PTAB,1))THEN
+ IF(JLOOPJ < SIZE(PTAB,1))THEN
+ WRITE(INUM,'(5X,I9,5X,E15.8,5X,5X,I9,5X,E15.8)')JLOOPJ,XZZXX(JLOOPJ), &
+ JLOOPJ,XZZXY(JLOOPJ)
+ ELSE IF(JLOOPJ == SIZE(PTAB,2))THEN
+ WRITE(INUM,'(29X,5X,5X,''NJSUP('',A4,I4,5X,E15.8)') &
+ YC42,JLOOPJ,XZZXY(JLOOPJ)
+ WRITE(INUM,'(1X,73(1H*))')
+ ELSE IF(JLOOPJ > SIZE(PTAB,1))THEN
+ WRITE(INUM,'(29X,5X,5X,5X,I9,5X,E15.8)')JLOOPJ,XZZXY(JLOOPJ)
+ ELSE
+ WRITE(INUM,'(''NISUP('',A4,I4,5X,E15.8,5X,5X,I9,5X,E15.8)') &
+ YC4,JLOOPJ,XZZXX(JLOOPJ), &
+ JLOOPJ,XZZXY(JLOOPJ)
+ ENDIF
+ ELSE
+ IF(JLOOPJ == SIZE(PTAB,2))THEN
+ WRITE(INUM,'(''NISUP('',A4,I4,5X,E15.8,5X,''NJSUP('',A4,I4,5X,E15.8)') &
+ YC4,JLOOPJ,XZZXX(JLOOPJ), &
+ YC42,JLOOPJ,XZZXY(JLOOPJ)
+ WRITE(INUM,'(1X,73(1H*))')
+ ELSE
+ WRITE(INUM,'(5X,I9,5X,E15.8,5X,5X,I9,5X,E15.8)')JLOOPJ,XZZXX(JLOOPJ), &
+ JLOOPJ,XZZXY(JLOOPJ)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ENDIF
+!
+!* 1.2 Scans for data extrema. Selects display window.
+! If required by LCARTESIAN: selects cartographic projection
+! and draws coastlines.
+! If required by LXY: draws a gripoint stencil over the contours.
+!
+
+! Modifs for diachro
+!
+!CALL GMNMX(ZTABMIN,ZTABMAX,ZTABINT)
+
+if(nverbia > 0)then
+ print *,' ** image IF(NIMNMX == '
+endif
+IF(NIMNMX == 0 .OR. NIMNMX == 1)THEN
+ LISOK=.FALSE.
+ ZTABMIN=0.; ZTABMAX=0.
+ CALL READMNMXINT_ISO(NIMNMX,YTEXT(1:LEN_TRIM(YTEXT)),ZTABMIN,ZTABMAX,ZTABINT)
+
+ELSE IF(NIMNMX == 2)THEN
+ ZISOLEVP(:)=9999.
+ CALL READXISOLEVP(YTEXT(1:LEN_TRIM(YTEXT)),ILE,ZISOLEVP)
+ IF(NVERBIA > 5)THEN
+ print *,' IMAGE YTEXT,ILE,ZISOLEVP ',YTEXT(1:LEN_TRIM(YTEXT)),ILE,ZISOLEVP(1:ILE)
+ ENDIF
+
+ELSE IF (NIMNMX==3) THEN ! compute contour values from XISOREF and XDIAINT
+ ZISOLEVP(:)=9999.
+ ZTABMN=MINVAL(PTAB,MASK=PTAB/=XSPVAL)
+ ZTABMX=MAXVAL(PTAB,MASK=PTAB/=XSPVAL)
+ CALL READREFINT_ISO(YTEXT(1:LEN_TRIM(YTEXT)),ZTABMN,ZTABMX,ZTABINT,ZISOLEVP)
+ENDIF
+
+IF(LCARTESIAN)THEN
+ ZVLDEF=.1; ZVRDEF=.9; ZVBDEF=.1; ZVTDEF=.9
+ELSE
+ ZVLDEF=.05; ZVRDEF=.95; ZVBDEF=.05; ZVTDEF=.95
+ENDIF
+XLWIDTH=XLWDEF
+IF(LSUPER)THEN
+ NSUPER=NSUPER+1
+ SELECT CASE(NSUPER)
+ CASE(1)
+ IF(XLW >= 0)THEN
+ XLWIDTH=XLW
+ ENDIF
+ IF(XLW1 >= 0)THEN
+ XLWIDTH=XLW1
+ ENDIF
+
+ IH=0; IHT=0
+
+ IF(LHACH2 .AND. LHACH3 .AND. LHACH4)THEN
+ IHT=3
+ ELSE IF((LHACH2 .AND. LHACH3 .AND. .NOT.LHACH4) .OR. &
+ (LHACH2 .AND. LHACH4 .AND. .NOT.LHACH3) .OR. &
+ (LHACH3 .AND. LHACH4 .AND. .NOT.LHACH2))THEN
+ IHT=2
+ ELSE IF((LHACH2 .AND. .NOT.LHACH3 .AND. .NOT.LHACH4) .OR. &
+ (LHACH3 .AND. .NOT.LHACH2 .AND. .NOT.LHACH4) .OR. &
+ (LHACH4 .AND. .NOT.LHACH2 .AND. .NOT.LHACH3))THEN
+ IHT=1
+ ENDIF
+
+ CASE(2)
+ IF(XLW2 >= 0)THEN
+ XLWIDTH=XLW2
+ ENDIF
+ CASE(3)
+ IF(XLW3 >= 0)THEN
+ XLWIDTH=XLW3
+ ENDIF
+ CASE(4)
+ IF(XLW4 >= 0)THEN
+ XLWIDTH=XLW4
+ ENDIF
+ END SELECT
+ IF(NSUPER == 1)THEN
+ IF(.NOT.LCARTESIAN)CALL BCGRD_FORDIACHRO(1)
+ IF(LCARTESIAN)CALL DEFENETRE
+ END IF
+ELSE
+ IF(XLW >= 0)THEN
+ XLWIDTH=XLW
+ ENDIF
+ IF(XLW1 >= 0)THEN
+ XLWIDTH=XLW1
+ ENDIF
+ IH=0; IHT=0
+ IF(.NOT.LCARTESIAN)CALL BCGRD_FORDIACHRO(1)
+ IF(LCARTESIAN)CALL DEFENETRE
+END IF
+!
+!IF(LXY)THEN
+! CALL GSCLIP(0)
+! CALL TRACEXY
+!END IF
+!
+if(nverbia > 0)then
+ print *,' ** image AV CALL GSLWSC(1.)'
+endif
+CALL GSLWSC(1.)
+!CALL CPSETI('CFC',1)
+!
+!
+!* 1.3 Selects contour range and increment according to NIMNMX
+!
+SELECT CASE(NIMNMX)
+
+ CASE(-1) ! Fully automatic scanning
+ CALL CPSETI('CLS',+16)
+ IF((LHACH1 .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))) .OR. &
+ (LHACH2 .AND. NSUPER == 2) .OR. &
+ (LHACH3 .AND. NSUPER == 3) .OR. &
+ (LHACH4 .AND. NSUPER == 4))CALL CPSETI('CLS',+7)
+ CALL CPSETR('CIS',-ZTABINT)
+
+ CASE(0) ! Automatic range and given increment
+ CALL CPSETI('CLS',16)
+ CALL CPSETR('CIS',ZTABINT)
+ CALL CPSETI('LIS',NULBLL+1)
+ CALL CPSETR('CMN',10000000000.)
+! CALL CPSETR('CMN',MAXVAL(PTAB))
+ CALL CPSETR('CMX',1000000000.)
+! CALL CPSETR('CMX',MINVAL(PTAB))
+
+ CASE(1) ! Given range and increment
+ IF(ZTABMAX == ZTABMIN)THEN
+ ICL=1
+ CALL CPSETI('NCL',ICL)
+ ELSE
+ ICL=NINT((ZTABMAX-ZTABMIN)/ZTABINT)
+ IF(NVERBIA >= 5)THEN
+ print *,' ztabmin max, int,ICL ',ZTABMIN,ZTABMAX,ZTABINT,ICL
+ ENDIF
+! mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
+ IF(ZTABMIN + ICL*ZTABINT <= ZTABMAX)ICL=ICL+1
+ IF(NVERBIA >= 5)THEN
+ print *,' ztabmin max, int,ICL ',ZTABMIN,ZTABMAX,ZTABINT,ICL
+ ENDIF
+! IF(ZTABMIN + ICL*ZTABINT < ZTABMAX)ICL=ICL+1
+ CALL CPSETI('NCL',ICL)
+! mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
+! IF((LCOLAREA .OR. LHACH1) .AND. (.NOT.LSUPER.OR. (LSUPER .AND. NSUPER == 1))) CALL CPSETI('NCL',ICL+1)
+ ENDIF
+ CALL CPSETI('CLS',0)
+ ZISO=ZTABMIN-ZTABINT
+ DO I=1,ICL
+ CALL CPSETI('PAI',I)
+ CALL CPSETI('AIA',I+1)
+ CALL CPSETI('AIB',I)
+ ZISO=ZISO+ZTABINT
+ IF(ABS(ZISO)<1.E-20)ZISO=0.
+ CALL CPSETR('CLV',ZISO)
+ CALL CPSETR('CLU',1.)
+ IF(.NOT.LSUPER.OR. (LSUPER .AND. NSUPER == 1))THEN
+ IF(LBLUSER1)THEN
+ DO JLBL=1,SIZE(XLBLUSER1)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER1(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+! print *,' ISO LABELLE ',ZISO
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 2)THEN
+ IF(LBLUSER2)THEN
+ DO JLBL=1,SIZE(XLBLUSER2)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER2(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 3)THEN
+ IF(LBLUSER3)THEN
+ DO JLBL=1,SIZE(XLBLUSER3)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER3(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 4)THEN
+ IF(LBLUSER4)THEN
+ DO JLBL=1,SIZE(XLBLUSER4)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER4(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ENDDO
+! mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
+! IF(ICL /= 1)THEN
+! IF((LCOLAREA .OR. LHACH1) .AND. (.NOT.LSUPER.OR. (LSUPER .AND. NSUPER == 1)))THEN
+! ICL=ICL+1
+! CALL CPSETI('PAI',ICL)
+! CALL CPSETI('AIB',ICL)
+!mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
+! CALL CPSETI('AIA',ICL+1)
+! ZISO=ZISO+ZTABINT
+! IF(ABS(ZISO)<1.E-20)ZISO=0.
+! CALL CPSETR('CLV',ZISO)
+! END IF
+! END IF
+
+! mmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
+ CASE(2,3)
+ ICL=0
+ DO I=1,10000
+ ICL=ICL+1
+ IF(NIMNMX==3 .OR. (NIMNMX==2 .AND.LISOLEVP))THEN
+ ZLEV(ICL)=ZISOLEVP(ICL)
+ IF(NVERBIA > 5)then
+ print *,' ICL ZLEV ',ICL,ZLEV(ICL)
+ ENDIF
+ ELSE IF (NIMNMX==2 .AND. .NOT.LISOLEVP) THEN ! Given contour values
+ IF(I == 1 .AND. XISOLEV(1) == 9999.)THEN
+ print *,' NIMNMX=2 . ABSENCE DE VALEURS DANS XISOLEV='
+ print *,' RENTREZ LES AU CLAVIER PAR ORDRE CROISSANT ET A RAISON D''1'
+ print *,' VALEUR PAR LIGNE. TERMINEZ PAR 9999.'
+ print *,' (REMARQUE : elles ne sont pas memorisees et donc valides pour le seul parametre'
+ print *,' en cours :',YTEXT(1:LEN_TRIM(YTEXT)),')'
+ ENDIF
+ IF(XISOLEV(1) == 9999.)THEN
+ READ(5,*)ZLEV(ICL)
+ ELSE
+ ZLEV(ICL)=XISOLEV(ICL)
+ ENDIF
+ ENDIF
+ IF(ZLEV(ICL) == 9999.)EXIT
+ ENDDO
+ !
+ ICL=ICL-1
+ CALL CPSETI('NCL',ICL)
+ CALL CPSETI('CLS',0)
+ DO I=1,ICL
+ CALL CPSETI('PAI',I)
+ CALL CPSETI('AIA',I+1)
+ CALL CPSETI('AIB',I)
+ CALL CPSETR('CLV',ZLEV(I))
+ CALL CPSETR('CLU',1.)
+ IF(.NOT.LSUPER.OR. (LSUPER .AND. NSUPER == 1))THEN
+ IF(LBLUSER1)THEN
+ DO JLBL=1,SIZE(XLBLUSER1)
+ DO JL=-20,20,1
+ IF(ZLEV(I) == XLBLUSER1(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+! print *,' ISO LABELLE ',ZLEV(I)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 2)THEN
+ IF(LBLUSER2)THEN
+ DO JLBL=1,SIZE(XLBLUSER2)
+ DO JL=-20,20,1
+ IF(ZLEV(I) == XLBLUSER2(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 3)THEN
+ IF(LBLUSER3)THEN
+ DO JLBL=1,SIZE(XLBLUSER3)
+ DO JL=-20,20,1
+ IF(ZLEV(I) == XLBLUSER3(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 4)THEN
+ IF(LBLUSER4)THEN
+ DO JLBL=1,SIZE(XLBLUSER4)
+ DO JL=-20,20,1
+ IF(ZLEV(I) == XLBLUSER4(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ENDDO
+END SELECT
+!
+!* 1.4 A few cosmetic parameter settings
+!
+! Label format and normalization
+!
+if(nverbia > 0)then
+ print *,' ** image AV CASE(NIOFFD)',NIOFFD
+endif
+SELECT CASE(NIOFFD)
+
+CASE(0) !! No label normalisation, decimal point kept
+ III=9 ! 'Numeric exponent use flag'
+ CALL CPSETI('NEU',III) ! III > 0 --> decimal point kept if the number of
+ ! significant digits < III; else form requiring the
+ ! fewest character is used
+ CALL CPSETI('NOF',7)
+ IF(NSD /= 0)THEN
+ CALL CPSETI('NSD',-NSD)
+ ELSE
+ CALL CPSETI('NSD',-6)
+ ENDIF
+CASE DEFAULT !! Label normalisation, scale factor right of the plot
+ CALL CPSETI('NEU',-2) ! Exponential notation forced, in any case
+ CALL CPSETI('NOF',7)
+ CALL CPSETI('NET',0) ! Exponent shown as a "E"
+
+END SELECT
+!
+! Special value handling
+!
+SELECT CASE(NIOFFP)
+
+CASE(0) ! No special value used
+ CALL CPSETR('SPV',0.)
+CASE DEFAULT ! XSPVAL used as a special value
+ CALL CPSETR('SPV',XSPVAL)
+
+END SELECT
+!
+! Information label under the plot
+!
+SELECT CASE(NIOFFM)
+
+CASE(0) ! A label is printed to the plot bottom
+CASE DEFAULT ! No label
+ CALL CPSETC('ILT',' ')
+
+END SELECT
+!
+!!!!!!!! PROVI
+CALL GSCLIP(1) ! Display clipping activated
+!CALL GSCLIP(0) ! Display clipping activated
+!!!!!!!! PROVI
+CALL CPSETI('MAP',4) ! A specific map projection is used, as provided in
+ ! the user-provided "CPMPXY" routine. This important
+ ! parameter informs Conpack of the kind of geographic
+ ! transformation actually made.
+CALL CPSETI('SET',0) ! No "SET" issued by conpack
+CALL CPSETR('SPV',XSPVAL)
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. FIELD CONTOURS DRAWING
+! ----------------------
+!
+!* 3.1 Conpack initialization
+!
+if(nverbia > 0)then
+ print *,' ** image AV CPRECT(PTAB,IM,IM',IM,IL
+endif
+CALL CPRECT(PTAB,IM,IM,IL,ZRWRK,JPLRWK,IWRK,JPLIWK)
+CALL CPSETR('CWM',XSIZEL/.01)
+
+INCL=0
+CALL CPPKCL(PTAB,ZRWRK,IWRK)
+CALL CPGETI('NCL',INCL)
+
+!
+!* 3.1a High and low handling
+!
+SELECT CASE(KNHI)
+
+ CASE(0) ! H + L are displayed
+! Test rajoute pour eviter la superposition de CONSTANT FIELD ici et ensuite
+! avec le 2eme CPLBDR utile en cas de surfaces colorees
+ IF(INCL /= 0)THEN
+ CALL CPLBDR(PTAB,ZRWRK,IWRK)
+ ENDIF
+ CASE DEFAULT ! TO BE REVISED*********************
+ ! <0 --> no action (:-1 to be set)
+ ! >0 --> gridpoint value displayed
+ ! (1: to be set)
+END SELECT
+!
+!* 3.2 Line style and color handling
+!
+!INCL=0
+!CALL CPPKCL(PTAB,ZRWRK,IWRK)
+!CALL CPGETI('NCL',INCL)
+IF(NIMNMX < 0)THEN
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETR('CLU',1.)
+ CALL CPGETR('CLV',ZISO)
+ IF(.NOT.LSUPER.OR. (LSUPER .AND. NSUPER == 1))THEN
+ IF(LBLUSER1)THEN
+ DO JLBL=1,SIZE(XLBLUSER1)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER1(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ print *,' ISO LABELLE ',ZISO
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(J,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(J-1,NULBLL+1)==0).OR.J==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 2)THEN
+ IF(LBLUSER2)THEN
+ DO JLBL=1,SIZE(XLBLUSER2)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER2(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(J,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(J-1,NULBLL+1)==0).OR.J==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 3)THEN
+ IF(LBLUSER3)THEN
+ DO JLBL=1,SIZE(XLBLUSER3)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER3(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(J,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(J-1,NULBLL+1)==0).OR.J==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 4)THEN
+ IF(LBLUSER4)THEN
+ DO JLBL=1,SIZE(XLBLUSER4)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER4(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(J,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(J-1,NULBLL+1)==0).OR.J==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(J,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(J-1,NULBLL+1)==0).OR.J==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ENDDO
+END IF
+SELECT CASE(KNDOT)
+ CASE(0,1,1023,65535) ! Solid lines
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('CLD',65535)
+ ENDDO
+ CASE (:-1) ! <0 Negative value dashed, positive value solid
+ ICLD=ABS(KNDOT)
+! write(0,*)' KNDOT',KNDOT,' INCL ',INCL
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPGETR('CLV',ZCLV)
+ IF(ZCLV.GE.0.)CALL CPSETI('CLD',65535)
+ IF(ZCLV.LT.0.)CALL CPSETI('CLD',ICLD)
+! write(0,*)' J ZCLV',I,ZCLV
+ ENDDO
+ CASE DEFAULT ! KNDOT used as a dash pattern
+ ICLD=ABS(KNDOT)
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('CLD',ICLD)
+ ENDDO
+END SELECT
+
+!
+! **************************************************************
+! Surfaces en hachures ; LHACHx=.TRUE. (avec x=1 ou 2 ou 3 ou 4)
+! **************************************************************
+
+IF((LHACH1 .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))) .OR. &
+ (LHACH2 .AND. NSUPER == 2) .OR. &
+ (LHACH3 .AND. NSUPER == 3) .OR. &
+ (LHACH4 .AND. NSUPER == 4))THEN !++++++++++++++++++++++++++++++++++++++++++
+
+ IF(NSUPER > 1)THEN
+ IH=IH+1
+ if(nverbia >0)then
+ print *,' image: HACHures IHT IH ',IHT,IH
+ endif
+ ENDIF
+
+ WRITE(NLUOUT,*)' >>>>>>>IMAGE_FORDIACHRO VARIABLE : ',HTEXTE,' NB ISOC. : ',INCL,' VALEURS:'
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('AIB',J)
+ CALL CPSETI('AIA',J+1)
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ CALL GENFORMAT_FORDIACHRO(ZCLV,YLLBS(J))
+ ENDDO
+
+ IF(.NOT.LHACHSEL)THEN
+ IF(INCL+1 <= 8)THEN
+ DO J=1,INCL
+ IHACH(J)=INDHACHREF(J)
+ ENDDO
+ IHACH(INCL+1)=INDHACHREF(8)
+ ELSE
+ IHACH(1:2)=INDHACHREF(1:2)
+ IHACH(3)=INDHACHREF(2)
+ IHACH(INCL-1:INCL+1)=INDHACHREF(6:8)
+
+ IF(INCL+1 < 13)THEN
+ IHACH(4)=INDHACHREF(3)
+ ELSE
+ IHACH(4)=INDHACHREF(2)
+ ENDIF
+
+ IF(INCL+1 == 9)THEN
+ IHACH(5)=INDHACHREF(4)
+ IHACH(6)=INDHACHREF(5)
+ ELSE
+ IHACH(5)=INDHACHREF(3)
+ IF(INCL+1 < 13)THEN
+ IHACH(6)=INDHACHREF(4)
+ ELSE
+ IHACH(6)=INDHACHREF(3)
+ ENDIF
+ ENDIF
+
+ IF(INCL+1 == 10)THEN
+ IHACH(7)=INDHACHREF(5)
+ ELSE IF(INCL+1 >= 11 .AND. INCL+1 < 14)THEN
+ IHACH(7)=INDHACHREF(4)
+ ELSE IF(INCL+1 >= 14)THEN
+ IHACH(7)=INDHACHREF(3)
+ ENDIF
+
+ IF(INCL+1 >= 11 .AND. INCL+1 < 13)THEN
+ IHACH(8)=INDHACHREF(5)
+ ELSE IF(INCL+1 >= 13)THEN
+ IHACH(8)=INDHACHREF(4)
+ ENDIF
+
+ IF(INCL+1 >= 12 .AND. INCL+1 < 14)THEN
+ IHACH(9)=INDHACHREF(5)
+ ELSE IF(INCL+1 >= 14)THEN
+ IHACH(9)=INDHACHREF(4)
+ ENDIF
+
+ IF(INCL+1 == 13)THEN
+ IHACH(10)=INDHACHREF(5)
+ ELSE IF(INCL+1 >= 14 .AND. INCL+1 < 15)THEN
+ IHACH(10)=INDHACHREF(5)
+ ELSE IF(INCL+1 >= 15)THEN
+ IHACH(10)=INDHACHREF(4)
+ ENDIF
+
+ IF(INCL+1 >= 14)THEN
+ IHACH(11)=INDHACHREF(5)
+ ENDIF
+
+ IF(INCL+1 >= 15)THEN
+ IHACH(12)=INDHACHREF(5)
+ ENDIF
+
+ IF(INCL+1 == 16)THEN
+ IHACH(13)=INDHACHREF(5)
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ DO J=1,300
+ IHACH(J)=0
+ ENDDO
+ WRITE(NLUOUT,*)' >>>>>>>SELECTION DES HACHURES PAR L''UTILISATEUR'
+ WRITE(NLUOUT,*)' >>>>>>>VOUS DEVEZ FOURNIR ',INCL+1,' INDICES'
+ WRITE(NLUOUT,*)' Rentrez sur 1 premiere ligne le nombre d''indices fournis dans la ligne suivante'
+ WRITE(NLUOUT,*)' Puis sur la(es) ligne(s) suivante(s) les indices des figures pris dans la table'
+ WRITE(NLUOUT,*)' de reference correspondant aux isocontours ranges par ordre croissant'
+ WRITE(NLUOUT,*)' (Entiers separes par 1 blanc)'
+ READ(5,*,END=10)INBC
+ GO TO 11
+ 10 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez le nombre d indices '
+ READ(5,*)INBC
+ 11 CONTINUE
+ !WRITE(YCAR80,*)INBC
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,INBC)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ READ(5,*,END=12)(IHACH(J),J=1,INBC)
+ GO TO 13
+ 12 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez la valeur des indices '
+ READ(5,*)(IHACH(J),J=1,INBC)
+ 13 CONTINUE
+ ! WRITE(YCAR320,*)IHACH(1:INBC)
+ ! YCAR320=ADJUSTL(YCAR320)
+ ! ILENT=LEN_TRIM(YCAR320)
+ ILENT=INBC*4
+ !! car plantage dans le cas ELSE si ILENT=80 !!
+ IF(ILENT == 80 ) THEN
+ ! YCAR320=TRIM(YCAR320)//' '
+ ILENT=ILENT+1
+ END IF
+ IF(ILENT > 240 )THEN
+ !WRITE(YCAR80,*)IHACH(1:INBC/4)
+ CALL WRITEDIR(NDIR,IHACH(1:INBC/4))
+ !WRITE(YCAR80,*)IHACH(INBC/4+1:INBC/2)
+ CALL WRITEDIR(NDIR,IHACH(INBC/4+1:INBC/2))
+ !WRITE(YCAR80,*)IHACH(INBC/2+1:3*INBC/4)
+ CALL WRITEDIR(NDIR,IHACH(INBC/2+1:3*INBC/4))
+ !WRITE(YCAR80,*)IHACH(3*INBC/4+1:INBC)
+ CALL WRITEDIR(NDIR,IHACH(3*INBC/4+1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ELSE IF(ILENT > 160 )THEN
+ ! WRITE(YCAR80,*)IHACH(1:INBC/3)
+ CALL WRITEDIR(NDIR,IHACH(1:INBC/3))
+ ! WRITE(YCAR80,*)IHACH(INBC/3+1:2*INBC/3)
+ CALL WRITEDIR(NDIR,IHACH(INBC/3+1:2*INBC/3))
+ ! WRITE(YCAR80,*)IHACH(2*INBC/3+1:INBC)
+ CALL WRITEDIR(NDIR,IHACH(2*INBC/3+1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ELSE IF(ILENT > 80 )THEN
+ ! WRITE(YCAR80,*)IHACH(1:INBC/2)
+ CALL WRITEDIR(NDIR,IHACH(1:INBC/2))
+ ! WRITE(YCAR80,*)IHACH(INBC/2+1:INBC)
+ CALL WRITEDIR(NDIR,IHACH(INBC/2+1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ELSE
+ !WRITE(YCAR80,*)IHACH(1:INBC)
+ CALL WRITEDIR(NDIR,IHACH(1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ENDIF
+ ENDIF
+
+ IF(LCOLZERO)THEN
+ IHACH(NCOLZERO)=0
+ ENDIF
+ WRITE(NLUOUT,*)(ZLEV(J),IHACH(J),J=1,INCL)
+ WRITE(NLUOUT,*)IHACH(INCL+1)
+
+! Trace des zones hachurees
+ CALL GSFAIS(1)
+ CALL GSLN(1)
+! CALL GSFACI(1)
+ CALL GSPLCI(1)
+ CALL ARINAM(IIMAP,JPMAP)
+! call mapbla(iimap)
+ CALL CPCLAM(PTAB,ZRWRK,IWRK,IIMAP)
+ CALL ARSCAM(IIMAP,ZXWRK,ZYWRK,JPWRK,IAREA,IGRP,JPAREAGRP,SFILLH)
+ print *,' Hach: MAP 1 6 5 ',IIMAP(1),IIMAP(6),IIMAP(5)
+ CALL GSFAIS(0)
+!
+! Trace des valeurs
+
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ CALL GSFAIS(1)
+ CALL LBSETI('CBL',1)
+! CALL LBSETI('CBL',0)
+ DO J=1,INCL
+ YLLBS(J)=ADJUSTL(YLLBS(J))
+ ENDDO
+ IF(.NOT.LSUPER .OR. NSUPER == 1 .OR. (NSUPER == 2 .AND. LARROVL .AND. NSUPERDIA == 2))THEN
+ IF(ZVR < .8999999)THEN
+ print *,' ZVR < .9 ',ZVR
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(MIN(ZVR+.2,1.)-ZVR)/10.,MIN(ZVR+.2,1.),ZVB,ZVT,INCL+1,.15,1.,IHACH,2,YLLBS,INCL,1)
+ ELSE
+ IF(INCL <= 8)THEN
+ if(nverbia >0)then
+ print *,' INCL <= 8 ',INCL
+ endif
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB+(ZVT-ZVB)/4.,ZVT,INCL+1,.15,1.,IHACH,2,YLLBS,INCL,1)
+ ELSE
+ if(nverbia >0)then
+ print *,' INCL > 8 ',INCL
+ endif
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB,ZVT,INCL+1,.15,1.,IHACH,2,YLLBS,INCL,1)
+ ENDIF
+! CALL LBLBAR_FORDIACHRO(1,ZVR,1.,ZVB,ZVT,INCL+1,.15,1.,IHACH,2,YLLBS,INCL,2)
+ ENDIF
+
+ ELSE
+
+ ZVERA=ZVR-(ZVR-ZVL)/3.
+
+ IF(IHT == 0)THEN
+ IF(NSUPER == 2 .AND. LARROVL .AND. NSUPERDIA > 2)THEN
+ ZD=ZVL; ZF=ZVERA
+ IF(INCL == 1)THEN
+ ZF=ZF-(ZF-ZD)/2.
+ ELSE IF(INCL <= 4)THEN
+ ZF=ZF-(ZF-ZD)/4.
+ ENDIF
+ CALL LBLBAR_FORDIACHRO(0,ZD,ZF,ZVT+.01,ZVT+.04,INCL+1,1.,.33,IHACH,2,YLLBS,INCL,2)
+ ELSE
+ print *,' ** Image IHT=0 -> pas de trace de la table de hachures. Cas imprevu .. A voir.. '
+ ENDIF
+ ELSE
+
+ ZINTE=(ZVERA-ZVLDEF)/FLOAT(IHT)
+ IF(IHT == 1)THEN
+ ZD=ZVL; ZF=ZVERA
+ ELSE IF(IHT == 2 .OR. IHT == 3)THEN
+ ZD=ZVLDEF+ZINTE*(IH-1)
+ ZF=ZVLDEF+ZINTE*(IH)-.01
+ ENDIF
+ IF(INCL == 1)THEN
+ ZF=ZF-(ZF-ZD)/2.
+ ELSE IF(INCL <= 4)THEN
+ ZF=ZF-(ZF-ZD)/4.
+ ENDIF
+ CALL LBLBAR_FORDIACHRO(0,ZD,ZF,ZVT+.01,ZVT+.04,INCL+1,1.,.33,IHACH,2,YLLBS,INCL,2)
+
+ ENDIF
+ ENDIF
+ CALL GSFAIS(0)
+!
+! Definition de la couleur des isos (0 -> blanc sur papier; 1 -> noir sur papier)
+ IF(LISOWHI)CALL GSPLCI(0)
+ IF(LISOWHI)CALL GSTXCI(0)
+
+!
+ELSE IF(LCOLAREA)THEN !+++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+! **************************************************************************
+! Surfaces couleur (reservees aux dessins avec ou sans superpositions;
+! LCOLAREA=.TRUE.) . En cas de superpositions, obligatoirement le 1er dessin
+! **************************************************************************
+
+ IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN !00000000000000000000000000000000000000000000
+
+ IF(.NOT.LCOLAREASEL)THEN !====================================
+!
+! Selection automatique des couleurs par le programme
+! ***************************************************
+!
+if(nverbia > 0)then
+ print *,' ** image AV COLOR_FORDIACHRO(INCL+1) ,INCL',INCL
+endif
+ CALL COLOR_FORDIACHRO(INCL+1,1)
+ WRITE(NLUOUT,*)' >>>>>>>IMAGE_FORDIACHRO VARIABLE : ',HTEXTE,' NB ISOC. : ',INCL,' VALEURS:'
+ IF(INCL /= 0)then
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('AIB',J)
+ CALL CPSETI('AIA',J+1)
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ ICOL(J)=J+2
+if(nverbia > 2)then
+ print *,' ** image AV GENFORMAT ZCLV ',ZCLV
+endif
+ CALL GENFORMAT_FORDIACHRO(ZCLV,YLLBS(J))
+ ENDDO
+ ENDIF
+ ICOL(INCL+1)=INCL+3
+if(nverbia > 0)then
+ print *,' ** image ICOL(INCL+1) ',ICOL(INCL+1)
+endif
+ IF(LCOLBR)THEN
+ IF(ZLEV(MAX(1,INCL)) > ZLEV(1) .AND. ICOL(INCL+1) > ICOL(1))THEN
+ ALLOCATE(ICOL2(INCL+1))
+ ICOL2(1:INCL+1)=ICOL(INCL+1:1:-1)
+ ICOL(1:INCL+1)=ICOL2
+! ICOL(:)=ICOL2
+ DEALLOCATE(ICOL2)
+ END IF
+ END IF
+ IF(LCOLZERO)THEN
+ ICOL(NCOLZERO)=0
+ ENDIF
+ WRITE(NLUOUT,*)(ZLEV(J),ICOL(J),J=1,INCL)
+ WRITE(NLUOUT,*)ICOL(INCL+1)
+ ELSE !====================================
+!
+! Selection des couleurs par l'utilisateur
+! ****************************************
+!
+ IF(LTABCOLDEF)THEN
+! Choix de la table de couleurs par defaut
+ WRITE(NLUOUT,*)' <<< TABCOLDEF >>>'
+ CALL TABCOL_FORDIACHRO
+ ELSE
+! Choix d'une table creee par l'utilisateur
+ CALL FMLOOK(YNAMTABCOL,CLUOUT,ILUCOL,IRESP)
+ IF(IRESP == -54)THEN
+ YNAMTABCOL(1:32)=' '
+! Lecture du nom de la table de couleurs (1 seule fois)
+ print *,' Entrez le nom de VOTRE TABLE de COULEURS '
+ READ(5,*,END=14)YNAMTABCOL
+ GO TO 15
+ 14 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez le nom de VOTRE TABLE de COULEURS'
+ READ(5,*)YNAMTABCOL
+ 15 CONTINUE
+ YNAMTABCOL=ADJUSTL(YNAMTABCOL)
+ !WRITE(NDIR,'(A80)')YNAMTABCOL
+ CALL WRITEDIR(NDIR,YNAMTABCOL)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+! Janv 2001
+ CALL FMLOOK(YNAMTABCOL,CLUOUT,ILUCOL,IRESP)
+ IF(IRESP /= 0)THEN
+! Janv 2001
+ CALL CREATLINK('DIRCOL',YNAMTABCOL,'CREAT',NVERBIA)
+ CALL FMATTR(YNAMTABCOL,CLUOUT,ILUCOL,IRESP)
+ OPEN(UNIT=ILUCOL,FILE=YNAMTABCOL,FORM='FORMATTED')
+! Janv 2001
+ ENDIF
+! Janv 2001
+ END IF
+ WRITE(NLUOUT,*)' <<< ',YNAMTABCOL,' >>>'
+ REWIND (ILUCOL)
+! Lecture du nb de couleurs de la table, des index de couleur et des
+! proportions relatives de rouge, vert, bleu
+ CALL GQOPS(ISTA)
+ CALL GQACWK(1,IER,INB,IWK)
+!print *,' COLOR_FORDIACHRO AP GQACWK INB IWK ',INB,IWK
+ CALL GQOPWK(1,IER,INB,IWK)
+ READ(ILUCOL,*)INBCT
+ DO J=1,INBCT
+ READ(ILUCOL,*)IDX,RED,GREEN,BLUE
+ DO JU=1,INB
+ CALL GQOPWK(JU,IER,INBB,IWK)
+ IF(IWK == 9)THEN
+ CYCLE
+ ELSE
+ CALL GSCR(IWK,IDX,RED,GREEN,BLUE)
+! CALL GSCR(1,IDX,RED,GREEN,BLUE)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF ! fin d'une table creee par l'utilisateur
+ WRITE(NLUOUT,*)' >>>>>>>IMAGE_FORDIACHRO VARIABLE : ',HTEXTE,' NB ISOC. : ',INCL,' VALEURS:'
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('AIB',J)
+ CALL CPSETI('AIA',J+1)
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ CALL GENFORMAT_FORDIACHRO(ZCLV,YLLBS(J))
+ ENDDO
+ DO J=1,300
+ ICOL(J)=0
+ ENDDO
+! Pour 1 dessin donne, lecture du nb d'indices de couleurs et de leur valeur
+! sur la ligne suivante
+ READ(5,*,END=16)INBC
+ GO TO 17
+ 16 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez le nb d indices de couleur'
+ READ(5,*)INBC
+ 17 CONTINUE
+ !WRITE(YCAR80,*)INBC
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,INBC)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+
+ READ(5,*,END=18)(ICOL(J),J=1,INBC)
+ GO TO 19
+ 18 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez la valeur des indices de couleur'
+ READ(5,*)(ICOL(J),J=1,INBC)
+ 19 CONTINUE
+ ! WRITE(YCAR320,*)ICOL(1:INBC)
+ ! YCAR320=ADJUSTL(YCAR320)
+ ! ILENT=LEN_TRIM(YCAR320)
+ ! print*,"YCAR320=",YCAR320
+ ! print*,"ILENT=",ILENT
+ ILENT=INBC*4
+ IF(ILENT == 80 ) THEN
+ ! YCAR320=TRIM(YCAR320)//' '
+ ILENT=ILENT+1
+ END IF
+ IF(ILENT > 240 )THEN
+ ! WRITE(YCAR80,*)ICOL(1:INBC/4)
+ CALL WRITEDIR(NDIR,ICOL(1:INBC/4))
+ ! WRITE(YCAR80,*)ICOL(INBC/4+1:INBC/2)
+ CALL WRITEDIR(NDIR,ICOL(INBC/4+1:INBC/2))
+ ! WRITE(YCAR80,*)ICOL(INBC/2+1:3*INBC/4)
+ CALL WRITEDIR(NDIR,ICOL(INBC/2+1:3*INBC/4))
+ ! WRITE(YCAR80,*)ICOL(3*INBC/4+1:INBC)
+ CALL WRITEDIR(NDIR,ICOL(3*INBC/4+1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ELSE IF(ILENT > 160 )THEN
+ ! WRITE(YCAR80,*)ICOL(1:INBC/3)
+ CALL WRITEDIR(NDIR,ICOL(1:INBC/3))
+ ! WRITE(YCAR80,*)ICOL(INBC/3+1:2*INBC/3)
+ CALL WRITEDIR(NDIR,ICOL(INBC/3+1:2*INBC/3))
+ ! WRITE(YCAR80,*)ICOL(2*INBC/3+1:INBC)
+ CALL WRITEDIR(NDIR,ICOL(2*INBC/3+1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ELSE IF(ILENT > 80 )THEN
+ !WRITE(YCAR80,*)ICOL(1:INBC/2)
+ CALL WRITEDIR(NDIR,ICOL(1:INBC/2))
+ ! WRITE(YCAR80,*)ICOL(INBC/2+1:INBC)
+ CALL WRITEDIR(NDIR,ICOL(INBC/2+1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ELSE
+ !WRITE(YCAR80,*)ICOL(1:INBC)
+ CALL WRITEDIR(NDIR,ICOL(1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ENDIF
+ print*,(ZLEV(J),ICOL(J),J=1,INCL)
+ print*,ICOL(INCL+1)
+
+ WRITE(NLUOUT,*)(ZLEV(J),ICOL(J),J=1,INCL)
+ WRITE(NLUOUT,*)ICOL(INCL+1)
+! fin de la selection des couleurs par l'utilisateur
+ ENDIF !====================================
+!
+! Trace des zones colorees
+! ************************
+ !IF(LMSKTOP .AND. LMARKER)THEN
+ IF(LMARKER .AND. .NOT. LSPOT)THEN
+ ! en etoiles colorees
+ CALL GSMK(3) ! asterisk is the type of marker
+ DO JJ=1,NIJMAX
+ DO JI=1,NIIMAX
+ IF(PTAB(JI,JJ) /= XSPVAL)THEN
+ IF(PTAB(JI,JJ) < ZLEV(1))THEN
+ CALL GSPMCI(ICOL(1))
+ ELSE IF(PTAB(JI,JJ) >= ZLEV(INCL))THEN
+ CALL GSPMCI(ICOL(INCL+1))
+ ELSE
+ DO JK=1,INCL-1
+ IF(PTAB(JI,JJ) >= ZLEV(JK) .AND. &
+ PTAB(JI,JJ) < ZLEV(JK+1))THEN
+ CALL GSPMCI(ICOL(JK+1))
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ZX=XZZXX(JI)
+ ZY=XZZXY(JJ)
+ CALL GPM(1,ZX,ZY)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ELSE IF (LSPOT .AND. .NOT. LMARKER) THEN
+ ! en paves de couleur
+ CALL GSFAIS(1) ! solid filling of the polygon
+ ZEPX=(XZZXX(NIIMAX/2+1)-XZZXX(NIIMAX/2))*0.5
+ ZEPY=(XZZXY(NIJMAX/2+1)-XZZXY(NIJMAX/2))*0.5
+ print *,'LSPOT: taille differente de la maille?'
+ print *,' (n/N recommande pour trace de champs modeles)'
+ print *,' (avec contour: o/O/y/Y recommande pour trace d observations '
+ print *,' epaisseur du contour gere avec XLW1)'
+ print *,' (sans contour: a/A recommande pour trace d observations)'
+ read(5,*) YREP
+ CALL WRITEDIR(NDIR,YREP)
+ IF(YREP=='o' .OR. YREP=='O' .OR. YREP=='y' .OR. YREP=='Y' .OR.&
+ YREP=='a' .OR. YREP=='A' ) THEN
+ ! essai de redimensionnement
+ print *,'taille du pixel: NIMAX/nx et NJMAX/ny'
+ print *,'indiquez nx et ny (2 entiers) ?'
+ print *,' si <=0 le defaut (50) est utilise'
+ read(5,*) INBX,INBY
+ CALL WRITEDIR(NDIR,INBX)
+ CALL WRITEDIR(NDIR,INBY)
+ IF(INBX<=0) INBX=50
+ IF(INBY<=0) INBY=50
+ ZEPX=ZEPX*NIIMAX/INBX ; ZEPY=ZEPY*NIJMAX/INBY
+ ! contour en trait plein noir
+ CALL DASHDB(65535)
+ ENDIF
+ DO JJ=1,NIJMAX
+ DO JI=1,NIIMAX
+ IF(PTAB(JI,JJ) /= XSPVAL)THEN
+ IF(PTAB(JI,JJ) < ZLEV(1))THEN
+ CALL GSFACI(ICOL(1))
+ ELSE IF(PTAB(JI,JJ) >= ZLEV(INCL)) THEN
+ CALL GSFACI(ICOL(INCL+1))
+ ELSE
+ DO JK=1,INCL-1
+ IF(PTAB(JI,JJ) >= ZLEV(JK) .AND. &
+ PTAB(JI,JJ) < ZLEV(JK+1))THEN
+ CALL GSFACI(ICOL(JK+1))
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ZX5(1)=XZZXX(JI)-ZEPX ; ZY5(1)=XZZXY(JJ)-ZEPY
+ ZX5(2)=XZZXX(JI)-ZEPX ; ZY5(2)=XZZXY(JJ)+ZEPY
+ ZX5(3)=XZZXX(JI)+ZEPX ; ZY5(3)=XZZXY(JJ)+ZEPY
+ ZX5(4)=XZZXX(JI)+ZEPX ; ZY5(4)=XZZXY(JJ)-ZEPY
+ ZX5(5)=XZZXX(JI)-ZEPX ; ZY5(5)=XZZXY(JJ)-ZEPY
+ ! paves
+ CALL GFA(5,ZX5,ZY5)
+ IF(YREP=='o' .OR. YREP=='O' .OR. YREP=='y' .OR. YREP=='Y') THEN
+ ! contour
+ CALL GQLWSC(IER,ZWIDTH)
+ CALL GSLWSC(XLWIDTH)
+ CALL CURVED(ZX5,ZY5,5)
+ CALL GSLWSC(ZWIDTH)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ ! Trace des surfaces couleurs
+ CALL GSFAIS(1)
+if(nverbia > 0)then
+ print *,' ** image AV CALL ARINAM ',JPMAP
+endif
+ CALL ARINAM(IIMAP,JPMAP)
+! call mapbla(iimap)
+ CALL CPCLAM(PTAB,ZRWRK,IWRK,IIMAP)
+ CALL ARSCAM(IIMAP,ZXWRK,ZYWRK,JPWRK,IAREA,IGRP,JPAREAGRP,CCOLR)
+ print *,' Col: MAP 1 6 5 ',IIMAP(1),IIMAP(6),IIMAP(5)
+ CALL GSPLCI(1)
+ CALL GSFAIS(0)
+ ENDIF
+! CALL GSLN(1)
+ ! Trace des valeurs (legende)
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ CALL GSFAIS(1)
+ CALL LBSETI('CBL',0)
+ DO J=1,INCL
+ YLLBS(J)=ADJUSTL(YLLBS(J))
+ ENDDO
+ IF(ZVR < .9)THEN
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(MIN(ZVR+.2,1.)-ZVR)/10.,MIN(ZVR+.2,1.),ZVB,ZVT,INCL+1,.15,1.,ICOL,1,YLLBS,INCL,1)
+ ELSE
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB,ZVT,INCL+1,.15,1.,ICOL,1,YLLBS,INCL,1)
+! CALL LBLBAR_FORDIACHRO(1,ZVR,1.,ZVB,ZVT,INCL+1,.15,1.,ICOL,1,YLLBS,INCL,2)
+ ENDIF
+ CALL GSFAIS(0)
+!
+! Definition de la couleur des isos (0 -> blanc sur papier; 1 -> noir sur papier)
+ IF(LISOWHI)CALL GSPLCI(0)
+ IF(LISOWHI)CALL GSTXCI(0)
+!
+ ELSE IF(LCOLINE)THEN !00000000000000000000000000000000000000000000
+
+! Traits couleur dans le cas de superpositions (LCOLAREA=.TRUE. et LCOLINE=.TRUE.)
+! **************************************************************************
+
+! Modifs 220396
+ CALL TABCOL_FORDIACHRO
+! IF((LSUPER .AND. NSUPER == 1) .OR. .NOT.LSUPER)CALL TABCOL_FORDIACHRO
+ IF(LSUPER)THEN
+!Mars 2000
+ IF(LCOLISONE)THEN
+ IF(NSUPER == 1)CALL GSPLCI(NCOLISONE1)
+ IF(NSUPER == 1)CALL GSTXCI(NCOLISONE1)
+ IF(NSUPER == 2)CALL GSPLCI(NCOLISONE2)
+ IF(NSUPER == 2)CALL GSTXCI(NCOLISONE2)
+ IF(NSUPER == 3)CALL GSPLCI(NCOLISONE3)
+ IF(NSUPER == 3)CALL GSTXCI(NCOLISONE3)
+ IF(NSUPER == 4)CALL GSPLCI(NCOLISONE4)
+ IF(NSUPER == 4)CALL GSTXCI(NCOLISONE4)
+ IF(NSUPER == 5)CALL GSPLCI(NCOLISONE5)
+ IF(NSUPER == 5)CALL GSTXCI(NCOLISONE5)
+ ELSE
+!Mars 2000
+ IF(NSUPER == 1)CALL GSPLCI(2)
+ IF(NSUPER == 1)CALL GSTXCI(2)
+ IF(NSUPER == 2)CALL GSPLCI(4)
+ IF(NSUPER == 2)CALL GSTXCI(4)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==2) &
+ CALL GSPLCI(2)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==2) &
+ CALL GSTXCI(2)
+ IF(NSUPER == 3)CALL GSPLCI(3)
+ IF(NSUPER == 3)CALL GSTXCI(3)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==3) &
+ CALL GSPLCI(4)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==3) &
+ CALL GSTXCI(4)
+ IF(NSUPER == 4)CALL GSPLCI(7)
+ IF(NSUPER == 4)CALL GSTXCI(7)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==4) &
+ CALL GSPLCI(3)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==4) &
+ CALL GSTXCI(3)
+ IF(NSUPER > 4)CALL GSPLCI(NSUPER*2-1)
+ IF(NSUPER > 4)CALL GSTXCI(NSUPER*2-1)
+!!!!!!!! PROVI
+!CALL FRSTPT(XXX(NIINF,NMGRID),XXY(NJINF,NMGRID))
+!CALL VECTOR(XXX(NIINF,NMGRID),XXY(NJSUP,NMGRID))
+!CALL VECTOR(XXX(NISUP,NMGRID),XXY(NJSUP,NMGRID))
+!CALL VECTOR(XXX(NISUP,NMGRID),XXY(NJINF,NMGRID))
+!CALL VECTOR(XXX(NIINF,NMGRID),XXY(NJINF,NMGRID))
+!!!!!!!! PROVI
+ ENDIF
+
+ END IF
+ ELSE !00000000000000000000000000000000000000000000
+
+! Traits noir et blanc dans le cas de superpositions (LCOLAREA=.TRUE. et LCOLINE=.FALSE.)
+! ********************************************************************************
+
+ CALL GSPLCI(1)
+ CALL GSLN(1)
+ IF(LSUPER)THEN
+ IF(NSUPER == 1)CALL GSLN(1)
+ IF(NSUPER == 2)CALL GSLN(1)
+
+ IF(LINVPTIR)THEN
+
+ IF(NSUPER == 3)THEN
+ CALL GSLN(2)
+ IF((LCOLAREA.OR.LHACH1) .AND. LHACH2)CALL GSLN(1)
+ ENDIF
+ IF(NSUPER == 4)CALL GSLN(3)
+
+ ELSE
+
+ IF(NSUPER == 3)THEN
+ CALL GSLN(3)
+ IF((LCOLAREA.OR.LHACH1) .AND. LHACH2)CALL GSLN(1)
+ ENDIF
+ IF(NSUPER == 4)CALL GSLN(2)
+
+ ENDIF
+
+ END IF
+
+ END IF !00000000000000000000000000000000000000000000
+
+ELSE IF( LGREY .AND. .NOT.LCOLAREA ) THEN
+! **************************************************************
+! Surfaces en grises ( LGREY=.TRUE.)
+! En cas de superpositions, obligatoirement le 1er dessin
+! **************************************************************
+ IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN !000000000000000000
+!
+! Selection automatique des grises par le programme
+! **************************************************
+!
+if(nverbia > 0)then
+ print *,' ** image GREY av COLOR_FORDIACHRO(INCL+1,2) ,INCL',INCL
+endif
+ CALL COLOR_FORDIACHRO(INCL+1,2)
+ WRITE(NLUOUT,*)' >>>>>>>IMAGE_FORDIACHRO VARIABLE : ',HTEXTE,' NB ISOC. : ',INCL,' VALEURS:'
+ IF(INCL /= 0)then
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('AIB',J)
+ CALL CPSETI('AIA',J+1)
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ ICOL(J)=J+2
+ CALL GENFORMAT_FORDIACHRO(ZCLV,YLLBS(J))
+ ENDDO
+ ENDIF
+ ICOL(INCL+1)=INCL+3
+if(nverbia > 0)then
+ print *,' ** image ICOL(INCL+1) ',ICOL(INCL+1)
+endif
+ IF(LCOLBR)THEN
+ IF(ZLEV(MAX(1,INCL)) > ZLEV(1) .AND. ICOL(INCL+1) > ICOL(1))THEN
+ print*,zlev(incl),zlev(1),icol(incl+1),icol(1)
+ ALLOCATE(ICOL2(INCL+1))
+ ICOL2(1:INCL+1)=ICOL(INCL+1:1:-1)
+ ICOL(1:INCL+1)=ICOL2
+! ICOL(:)=ICOL2
+ DEALLOCATE(ICOL2)
+ END IF
+ END IF
+ IF(LCOLZERO)THEN
+ ICOL(NCOLZERO)=0
+ ENDIF
+ WRITE(NLUOUT,*)(ZLEV(J),ICOL(J),J=1,INCL)
+ WRITE(NLUOUT,*)ICOL(INCL+1)
+ ! Trace des zones grisees
+ CALL GSFAIS(1)
+ CALL ARINAM(IIMAP,JPMAP)
+! call mapbla(iimap)
+ CALL CPCLAM(PTAB,ZRWRK,IWRK,IIMAP)
+ CALL ARSCAM(IIMAP,ZXWRK,ZYWRK,JPWRK,IAREA,IGRP,JPAREAGRP,CCOLR)
+ print *,' Grey: MAP 1 6 5 ',IIMAP(1),IIMAP(6),IIMAP(5)
+ CALL GSPLCI(1)
+ CALL GSFAIS(0)
+! CALL GSLN(1)
+ ! Trace des valeurs (legende)
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ CALL GSFAIS(1)
+ CALL LBSETI('CBL',0)
+ DO J=1,INCL
+ YLLBS(J)=ADJUSTL(YLLBS(J))
+ ENDDO
+ IF(ZVR < .8999999)THEN
+ print *,' ZVR < .9 ',ZVR
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(MIN(ZVR+.2,1.)-ZVR)/10.,MIN(ZVR+.2,1.),ZVB,ZVT,INCL+1,.15,1.,ICOL,1,YLLBS,INCL,1)
+ ELSE
+ IF(INCL <= 8)THEN
+ if(nverbia >0)then
+ print *,' INCL <= 8 ',INCL
+ endif
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB+(ZVT-ZVB)/4.,ZVT,INCL+1,.15,1.,ICOL,1,YLLBS,INCL,1)
+ ELSE
+ if(nverbia >0)then
+ print *,' INCL > 8 ',INCL
+ endif
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB,ZVT,INCL+1,.15,1.,ICOL,1,YLLBS,INCL,1)
+ ENDIF
+! CALL LBLBAR_FORDIACHRO(1,ZVR,1.,ZVB,ZVT,INCL+1,.15,1.,IHACH,2,YLLBS,INCL,2)
+ ENDIF
+ CALL GSFAIS(0)
+!
+! Definition de la couleur des isos (0 -> blanc sur papier; 1 -> noir sur papier)
+ IF(LISOWHI)CALL GSPLCI(0)
+ IF(LISOWHI)CALL GSTXCI(0)
+
+ ELSE IF(LCOLINE)THEN !00000000000000000000000000000000000000000000
+
+! Traits couleur dans le cas de superpositions (LGREY=.TRUE. et LCOLINE=.TRUE.)
+! **************************************************************************
+
+! Modifs 220396
+ CALL TABCOL_FORDIACHRO
+! IF((LSUPER .AND. NSUPER == 1) .OR. .NOT.LSUPER)CALL TABCOL_FORDIACHRO
+ IF(LSUPER)THEN
+!Mars 2000
+ IF(LCOLISONE)THEN
+ IF(NSUPER == 1)CALL GSPLCI(NCOLISONE1)
+ IF(NSUPER == 1)CALL GSTXCI(NCOLISONE1)
+ IF(NSUPER == 2)CALL GSPLCI(NCOLISONE2)
+ IF(NSUPER == 2)CALL GSTXCI(NCOLISONE2)
+ IF(NSUPER == 3)CALL GSPLCI(NCOLISONE3)
+ IF(NSUPER == 3)CALL GSTXCI(NCOLISONE3)
+ IF(NSUPER == 4)CALL GSPLCI(NCOLISONE4)
+ IF(NSUPER == 4)CALL GSTXCI(NCOLISONE4)
+ IF(NSUPER == 5)CALL GSPLCI(NCOLISONE5)
+ IF(NSUPER == 5)CALL GSTXCI(NCOLISONE5)
+ ELSE
+!Mars 2000
+ IF(NSUPER == 1)CALL GSPLCI(2)
+ IF(NSUPER == 1)CALL GSTXCI(2)
+ IF(NSUPER == 2)CALL GSPLCI(4)
+ IF(NSUPER == 2)CALL GSTXCI(4)
+ IF((LARROVL .OR. LGREY .OR. LHACH1) .AND. NSUPER ==2) &
+ CALL GSPLCI(2)
+ IF((LARROVL .OR. LGREY .OR. LHACH1) .AND. NSUPER ==2) &
+ CALL GSTXCI(2)
+ IF(NSUPER == 3)CALL GSPLCI(3)
+ IF(NSUPER == 3)CALL GSTXCI(3)
+ IF((LARROVL .OR. LGREY .OR. LHACH1) .AND. NSUPER ==3) &
+ CALL GSPLCI(4)
+ IF((LARROVL .OR. LGREY .OR. LHACH1) .AND. NSUPER ==3) &
+ CALL GSTXCI(4)
+ IF(NSUPER == 4)CALL GSPLCI(7)
+ IF(NSUPER == 4)CALL GSTXCI(7)
+ IF((LARROVL .OR. LGREY .OR. LHACH1) .AND. NSUPER ==4) &
+ CALL GSPLCI(3)
+ IF((LARROVL .OR. LGREY .OR. LHACH1) .AND. NSUPER ==4) &
+ CALL GSTXCI(3)
+ IF(NSUPER > 4)CALL GSPLCI(NSUPER*2-1)
+ IF(NSUPER > 4)CALL GSTXCI(NSUPER*2-1)
+!!!!!!!! PROVI
+!CALL FRSTPT(XXX(NIINF,NMGRID),XXY(NJINF,NMGRID))
+!CALL VECTOR(XXX(NIINF,NMGRID),XXY(NJSUP,NMGRID))
+!CALL VECTOR(XXX(NISUP,NMGRID),XXY(NJSUP,NMGRID))
+!CALL VECTOR(XXX(NISUP,NMGRID),XXY(NJINF,NMGRID))
+!CALL VECTOR(XXX(NIINF,NMGRID),XXY(NJINF,NMGRID))
+!!!!!!!! PROVI
+ ENDIF
+
+ END IF
+ ELSE !00000000000000000000000000000000000000000000
+
+! Traits noir et blanc dans le cas de superpositions (LGREY=.TRUE. et LCOLINE=.FALSE.)
+! ********************************************************************************
+
+ CALL GSPLCI(1)
+ CALL GSLN(1)
+ IF(LSUPER)THEN
+ IF(NSUPER == 1)CALL GSLN(1)
+ IF(NSUPER == 2)CALL GSLN(1)
+
+ IF(LINVPTIR)THEN
+
+ IF(NSUPER == 3)THEN
+ CALL GSLN(2)
+ IF((LGREY.OR.LHACH1) .AND. LHACH2)CALL GSLN(1)
+ ENDIF
+ IF(NSUPER == 4)CALL GSLN(3)
+
+ ELSE
+
+ IF(NSUPER == 3)THEN
+ CALL GSLN(3)
+ IF((LGREY.OR.LHACH1) .AND. LHACH2)CALL GSLN(1)
+ ENDIF
+ IF(NSUPER == 4)CALL GSLN(2)
+
+ ENDIF
+
+ END IF
+
+ END IF !00000000000000000000000000000000000000000000
+
+ELSE IF(LCOLINE)THEN !+++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+! **********************************************
+! Traits couleur (LCOLAREA=.FALSE. et LCOLINE=.TRUE.)
+! **********************************************
+! Cas de superpositions
+! *********************
+
+! Modifs 220396
+ CALL TABCOL_FORDIACHRO
+! IF((LSUPER .AND. NSUPER == 1) .OR. .NOT.LSUPER)CALL TABCOL_FORDIACHRO
+! Modifs 260198
+! IF(LSUPER)THEN !............................................
+ IF(LSUPER .AND. & !............................................
+ .NOT.((LHACH1.OR.LHACH2) .AND. NSUPERDIA == 2) .AND. &
+ .NOT.( LARROVL .AND. NSUPERDIA == 2 ) )THEN
+!Mars 2000
+ IF(LCOLISONE)THEN
+ IF(NSUPER == 1)CALL GSPLCI(NCOLISONE1)
+ IF(NSUPER == 1)CALL GSTXCI(NCOLISONE1)
+ IF(NSUPER == 2)CALL GSPLCI(NCOLISONE2)
+ IF(NSUPER == 2)CALL GSTXCI(NCOLISONE2)
+ IF(NSUPER == 3)CALL GSPLCI(NCOLISONE3)
+ IF(NSUPER == 3)CALL GSTXCI(NCOLISONE3)
+ IF(NSUPER == 4)CALL GSPLCI(NCOLISONE4)
+ IF(NSUPER == 4)CALL GSTXCI(NCOLISONE4)
+ IF(NSUPER == 5)CALL GSPLCI(NCOLISONE5)
+ IF(NSUPER == 5)CALL GSTXCI(NCOLISONE5)
+ ELSE
+!Mars 2000
+ IF(NSUPER == 1)CALL GSPLCI(2)
+ IF(NSUPER == 1)CALL GSTXCI(2)
+ IF(NSUPER == 2)CALL GSPLCI(4)
+ IF(NSUPER == 2)CALL GSTXCI(4)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==2) &
+ CALL GSPLCI(2)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==2) &
+ CALL GSTXCI(2)
+ IF(NSUPER == 3)CALL GSPLCI(3)
+ IF(NSUPER == 3)CALL GSTXCI(3)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==3) &
+ CALL GSPLCI(4)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==3) &
+ CALL GSTXCI(4)
+ IF(NSUPER == 4)CALL GSPLCI(7)
+ IF(NSUPER == 4)CALL GSTXCI(7)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==4) &
+ CALL GSPLCI(3)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==4) &
+ CALL GSTXCI(3)
+ IF(NSUPER > 4)CALL GSPLCI(NSUPER*2-1)
+ IF(NSUPER > 4)CALL GSTXCI(NSUPER*2-1)
+
+!Mars 2000
+ ENDIF
+!Mars 2000
+
+ ELSE !............................................
+! Pas de superpositions
+! *********************
+
+! Selection automatique des couleurs par le programme
+! ***************************************************
+
+ IF(.NOT.LCOLINESEL)THEN !::::::::::::::::::::::::::::::::::::
+!Mars 2000
+ IF(LCOLISONE)THEN
+ ICOL(1:INCL)=NCOLISONE1
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('CLC',ICOL(J))
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ ENDDO
+ WRITE(NLUOUT,*)' >>>>>>>IMAGE_FORDIACHRO VARIABLE : ',HTEXTE,' NB ISOC. : ',INCL,' COULEUR UNIQUE : ',ICOL(1)
+ WRITE(NLUOUT,*)(ZLEV(J),J=1,INCL)
+ ELSE
+!Mars 2000
+
+ CALL COLOR_FORDIACHRO(INCL,1)
+ WRITE(NLUOUT,*)' >>>>>>>IMAGE_FORDIACHRO VARIABLE : ',HTEXTE,' NB ISOC. : ',INCL,' VALEURS:'
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('CLC',J+2)
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ ICOL(J)=J+2
+ CALL GENFORMAT_FORDIACHRO(ZCLV,YLLBS(J))
+ ENDDO
+ IF(LCOLBR)THEN
+ IF(ZLEV(MAX(1,INCL)) > ZLEV(1) .AND. ICOL(INCL) > ICOL(1))THEN
+ ALLOCATE(ICOL2(INCL))
+ ICOL2(1:INCL)=ICOL(INCL:1:-1)
+ ICOL(1:INCL)=ICOL2
+! ICOL(:)=ICOL2
+ DEALLOCATE(ICOL2)
+ END IF
+ END IF
+ WRITE(NLUOUT,*)(ZLEV(J),ICOL(J),J=1,INCL)
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('CLC',ICOL(J))
+ ENDDO
+
+!Mars 2000
+ ENDIF
+!Mars 2000
+ ELSE !::::::::::::::::::::::::::::::::::::
+
+! Selection des couleurs par l'utilisateur
+! ****************************************
+
+! Choix de la table de couleurs par defaut
+! ****************************************
+
+ IF(LTABCOLDEF)THEN
+ WRITE(NLUOUT,*)' <<< TABCOLDEF >>>'
+ CALL TABCOL_FORDIACHRO
+
+ ELSE
+
+! Choix d'une table creee par l'utilisateur
+! *****************************************
+
+ CALL FMLOOK(YNAMTABCOL,CLUOUT,ILUCOL,IRESP)
+ IF(IRESP == -54)THEN
+ YNAMTABCOL(1:32)=' '
+! Lecture du nom de la table de couleurs (1 seule fois)
+ print *,' Entrez le nom de VOTRE TABLE de COULEURS '
+ READ(5,*,END=20)YNAMTABCOL
+ GO TO 21
+ 20 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez le nom de VOTRE TABLE de COULEURS'
+ READ(5,*)YNAMTABCOL
+ 21 CONTINUE
+ YNAMTABCOL=ADJUSTL(YNAMTABCOL)
+ !WRITE(NDIR,'(A80)')YNAMTABCOL
+ CALL WRITEDIR(NDIR,YNAMTABCOL)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+! Janv 2001
+ CALL FMLOOK(YNAMTABCOL,CLUOUT,ILUCOL,IRESP)
+ IF(IRESP /= 0)THEN
+! Janv 2001
+ CALL CREATLINK('DIRCOL',YNAMTABCOL,'CREAT',NVERBIA)
+ CALL FMATTR(YNAMTABCOL,CLUOUT,ILUCOL,IRESP)
+ OPEN(UNIT=ILUCOL,FILE=YNAMTABCOL,FORM='FORMATTED')
+! Janv 2001
+ ENDIF
+! Janv 2001
+ END IF
+ WRITE(NLUOUT,*)' <<< ',YNAMTABCOL,' >>>'
+ REWIND (ILUCOL)
+ CALL GQOPS(ISTA)
+ CALL GQACWK(1,IER,INB,IWK)
+!print *,' COLOR_FORDIACHRO AP GQACWK INB IWK ',INB,IWK
+ CALL GQOPWK(1,IER,INB,IWK)
+! Lecture du nb de couleurs de la table, des index de couleur et des
+! proportions relatives de rouge, vert, bleu
+ READ(ILUCOL,*)INBCT
+ DO J=1,INBCT
+ READ(ILUCOL,*)IDX,RED,GREEN,BLUE
+ DO JU=1,INB
+ CALL GQOPWK(JU,IER,INBB,IWK)
+ IF(IWK == 9)THEN
+ CYCLE
+ ELSE
+ CALL GSCR(IWK,IDX,RED,GREEN,BLUE)
+! CALL GSCR(1,IDX,RED,GREEN,BLUE)
+ ENDIF
+ ENDDO
+ ENDDO
+ END IF
+! Pour 1 dessin donne, lecture du nb d'indices de couleurs et de leur valeur
+! sur la ligne suivante
+ DO J=1,300
+ ICOL(J)=1
+ ENDDO
+ READ(5,*,END=22)INBC
+ GO TO 23
+ 22 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez le nb d indices de couleur'
+ READ(5,*)INBC
+ 23 CONTINUE
+ !WRITE(YCAR80,*)INBC
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,INBC)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ READ(5,*,END=24)(ICOL(J),J=1,INBC)
+ GO TO 25
+ 24 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez la valeur des indices de couleur'
+ READ(5,*)(ICOL(J),J=1,INBC)
+ 25 CONTINUE
+ ! WRITE(YCAR320,*)ICOL(1:INBC)
+ ! YCAR320=ADJUSTL(YCAR320)
+ ! ILENT=LEN_TRIM(YCAR320)
+ ILENT=INBC*4
+ IF(ILENT == 80 ) THEN
+ ! YCAR320=TRIM(YCAR320)//' '
+ ILENT=ILENT+1
+ END IF
+ IF(ILENT > 240 )THEN
+ ! WRITE(YCAR80,*)ICOL(1:INBC/4)
+ CALL WRITEDIR(NDIR,ICOL(1:INBC/4))
+ ! WRITE(YCAR80,*)ICOL(INBC/4+1:INBC/2)
+ CALL WRITEDIR(NDIR,ICOL(INBC/4+1:INBC/2))
+ ! WRITE(YCAR80,*)ICOL(INBC/2+1:3*INBC/4)
+ CALL WRITEDIR(NDIR,ICOL(INBC/2+1:3*INBC/4))
+ ! WRITE(YCAR80,*)ICOL(3*INBC/4+1:INBC)
+ CALL WRITEDIR(NDIR,ICOL(3*INBC/4+1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ELSE IF(ILENT > 160 )THEN
+ ! WRITE(YCAR80,*)ICOL(1:INBC/3)
+ CALL WRITEDIR(NDIR,ICOL(1:INBC/3))
+ ! WRITE(YCAR80,*)ICOL(INBC/3+1:2*INBC/3)
+ CALL WRITEDIR(NDIR,ICOL(INBC/3+1:2*INBC/3))
+ ! WRITE(YCAR80,*)ICOL(2*INBC/3+1:INBC)
+ CALL WRITEDIR(NDIR,ICOL(2*INBC/3+1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ELSE IF(ILENT > 80 )THEN
+ ! WRITE(YCAR80,*)ICOL(1:INBC/2)
+ CALL WRITEDIR(NDIR,ICOL(1:INBC/2))
+ ! WRITE(YCAR80,*)ICOL(INBC/2+1:INBC)
+ CALL WRITEDIR(NDIR,ICOL(INBC/2+1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ELSE
+ ! WRITE(YCAR80,*)ICOL(1:INBC)
+ CALL WRITEDIR(NDIR,ICOL(1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ENDIF
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('CLC',ICOL(J))
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ CALL GENFORMAT_FORDIACHRO(ZCLV,YLLBS(J))
+ ENDDO
+ WRITE(NLUOUT,*)' >>>>>>>IMAGE_FORDIACHRO VARIABLE : ',HTEXTE,' NB ISOC. : ',INCL,' VALEURS:'
+ WRITE(NLUOUT,*)(ZLEV(J),ICOL(J),J=1,INCL)
+
+ END IF !::::::::::::::::::::::::::::::::::::
+
+!Mai 2009
+ IF(LNOLBLBAR)THEN
+ ELSE
+!Mai 2009
+!Mars 2000
+ IF(LCOLISONE)THEN
+ ELSE
+!Mars 2000
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ CALL GSFAIS(0)
+ CALL SET(ZVR,1.,ZVB,ZVT,ZVR,1.,ZVB,ZVT,1)
+ IF(INCL <= 1)THEN
+ ZINTERV=0.
+ ELSE
+ ZINTERV=(ZVT-ZVB-.009)/(INCL-1)
+ ENDIF
+ CALL GSCLIP(0)
+ DO J=1,INCL
+ YLLBS(J)=ADJUSTL(YLLBS(J))
+ CALL GSPLCI(ICOL(J))
+ CALL GSTXCI(ICOL(J))
+ IF(ZVR < .9 .AND. INCL < 25)THEN
+ CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.015,0.,-1.)
+ ELSEIF(ZVR < .9 .AND. INCL < 30 .AND. INCL >= 25)THEN
+ CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.012,0.,-1.)
+ ELSEIF(ZVR >= .95 )THEN
+ CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.007,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.009,0.,-1.)
+ ENDIF
+! CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.007,0.,-1.)
+ ENDDO
+ CALL GSCLIP(1)
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!Mars 2000
+ ENDIF
+!Mars 2000
+!Mai 2009
+ ENDIF
+!Mai 2009
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+
+
+ END IF !............................................
+
+ELSE !+++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!***************************************************
+! Traits noir et blanc (LCOLAREA=.FALSE. et LCOLINE=.FALSE.)
+!***************************************************
+
+ CALL GSPLCI(1)
+
+ IF(LSUPER)THEN !!! Overlay case
+
+
+ IF(NSUPER == 1)THEN ! If first plot of an overlay: default
+ CALL GSLN(1) ! Line is solid
+
+ ELSE ! If subsequent plots of an overlay: default
+ IF(LINVPTIR)THEN
+
+ IF(NSUPER ==2)CALL GSLN(2) ! line is a special dash type
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==2)CALL GSLN(1)
+ IF(NSUPER ==3)CALL GSLN(3)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==3)THEN
+ CALL GSLN(1)
+ CALL GSLN(2)
+ IF(LHACH2)CALL GSLN(1)
+ ENDIF
+
+ ELSE
+
+ IF(NSUPER ==2)CALL GSLN(3) ! line is a special dash type
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==2) &
+ CALL GSLN(1)
+ IF(NSUPER ==3)CALL GSLN(2)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER ==3)THEN
+ CALL GSLN(1)
+ CALL GSLN(3)
+ IF(LHACH2)CALL GSLN(1)
+ ENDIF
+
+ ENDIF
+
+ END IF
+
+ END IF !!! Not an overlay case
+!
+END IF !+++++++++++++++++++++++++++++++++++++++++++++++++++++
+!
+!* 3.3 High and low handling
+!
+IF (nverbia >=5) THEN
+ print *,'image KNHI=',KNHI
+END IF
+SELECT CASE(KNHI)
+
+ CASE(0) ! H + L are displayed
+! Test rajoute pour eviter la superposition de CONSTANT FIELD ici et ensuite
+! avec le 2eme CPLBDR utile en cas de surfaces colorees
+ IF(INCL /= 0)THEN
+ CALL CPLBDR(PTAB,ZRWRK,IWRK)
+ ENDIF
+ CASE DEFAULT ! TO BE REVISED*********************
+ ! <0 --> no action (:-1 to be set)
+ ! >0 --> gridpoint value displayed
+ ! (1: to be set)
+END SELECT
+!
+!* 3.4 Effective contour drawing and line width selection
+!
+IF(ZMIN == 999999. .AND. ZMAX == -999999.)THEN
+ CALL CPSETC('CFT','CONSTANT FIELD - SPECIAL VALUE 999.')
+ENDIF
+GISO=LISO .AND. .NOT.(LSPOT .OR. LMARKER)
+IF((LCOLAREA .AND. .NOT.GISO .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1)))&
+ .OR.(LHACH1 .AND. .NOT.LISO .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1)))&
+ .OR.(LGREY .AND. .NOT.LISO .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1)))&
+ .OR. (LHACH2 .AND. .NOT.LISO .AND. NSUPER == 2) &
+ .OR. (LHACH3 .AND. .NOT.LISO .AND. NSUPER == 3) &
+ .OR. (LHACH4 .AND. .NOT.LISO .AND. NSUPER == 4) ) THEN
+ELSE
+ CALL GSLWSC(XLWIDTH)
+ IF(NSUPER == 2 .AND. LISOWHI2)THEN
+ CALL GSLN(1)
+ CALL GSPLCI(0)
+ CALL GSTXCI(0)
+ ELSE IF(NSUPER == 3 .AND. LISOWHI3)THEN
+ CALL GSLN(1)
+ CALL GSPLCI(0)
+ CALL GSTXCI(0)
+ ENDIF
+ IF (nverbia >=5) THEN
+ print *,'image av CPCLDR'
+ END IF
+ CALL CPCLDR(PTAB,ZRWRK,IWRK)
+ ! message d erreur pour grd tableau: comment corriger ??
+ !CPGIWS 50100 WORDS REQUESTED 50000 WORDS AVAILABLE
+ IF (nverbia >=5) THEN
+ print *,'image ap CPCLDR'
+ END IF
+END IF
+IF((NSUPER == 2 .AND. LISOWHI2) .OR. (NSUPER == 3 .AND. LISOWHI3))THEN
+! CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ENDIF
+IF(INCL == 0)THEN
+ CALL CPLBDR(PTAB,ZRWRK,IWRK)
+ENDIF
+
+IF (nverbia >=5) THEN
+ print *,'image avant CALL GSCLIP '
+END IF
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZVL,ZVR,ZVB,ZVT,1)
+CALL GSCLIP(0)
+
+YTEM40(1:LEN(YTEM40))=' '
+IF(NLOOPSUPER == 1)THEN
+ CALL RESOLV_TIT('CTITVAR1',YTEM40)
+ELSE IF(NLOOPSUPER == 2)THEN
+ CALL RESOLV_TIT('CTITVAR2',YTEM40)
+ELSE IF(NLOOPSUPER == 3)THEN
+ CALL RESOLV_TIT('CTITVAR3',YTEM40)
+ELSE IF(NLOOPSUPER == 4)THEN
+ CALL RESOLV_TIT('CTITVAR4',YTEM40)
+ELSE IF(NLOOPSUPER == 5)THEN
+ CALL RESOLV_TIT('CTITVAR5',YTEM40)
+ELSE IF(NLOOPSUPER == 6)THEN
+ CALL RESOLV_TIT('CTITVAR6',YTEM40)
+ELSE IF(NLOOPSUPER == 7)THEN
+ CALL RESOLV_TIT('CTITVAR7',YTEM40)
+ELSE IF(NLOOPSUPER == 8)THEN
+ CALL RESOLV_TIT('CTITVAR8',YTEM40)
+ENDIF
+if(nverbia > 0)then
+ print *,' image CTITVAR ',YTEM40(1:LEN_TRIM(YTEM40))
+endif
+
+ IF(NSUPER < 4)THEN
+
+ IF((LHACH1 .AND. NSUPER == 1) .OR. (LHACH2 .AND. NSUPER == 2) .OR. &
+ (LHACH3 .AND. NSUPER == 3) .OR. (LHACH4 .AND. NSUPER == 4) ) THEN
+ ELSE
+ IF((LCOLAREA .AND. NSUPER > 1) .OR. &
+ (.NOT.LCOLAREA .AND. &
+ .NOT.((LHACH1.OR.LHACH2) .AND. NSUPERDIA == 2)))THEN
+ CALL GSLWSC(XLWIDTH)
+
+ IF(YTEM40 /= ' ')THEN
+ CALL FRSTPT(.95,.007+(NSUPER-1)*.017)
+ CALL VECTOR(.95+.03,.007+(NSUPER-1)*.017)
+ ENDIF
+
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ IF((LCOLAREA .AND. NSUPER > 1) .OR. &
+ (.NOT.LCOLAREA .AND. &
+ .NOT.((LHACH1.OR.LHACH2) .AND. NSUPERDIA == 2)))THEN
+
+ IF(YTEM40 /= ' ')THEN
+ CALL PLCHHQ(ZVLDEF+(NSUPER-4)*.25,ZVT+.01,ADJUSTL(CTIMEC(8:15)),.007,0.,-1.)
+ CALL FRSTPT(ZVLDEF+(NSUPER-4)*.25+.08,ZVT+.01)
+ CALL VECTOR(ZVLDEF+(NSUPER-4)*.25+.08+.03,ZVT+.01)
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+CALL GSLWSC(1.)
+CALL GSLN(1)
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+IF(NSUPER == 1 .OR. .NOT.LSUPER .OR. (NSUPER == 2 .AND. LISOWHI2) .OR. &
+(NSUPER == 3 .AND. LISOWHI3))THEN
+ IF(LCARTESIAN)THEN
+ CALL DEFENETRE
+ ELSE
+ CALL BCGRD_FORDIACHRO(2)
+ END IF
+ IF(LXY)THEN
+ CALL GSCLIP(0)
+ CALL TRACEXY
+ END IF
+END IF
+!------------------------------------------------------------------------------
+!
+!* 4. TOPOGRAPHY MASKING WHEN PLOTTED LEVEL INTERCEPTS TERRAIN
+! --------------------------------------------------------
+!
+! Initialization of a topographic mask using
+! the NCAR "area" features (see NCAR manual)
+!
+if(nverbia > 0)then
+ print *,' ** image AV CTYPHOR.EQ.Z'
+endif
+IF(CTYPHOR.EQ.'Z' .AND. (.NOT.LSUPER .OR. NSUPER == 1))THEN
+ ZLREF=KLREF
+ ! ! If terrain higher -> a 888. mask value is forced
+ DO J=NIINF,NISUP
+ DO JJ=NJINF,NJSUP
+ IF(ZLREF.LT.XXZS(J,JJ,NMGRID))PTAB(J-NIINF+1,JJ-NJINF+1)=888.
+ ENDDO
+ ENDDO
+ !
+ ICL=1 ! A single contour will be drawn
+ CALL CPSETI('CLS',0) ! User provided contour value
+ CALL CPSETI('HCF',1) ! Area within contour will be hatched
+ CALL CPSETC('CFT',' ') ! No 'CONSTANT FIELD' message issued
+ CALL CPSETI('NCL',ICL) ! A single contour will be drawn
+ CALL CPSETI('PAI',ICL) ! A single contour will be drawn
+ CALL CPSETI('AIA',ICL+1) ! Area number where field values are > 888.
+ CALL CPSETI('AIB',ICL) ! Area number where field values are < 888.
+ CALL CPSETI('CLU',1) ! Area without contour, if =1 unlabeled contour
+ CALL CPSETR('SPV',0.) ! Resets SPV, erases the special value setting
+ CALL CPSETR('CLV',888.) ! Value of the single contour drawn
+ !
+ ! As the topography-intercepted area has been set to 888., the rest of the
+ ! field array is set to ZZSPVAL to hide it in the subsequent processing
+ !
+ ZZSPVAL=7777.
+ WHERE(PTAB(:,:)/=888.)PTAB(:,:)=ZZSPVAL
+ WHERE(PTAB(:,::2)==888.)PTAB(:,::2)=PTAB(:,::2)+1.E-3
+ CALL CPSETR('SPV',ZZSPVAL) ! Special value = ZZSPVAL
+ !
+ ! Effective area computation and contour drawing
+ !
+ CALL ARINAM(IIMAP,JPMAP) ! Initialize areas
+! call mapbla(iimap)
+if(nverbia > 0)then
+ print *,' ** image AV CPRECT'
+endif
+ CALL CPRECT(PTAB,IM,IM,IL,ZRWRK,JPLRWK,IWRK,JPLIWK) ! Initialize conpack
+ CALL CPCLAM(PTAB,ZRWRK,IWRK,IIMAP) ! Contours terrain area
+ CALL CPCLDR(PTAB,ZRWRK,IWRK) ! Contours outside field
+ CALL ARSCAM(IIMAP,ZXWRK,ZYWRK,JPWRK,IAREA,IGRP,JPAREAGRP,SFILL)! Hatches
+ ! !terrain area
+END IF
+!
+!-----------------------------------------------------------------------------
+!
+!* 5. COMPLETING THE PLOT
+! -------------------
+!
+!* 5.1 Page information labels
+!
+CALL GSCLIP(0)
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+XCURVPTL=ZVL;XCURVPTR=ZVR;XCURVPTB=ZVB;XCURVPTT=ZVT
+
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZVL,ZVR,ZVB,ZVT,1)
+IF(CTYPHOR == 'T')THEN
+ IF(.NOT.LTHSTAB)THEN
+ CALL PLCHHQ(ZVL+.04,ZVT-.04,'*** UNSTABLE THETA ***',.011,0.,-1.)
+ ENDIF
+ELSE IF(CTYPHOR == 'E')THEN
+ IF(.NOT.LTHSTAB)THEN
+ CALL PLCHHQ(ZVL+.04,ZVT-.04,'*** VORTICITE NON MONOTONE ***',.011,0.,-1.)
+ ENDIF
+ELSE IF(CTYPHOR == 'V')THEN
+ IF(.NOT.LTHSTAB)THEN
+ CALL PLCHHQ(ZVL+.04,ZVT-.04,'*** FONCTION NON MONOTONE ***',.011,0.,-1.)
+ ENDIF
+
+ENDIF
+IF(.NOT.LSUPER)THEN
+
+! Modifs du 03/04/96
+ IF(LEN_TRIM(HTEXTE) > 25)THEN !+++++++++++++
+ ZSZTITVAR1=.009
+ ELSE
+ ZSZTITVAR1=.011
+ ENDIF
+ IF(XSZTITVAR1 /= 0.)THEN
+ ZSZTITVAR1=XSZTITVAR1
+ ENDIF
+ IF(LCOLAREA .OR. LHACH1 .OR. LGREY)THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ CALL RESOLV_TIT('CTITVAR1',HTEXTE)
+ IF(HTEXTE /= ' ')THEN
+ CALL PLCHHQ(MAX(ZVR,.99),.007,HTEXTE,ZSZTITVAR1,0.,+1.)
+! CALL PLCHHQ(MAX(ZVR,.99),.007,HTEXTE,.011,0.,+1.)
+ ENDIF
+
+ ELSE
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ CALL RESOLV_TIT('CTITVAR1',HTEXTE)
+ IF(HTEXTE /= ' ')THEN
+ CALL PLCHHQ(.93,.007,HTEXTE,ZSZTITVAR1,0.,+1.)
+! CALL PLCHHQ(.93,.007,HTEXTE,.011,0.,+1.)
+ ENDIF
+
+ ENDIF
+ IF(LMINMAX)THEN
+ CALL PCSETC('FC','/')
+ CAll PLCHHQ(ZVR,ZVT+.03,YLBL,.009,0.,+1.)
+ CALL PCSETC('FC',':')
+ ENDIF
+
+ELSE
+
+ ZSZTITVAR=0.
+ IF(NLOOPSUPER == 1)THEN
+ CALL RESOLV_TIT('CTITVAR1',HTEXTE)
+ IF(XSZTITVAR1 /= 0.)THEN
+ ZSZTITVAR=XSZTITVAR1
+ ENDIF
+ ELSE IF(NLOOPSUPER == 2)THEN
+ CALL RESOLV_TIT('CTITVAR2',HTEXTE)
+ IF(XSZTITVAR2 /= 0.)THEN
+ ZSZTITVAR=XSZTITVAR2
+ ENDIF
+ ELSE IF(NLOOPSUPER == 3)THEN
+ CALL RESOLV_TIT('CTITVAR3',HTEXTE)
+ IF(XSZTITVAR3 /= 0.)THEN
+ ZSZTITVAR=XSZTITVAR3
+ ENDIF
+ ELSE IF(NLOOPSUPER == 4)THEN
+ CALL RESOLV_TIT('CTITVAR4',HTEXTE)
+ IF(XSZTITVAR4 /= 0.)THEN
+ ZSZTITVAR=XSZTITVAR4
+ ENDIF
+ ELSE IF(NLOOPSUPER == 5)THEN
+ CALL RESOLV_TIT('CTITVAR5',HTEXTE)
+ IF(XSZTITVAR5 /= 0.)THEN
+ ZSZTITVAR=XSZTITVAR5
+ ENDIF
+ ELSE IF(NLOOPSUPER == 6)THEN
+ CALL RESOLV_TIT('CTITVAR6',HTEXTE)
+ IF(XSZTITVAR6 /= 0.)THEN
+ ZSZTITVAR=XSZTITVAR6
+ ENDIF
+ ELSE IF(NLOOPSUPER == 7)THEN
+ CALL RESOLV_TIT('CTITVAR7',HTEXTE)
+ IF(XSZTITVAR7 /= 0.)THEN
+ ZSZTITVAR=XSZTITVAR7
+ ENDIF
+ ELSE IF(NLOOPSUPER == 8)THEN
+ CALL RESOLV_TIT('CTITVAR8',HTEXTE)
+ IF(XSZTITVAR8 /= 0.)THEN
+ ZSZTITVAR=XSZTITVAR8
+ ENDIF
+ ENDIF
+if(nverbia > 0)then
+ print *,' image CTITVAR ',HTEXTE(1:LEN_TRIM(HTEXTE))
+endif
+
+! Modifs du 03/04/96 NON NON REFLECHIR EN CAS DE SUPERPOSITIONS
+ IF(NSUPER < 4)THEN
+
+ IF(NSUPER == 1)ZSC=999.
+ IF(LEN_TRIM(HTEXTE) > 25)THEN !+++++++++++++
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ IF((LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER == 1)THEN !000000000000
+
+ IF(HTEXTE /= ' ')THEN
+ IF(ZSZTITVAR /= 0.)THEN
+ CALL PLCHHQ(MAX(ZVR,.99),.007+(NSUPER-1)*.017,HTEXTE,ZSZTITVAR,0.,+1.)
+ ELSE
+ CALL PLCHHQ(MAX(ZVR,.99),.007+(NSUPER-1)*.017,HTEXTE,.005,0.,+1.)
+ ENDIF
+ ENDIF
+
+ ELSE !00000000000000000000
+ IF((LHACH2 .AND. NSUPER == 2) .OR. (LHACH3 .AND. NSUPER == 3) .OR. &
+ (LHACH4 .AND. NSUPER == 4) ) THEN
+
+ IF(IHT == 1)THEN
+ IF(HTEXTE /= ' ')THEN
+ IF(ZSZTITVAR /= 0.)THEN
+ CALL PLCHHQ(ZD,ZVT+.04,HTEXTE,ZSZTITVAR,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZD,ZVT+.04,HTEXTE,.007,0.,-1.)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(HTEXTE /= ' ')THEN
+ IF(ZSZTITVAR /= 0.)THEN
+ CALL PLCHHQ(ZD,ZVT+.04,HTEXTE,ZSZTITVAR,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZD,ZVT+.04,HTEXTE,.005,0.,-1.)
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE
+
+ IF(HTEXTE /= ' ')THEN
+ IF(ZSZTITVAR /= 0.)THEN
+ CALL PLCHHQ(.93,.007+(NSUPER-1)*.017,HTEXTE,ZSZTITVAR,0.,+1.)
+ ELSE
+ CALL PLCHHQ(.93,.007+(NSUPER-1)*.017,HTEXTE,.005,0.,+1.)
+ ENDIF
+ ENDIF
+
+ ENDIF
+ ENDIF !0000000000000000000
+
+ ZSC=.005
+
+ ELSE !+++++++++++++
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ IF((LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER == 1)THEN
+
+ IF(HTEXTE /= ' ')THEN
+ IF(ZSZTITVAR /= 0.)THEN
+ CALL PLCHHQ(MAX(ZVR,.99),.007+(NSUPER-1)*.017,HTEXTE,ZSZTITVAR,0.,+1.)
+ ELSE
+ CALL PLCHHQ(MAX(ZVR,.99),.007+(NSUPER-1)*.017,HTEXTE,.007,0.,+1.)
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ IF((LHACH2 .AND. NSUPER == 2) .OR. (LHACH3 .AND. NSUPER == 3) .OR. &
+ (LHACH4 .AND. NSUPER == 4))THEN
+
+ IF(HTEXTE /= ' ')THEN
+ IF(ZSZTITVAR /= 0.)THEN
+ CALL PLCHHQ(ZD,ZVT+.04,HTEXTE,ZSZTITVAR,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZD,ZVT+.04,HTEXTE,.005,0.,-1.)
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ IF(HTEXTE /= ' ')THEN
+ IF(ZSZTITVAR /= 0.)THEN
+ CALL PLCHHQ(.93,.007+(NSUPER-1)*.017,HTEXTE,ZSZTITVAR,0.,+1.)
+ ELSE
+ CALL PLCHHQ(.93,.007+(NSUPER-1)*.017,HTEXTE,.007,0.,+1.)
+ ENDIF
+ ENDIF
+
+ ENDIF
+ ENDIF
+
+ ENDIF !+++++++++++++
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ IF((LCOLAREA .OR. LHACH1 .OR. LGREY) .AND. NSUPER == 1)THEN
+
+ IF(HTEXTE /= ' ')THEN
+ CALL PLCHHQ(1.-((LEN_TRIM(HTEXTE)+5)*.007),.007+(NSUPER-1)*.017,CTIMEC(8:15),.007,0.,+1.)
+ ENDIF
+
+ ELSE
+
+ IF((LHACH2 .AND. NSUPER == 2) .OR. (LHACH3 .AND. NSUPER == 3) .OR. &
+ (LHACH4 .AND. NSUPER == 4))THEN
+!!!!!!! REFLECHIR
+! CALL PLCHHQ(ZD,ZVT+.04,HTEXTE,.005,0.,-1.)
+ ELSE
+ IF(HTEXTE /= ' ')THEN
+ CALL PLCHHQ(.93-((LEN_TRIM(HTEXTE)+4)*.007),.007+(NSUPER-1)*.017,CTIMEC(8:15),.007,0.,+1.)
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ IF(LMINMAX)THEN
+ CALL PCSETC('FC','/')
+ CAll PLCHHQ(ZVRDEF,ZVT+.01+(NSUPER-1)*.02,YLBL,.007,0.,+1.)
+ CALL PCSETC('FC',':')
+ ENDIF
+
+ ELSE
+
+ IF(ZSC /= 999.)THEN
+ IF(HTEXTE /= ' ')THEN
+ CALL PLCHHQ(ZVLDEF+(NSUPER-4)*.25,ZVT+.03,HTEXTE,ZSC,0.,-1.)
+ ENDIF
+ ELSE
+ IF(HTEXTE /= ' ')THEN
+ CALL PLCHHQ(ZVLDEF+(NSUPER-4)*.25,ZVT+.03,HTEXTE,.007,0.,-1.)
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+
+END IF
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+CALL GSLWSC(1.)
+CALL GSLN(1)
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+! Oct 99
+
+!IF(LFACTIMP)THEN
+! CALL FACTIMP
+!ENDIF
+! Oct 99
+if(nverbia > 0)then
+ print *,' ** image AV NOT LSUPER'
+endif
+IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN
+! Mars 2000
+IF(LFACTIMP)THEN
+ CALL FACTIMP
+ENDIF
+! Modifs for diachro
+! Remodifs le 170596
+! Titres en X
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(XSZTITXL /= 0.)THEN
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/2.,.05),YTEM,XSZTITXL,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/2.,YTEM,XSZTITXL,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(XSZTITXM /= 0.)THEN
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),XSZTITXM,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),XSZTITXM,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/2.,ZVB/2.,YTEM,XSZTITXM,0.,-1.)
+ ELSE
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(XSZTITXR /= 0.)THEN
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/2.,.05),YTEM,XSZTITXR,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,XSZTITXR,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+! Titres en Y
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYT',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYM',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYB',ZVL,ZVR,ZVB,ZVT,YTEM)
+! Titres TOP
+ YTEM(1:LEN(YTEM))=' '
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.95
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ ZXPOSTITT3=.002
+ ZXYPOSTITT3=.93
+ IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ ENDIF
+ IF(XYPOSTITT3 /= 0.)THEN
+ ZXYPOSTITT3=XYPOSTITT3
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT3',YTEM)
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,XSZTITT3,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+
+! Titre N1 BOTTOM
+ ZXPOSTITB1=.002
+ ZXYPOSTITB1=.005
+ IF(XPOSTITB1 /= 0.)THEN
+ ZXPOSTITB1=XPOSTITB1
+ ENDIF
+ IF(XYPOSTITB1 /= 0.)THEN
+ ZXYPOSTITB1=XYPOSTITB1
+ ENDIF
+ CALL RESOLV_TIT('CTITB1',CLEGEND)
+ IF(CLEGEND /= ' ')THEN
+ IF(XSZTITB1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,CLEGEND,XSZTITB1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,CLEGEND,.007,0.,-1.)
+ ENDIF
+ ENDIF
+! Titre N3 BOTTOM
+ ZXPOSTITB3=.002
+ ZXYPOSTITB3=.045
+ IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ ENDIF
+ IF(XYPOSTITB3 /= 0.)THEN
+ ZXYPOSTITB3=XYPOSTITB3
+ ENDIF
+ IF(LCNCUM .OR. LCNSUM)THEN
+ CALL RESOLV_TIT('CTITB3',CTIMECS)
+ IF(CTIMECS /= ' ')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTIMECS,XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTIMECS,.009,0.,-1.)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(LMINUS .OR. LPLUS)THEN
+ IF(.NOT.LTITDEFM .AND. CTITB3MEM /= 'DEFAULT' .AND. &
+ CTITB3MEM /= 'default' .AND. CTITB3MEM /= 'DEFAUT' .AND. &
+ CTITB3MEM /= 'defaut')THEN
+! Il ne faut pas mettre l'instruction suivante
+! CALL RESOLV_TIT('CTITB3',CTITB3MEM)
+ if(nverbia > 0)then
+ print *,' image CTITB3MEM ',CTITB3MEM(1:LEN_TRIM(CTITB3MEM))
+ endif
+ IF(CTITB3MEM /= ' ' .AND. CTITB3MEM /= 'WHITE' .AND. &
+ CTITB3MEM /= 'white' .AND. CTITB3MEM /= 'BLANC' .AND. &
+ CTITB3MEM /= 'blanc')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),.009,0.,-1.)
+ ENDIF
+ ENDIF
+ ELSE
+! ******************** 200697 ***************
+ CALL RESOLV_TIT('CTITB3',CTITB3)
+ if(nverbia > 0)then
+ print *,' image CTITB3 ',CTITB3(1:LEN_TRIM(CTITB3))
+ endif
+ IF(CTITB3 /= ' ')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3,XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3,.009,0.,-1.)
+ ENDIF
+ ENDIF
+ ENDIF
+! ******************** 200697 ***************
+ ELSE
+
+ IF(CSTORAGE_TYPE /= 'PG')THEN
+! NBPMT=nb de + et -
+ IF(NBPMT == 0)THEN
+ YTEM(1:LEN(YTEM))=' '
+ YTEM=CTIMEC
+ YTEM=ADJUSTL(YTEM)
+ CALL RESOLV_TIT('CTITB3',YTEM)
+ if(nverbia > 0)then
+ print *,' image LEN et CTIMEC ',LEN(CTIMEC),CTIMEC
+ print *,' image LEN et YTEM ',LEN(YTEM),YTEM
+ endif
+ IF(YTEM/= ' ')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,.009,0.,-1.)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ENDIF
+ ENDIF
+! Titre N2 BOTTOM
+ ZXPOSTITB2=.002
+ ZXYPOSTITB2=.025
+ IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ ENDIF
+ IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ ENDIF
+ CALL RESOLV_TIT('CTITB2',CLEGEND2)
+ IF(CLEGEND2 /= ' ')THEN
+ IF(XSZTITB2 /= 0.)THEN
+ CALL PLCHHQ(0.002,0.025,CLEGEND2,XSZTITB2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
+ ENDIF
+ ENDIF
+! Titre N1 TOP
+ ZXPOSTITT1=.002
+ ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+ WRITE(YPLANH,1001)NIINF,NISUP,NJINF,NJSUP
+ CALL RESOLV_TIT('CTITT1',YPLANH)
+ IF(YPLANH /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YPLANH,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YPLANH,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YPLANH,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YPLANH,.012,0.,-1.)
+ ENDIF
+ ENDIF
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ENDIF
+!
+1001 FORMAT('HORIZONTAL SECTION NIINF=',I4,' NISUP=',I4,' NJINF=',I4,' NJSUP=',I4)
+!
+CALL GSCLIP(1)
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!
+!* 5.2 NCAR parameter reset
+!
+CALL CPSETI('CLS',16)
+CALL CPRSET
+CALL GSLN(1)
+!
+!--------------------------------------------------------------------------------
+!
+!* 6. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE IMAGE_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/imagev_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/imagev_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1845f942082a05f9051e5a6e8a04d0d3c76e2d50
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/imagev_fordiachro.f90
@@ -0,0 +1,1276 @@
+! ######spl
+ SUBROUTINE IMAGEV_FORDIACHRO(PU,PV,KLREF,HTEXTE)
+! ################################################
+!
+!!**** *IMAGEV_FORDIACHRO* - Draws a vector arrow plot for an horizontal cross-section
+!!
+!! PURPOSE
+!! -------
+! Draws an arrow plot of a UV vector field re-colocated at the
+! mass gridpoint for an horizontal cross-section
+!
+!!** METHOD
+!! ------
+!!
+!! Assumption is made that wind components were re-colocated onto the mass
+!! gridpoint location prior to calling IMAGEV_FORDIACHRO. The horizontal coordinates
+!! of the mass gridpoint are first collected, next the gridmap overlay
+!! background and the display window are computed according to user requests,
+!! the visual characteritics of the plot are prescribed, and the wind
+!! arrows are plotted accounting for map projection using the VVECTR NCAR
+!! utility. If IMAGEV_FORDIACHRO works on a constant altitude or pressure level, areas
+!! where the plotting level intercepts the terrain are hatched and wind
+!! vector are hidden. Finally, various information labels are printed on
+!! the plot.
+!!
+!! Notice that a TRACE-provided VVUMXY routine is used within the NCAR
+!! vector VVECTR utility to map the wind vectors onto the stretched
+!! MESO-NH model space. Wind vectors are given in m/s and scaled by VVUMXY
+!! to obtain arrow sizes in "NCAR fractional coordinate" (NCAR User Guide
+!! "Fundamentals", Appendix A, p345 section 1), notice this is different
+!! from what is required for Conpack... The final result is an automatic
+!! arrow scale selection giving a maximum arrow size equal to the meshlength
+!! on the plot. If a different procedure has to be followed VVUMXY should
+!! be updated accordingly. The parameters of the NCAR VVECTR utility can
+!! be printed online by typing "man vectors_params", these feature are not
+!! really documented elsewhere in NCAR user guide.
+!!
+!! Further, notice that the Meso-NH model usually provides the so-called
+!! covariant wind components in the LFIFM files (multiplied by rho_~_*).
+!! If this assumption is made, the wind modulus of the displayed wind is
+!! equal to the modulus of the real meteorological wind on the spherical
+!! earth.
+!!
+!! EXTERNAL
+!! --------
+!! DEFENETRE : when cartesian geometry applies, defines the !
+!! display window !
+!! BCGRD : when a cartographic projection applies, defines !
+!! displayed !
+!! window and draws the continent/state outlines !
+!! GSCLIP : clips items getting out of the drawing window !
+!! GETSET : retrieves the normalized and user NCAR !
+!! coordinates of a previously used window !
+!! PLCHHQ : prints high-quality character strings !
+!! !
+!! VVSETR ! : gets the value of a NCAR parameter, REEL !
+!! VVSETI ! INTEGER !
+!! VVINIT : initialize a vector plot (arrows) !
+!! VVECTR : draws the arrows for a vector plot !
+!! !
+!! CPSETI ! INTEGER !
+!! CPSETR ! : sets the value of a NCAR parameter, REEL !
+!! CPSETC ! CHARACTER ! NCAR
+!! !
+!! CPGETI ! INTEGER !
+!! CPGETR ! : gets the value of a NCAR parameter, REEL !
+!! CPGETC ! CHARACTER !
+!! !
+!! CPRECT : Conpack initialization (contours) !
+!! CPCLDR : draws contours ! Routines
+!! GSLWSC : sets line width !
+!! !
+!! ARINAM : initialize the contour calculation as a subset !
+!! of areas, which may be adressed individually to !
+!! modify their display characteristics (used for !
+!! topography masking here). !
+!! ARSCAM : scans the plotting domain and defines the !
+!! different areas, then performs the processing !
+!! defined in the SFILL routine (here, hatch fill) !
+!! CPCLAM : adds contour in a previously defined area !
+!! CPRSET : resets Conpack parameters to default values !
+!!
+!!
+!! VVUMXY : TRACE provided FORTRAN-77 routine directly called
+!! within the VVECTR NCAR utility to to map the wind
+!! vectors onto the stretched MESO-NH model space.
+!! CPMPXY : TRACE provided FORTRAN-77 routine directly called
+!! within CONPACK to map the array space onto the
+!! cartographic space
+!! SFILL : TRACE provided FORTAN-77 routine directly called
+!! CONPACK to define the hatched area used to locate
+!! points where the plot level intercepts topography
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_TITLE : Declares heading variables for the plots (TRACE)
+!! CLEGEND: Current plot heading title
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX,XXY : coordinate values for all the MESO-NH grids
+!! XXZS : topography values for all the MESO_NH grids
+!!
+!! Module MODD_CONF : declares configuration variables of all models
+!! LCARTESIAN: Logical for cartesian geometry :
+!! .TRUE. = cartesian geometry
+!! .FALSE. = conformal projection
+!!
+!! Module MODN_PARA : defines NAM_DOMAIN_POS namelist
+!! LHORIZ : must be .TRUE. to perform horizontal cross esctions
+!! LVERTI : must be .FALSE. to perform horizontal cross sections
+!! Module MODD_DIM1 : Contains dimensions
+!! NIMAX, NJMAX : x, and y array dimensions
+!! NIINF, NISUP : Lower and upper array bounds in x direction
+!! NJINF, NJSUP : Lower bound and upper bound in y direction
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!! CTYPHOR : Horizontal cross-section type
+!! (='K' --> model level section;
+!! ='Z' --> constant-altitude section;
+!! ='P' --> isobar section (planned)
+!! ='T' --> isentrope section (planned)
+!! XSPVAL : Special value
+!! NISKIP : Sampling rate for drawing velocity vectors
+!!
+!! Module MODD_OUT : Defines a log. unit for printing
+!! NIMAXT : x-size of the displayed section of the model array
+!! NJMAXT : y-size of the displayed section of the model array
+!!
+!! Module MODD_TIME ! To be checked, useless..
+!! Module MODD_TIME1 ! To be checked, useless.
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 13/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_COORD
+USE MODD_CONF
+USE MODD_GRID
+USE MODD_GRID1
+USE MODE_GRIDPROJ
+USE MODD_TITLE
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_OUT
+USE MODN_PARA
+USE MODN_NCAR
+USE MODD_TIME
+USE MODD_TIME1
+USE MODD_SUPER
+USE MODD_RESOLVCAR
+USE MODD_TIT
+USE MODD_PVT
+USE MODD_MEMCV
+USE MODD_CTL_AXES_AND_STYL
+USE MODI_RESOLV_TIT
+USE MODI_RESOLV_TITY
+USE MODI_COMPUTEDIR
+!
+IMPLICIT NONE
+
+INTERFACE
+ SUBROUTINE IMAGE_FORDIACHRO(PTAB,KLREF,PTABINT,KNHI,KNDOT,HTEXTE)
+ CHARACTER(LEN=*) :: HTEXTE
+ REAL :: PTABINT
+ REAL,DIMENSION(:,:) :: PTAB
+ INTEGER :: KNHI, KNDOT, KLREF
+ END SUBROUTINE IMAGE_FORDIACHRO
+END INTERFACE
+!
+!* 0.0 TRACE interface with the "VVUMXY" routine of the NCAR package
+!
+! NOTICE: The TRACE provided VVUMXY routine and the NCAR graphical utilities
+! ------ are NOT written in Fortran 90, but in Fortran 77.. This sub-section
+! of TRACE does not follow the Meso-NH usual rules: it has to be made
+! using a COMMON stack with static memory allocation of XZZXX and
+! XZZXY arrays.
+!
+!
+COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+COMMON/TEMH/XZZX,XZZY,NIIMAX,NIJMAX
+#include "big.h"
+REAL,DIMENSION(N2DVERTX) :: XZZX
+REAL,DIMENSION(N2DVERTX) :: XZZY
+INTEGER :: NIIMAX, NIJMAX
+LOGICAL :: LVERT, LHOR,LPT, LXABS
+!
+!* 0.1 NCAR work arrays
+!
+! See aforementioned notice. The dimensions of these arrays are
+! subject to possible tuning, but have to be prescribed. Add
+! extra size if necessary.
+!
+INTEGER,PARAMETER :: JPLRWK=50000, JPLIWK=50000
+INTEGER,PARAMETER :: JPRSCR=10000, JPISCR=10000
+INTEGER,PARAMETER :: JPMAP=800000, JPAREAGRP=300, JPWRK=50000
+
+REAL,DIMENSION(JPLRWK):: ZRWRK
+INTEGER,DIMENSION(JPLIWK):: IWRK
+!REAL,DIMENSION(JPRSCR):: ZRSCR
+!INTEGER,DIMENSION(JPISCR):: ISCR
+INTEGER,DIMENSION(JPMAP):: IIMAP
+INTEGER,DIMENSION(JPAREAGRP):: IAREA, IGRP
+REAL,DIMENSION(JPWRK) :: ZXWRK, ZYWRK
+!
+!* 0.2 Dummy arguments and results
+!
+INTEGER :: KLREF ! Cross-section altitude (or Model Level
+ ! or Pressure depending on user's vertical
+ ! coordinate choice)
+CHARACTER(LEN=*) :: HTEXTE ! Plot heading contataining field name
+REAL,DIMENSION(:,:) :: PU,PV ! Arrays of "wind components" to be plotted
+!
+!* 0.3 Local variables
+!
+INTEGER :: JILOOP, JJLOOP, IUB1, IUB2, ID, J, IJ, JA
+INTEGER :: ICL
+
+INTEGER :: IZS
+
+INTEGER :: ITER, JTER, ISKIP, IGRNC
+INTEGER :: II, INUM, IRESP, ILOOP, IDEB, IFIN
+INTEGER :: JLOOPI, JLOOPJ
+
+CHARACTER(LEN=70) :: YPLANH, YTEM
+CHARACTER(LEN=40) :: YTEXTE
+CHARACTER(LEN=4) :: YTE, YC4, YC42
+!
+REAL :: ZLREF, ZZSPVAL, ZY, ZINTX, ZINTY
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZZU,ZZV
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZSTRU,ZSTRV
+!REAL,DIMENSION(SIZE(PU,1),SIZE(PU,2)) :: ZZU, ZZV
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZZY, ZTEMX,ZTEMY
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZX, ZLAT, ZLON, ZYY
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZDIRU, ZDIRV, ZLA, ZLO
+REAL :: ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+REAL :: ZVINT, ZVY
+REAL :: ZXPOSTITT1, ZXYPOSTITT1
+REAL :: ZXPOSTITT2, ZXYPOSTITT2
+REAL :: ZXPOSTITT3, ZXYPOSTITT3
+REAL :: ZXPOSTITB1, ZXYPOSTITB1
+REAL :: ZXPOSTITB2, ZXYPOSTITB2
+REAL,SAVE :: ZXPOSTITB3, ZXYPOSTITB3
+REAL,DIMENSION(18) :: ZCOL
+
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZSTR1
+
+INTEGER,DIMENSION(18) :: ICOL
+INTEGER :: ICOL1,IER
+LOGICAL,SAVE :: GVSUPSCA
+!
+!* 0.4 External for NCAR use
+!
+! SFILL subroutine declared as external provides area control
+! in some parts of the contour plot.
+!
+EXTERNAL SFILL
+EXTERNAL STUMXY
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DISPLAY ENVIRONMENT SETUP AND ARROWS PLOTTING
+! ---------------------------------------------
+!
+!* 1.1 Array sizes calculation and default field value
+!
+IUB1=UBOUND(PU,1)
+IUB2=UBOUND(PU,2)
+IF(ALLOCATED(ZZU))THEN
+ DEALLOCATE(ZZU)
+ENDIF
+IF(ALLOCATED(ZZV))THEN
+ DEALLOCATE(ZZV)
+ENDIF
+ALLOCATE(ZZU(SIZE(PU,1),SIZE(PU,2)),ZZV(SIZE(PU,1),SIZE(PU,2)))
+
+!
+!DO JJLOOP=1,NJMAXT
+DO JJLOOP=1,IUB2
+! DO JILOOP=1,NIMAXT
+ DO JILOOP=1,IUB1
+ ZZU(JILOOP,JJLOOP)=XSPVAL
+ ZZV(JILOOP,JJLOOP)=XSPVAL
+ ENDDO
+ENDDO
+!
+!* 1.2 Collects XHAT and YHAT values at mass gridpoints (NGRID=1)
+!* where wind components have been relocated in TRACEH
+!
+DO JILOOP=NIINF,NISUP
+ XZZX(JILOOP-NIINF+1)=XXX(JILOOP,1)
+!XZZX(JILOOP-NIINF+1)=XXX(JILOOP,NMGRID)
+ENDDO
+DO JJLOOP=NJINF,NJSUP
+ XZZY(JJLOOP-NJINF+1)=XXY(JJLOOP,1)
+!XZZY(JJLOOP-NJINF+1)=XXY(JJLOOP,NMGRID)
+ENDDO
+!
+!* 1.3 Collects wind values within the user postprocessing
+!* window with a sampling rate of NISKIP outside values
+!* are kept to default
+!
+!DO JJLOOP=1,NJMAXT,NISKIP
+DO JJLOOP=1,IUB2,NISKIP
+! DO JILOOP=1,NIMAXT,NISKIP
+ DO JILOOP=1,IUB1,NISKIP
+ ZZU(JILOOP,JJLOOP)=PU(JILOOP,JJLOOP)
+ ZZV(JILOOP,JJLOOP)=PV(JILOOP,JJLOOP)
+ ENDDO
+ENDDO
+!!!!!!!!!!!!!!!STREAM
+IF(LSTREAM)THEN
+ ITER=IUB1/NISKIP+1
+ IF(1+(ITER-1)*NISKIP > IUB1)ITER=ITER-1
+ JTER=IUB2/NISKIP+1
+ IF(1+(JTER-1)*NISKIP > IUB2)JTER=JTER-1
+ ALLOCATE(ZDIRU(ITER,JTER),ZDIRV(ITER,JTER))
+ ALLOCATE(ZX(ITER,1),ZZY(JTER))
+ ALLOCATE(ZTEMX(IUB1),ZTEMY(IUB2))
+ ZTEMX(1:IUB1)=XZZX(1:IUB1)
+ ZTEMY(1:IUB2)=XZZY(1:IUB2)
+ ZX(:,1)=XZZX(1:IUB1:NISKIP)
+ ZZY=XZZY(1:IUB2:NISKIP)
+ ZDIRU=PU(1:IUB1:NISKIP,1:IUB2:NISKIP)
+ ZDIRV=PV(1:IUB1:NISKIP,1:IUB2:NISKIP)
+! print *,' **deallocate ZZU ZZV'
+ ALLOCATE(ZSTRU(ITER,JTER),ZSTRV(ITER,JTER))
+
+ DO JJLOOP=1,JTER
+ DO JILOOP=1,ITER
+ ZSTRU(JILOOP,JJLOOP)=ZDIRU(JILOOP,JJLOOP)
+ ZSTRV(JILOOP,JJLOOP)=ZDIRV(JILOOP,JJLOOP)
+ ENDDO
+ ENDDO
+ XZZX(1:ITER)=ZX(:,1)
+ XZZY(1:JTER)=ZZY
+! IUB1=ITER
+! IUB2=JTER
+ DEALLOCATE(ZDIRU,ZDIRV,ZX,ZZY)
+!!!!!!!!!!!!!!!STREAM
+ALLOCATE(ZSTR1(4*ITER*JTER))
+!!!!!!!!!!!!!!!STREAM
+ENDIF
+!!!!!!!!!!!!!!!STREAM
+!
+IF(LDIRWIND)THEN
+ ISKIP=NISKIP
+ NISKIP=1
+ IGRNC=NIGRNC
+ NIGRNC=5
+ENDIF
+
+!000000000000000000000000000000000000000000000000000000000000000
+IF(LDIRWIND)THEN
+!000000000000000000000000000000000000000000000000000000000000000
+ print *,' imagev LDIRWIND ',LDIRWIND
+ YTEXTE(1:LEN(YTEXTE))=' '
+ YTEXTE='WIND-DIRECTION'
+ YTEXTE=ADJUSTL(YTEXTE)
+ ITER=IUB1/NISKIP+1
+ IF(1+(ITER-1)*NISKIP > IUB1)ITER=ITER-1
+ JTER=IUB2/NISKIP+1
+ IF(1+(JTER-1)*NISKIP > IUB2)JTER=JTER-1
+ ALLOCATE(ZDIRU(ITER,JTER),ZDIRV(ITER,JTER))
+ ALLOCATE(ZX(ITER,1),ZZY(JTER))
+ ZX(:,1)=XZZX(1:IUB1:NISKIP)
+ ZZY=XZZY(1:IUB2:NISKIP)
+ ZDIRU=PU(1:IUB1:NISKIP,1:IUB2:NISKIP)
+ ZDIRV=PV(1:IUB1:NISKIP,1:IUB2:NISKIP)
+ print*,'imagev dd ',minval(ZDIRU),maxval(ZDIRU),minval(ZDIRV), maxval(ZDIRV)
+ CALL COMPUTEDIR(ITER,JTER,IUB1,IUB2,NISKIP,ZDIRU,ZDIRV)
+ print*,'imagev dd ',minval(ZDIRV), maxval(ZDIRV)
+!! Supprime en nov 2001 Appel routine COMPUTEDIR
+!! Supprime en nov 2001 Appel routine COMPUTEDIR
+ IF(LSUPER)THEN
+ NSUPER=NSUPER+1
+ print *,' ** imagev DIRWIND NSUPER ',NSUPER
+ IF(NSUPER == 1)THEN
+ IF(.NOT.LCARTESIAN)CALL BCGRD_FORDIACHRO(1)
+ IF(LCARTESIAN)CALL DEFENETRE
+ END IF
+ ELSE
+ IF(.NOT.LCARTESIAN)CALL BCGRD_FORDIACHRO(1)
+ IF(LCARTESIAN)CALL DEFENETRE
+ END IF
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+! CALL SET(ZVL,ZVR,ZVB,ZVT,ZX(1,1),ZX(ITER,1),ZZY(1),ZZY(JTER),1)
+
+ CALL TABCOL_FORDIACHRO
+ IJ=1
+ DO J=15,345,30
+ IJ=IJ+1
+ ZCOL(IJ)=J
+ ENDDO
+ ZCOL(1)=0.
+ IJ=IJ+1
+ ZCOL(IJ)=360.
+ ICOL(1)=4; ICOL(13)=4; ICOL(2)=88; ICOL(3)=79; ICOL(4)=7
+ ICOL(5)=52; ICOL(6)=25; ICOL(7)=2; ICOL(8)=20; ICOL(9)=24
+ ICOL(10)=3; ICOL(11)=124; ICOL(12)=5; ICOL(13)=4
+ DO JJLOOP=1,JTER
+ DO JILOOP=1,ITER
+ IF(ZDIRV(JILOOP,JJLOOP) == XSPVAL)THEN
+! print *,J,' CYCLE ',ZDIRV(JILOOP,JJLOOP),ZCOL(J),ZCOL(J-1)
+ CYCLE
+ ENDIF
+ DO J=2,IJ
+! print *,J,' ',ZDIRV(JILOOP,JJLOOP),ZCOL(J),ZCOL(J-1)
+
+ IF(ZDIRV(JILOOP,JJLOOP) == 0. .OR. ZDIRV(JILOOP,JJLOOP) == 360.)THEN
+ CALL GSPMCI(ICOL(1))
+! print *,' ZDIRV(JILOOP,JJLOOP) J+2 ',ZDIRV(JILOOP,JJLOOP),ICOL(1)
+ EXIT
+ ELSE IF(ZDIRV(JILOOP,JJLOOP) < ZCOL(J).AND. &
+ ZDIRV(JILOOP,JJLOOP) >= ZCOL(J-1))THEN
+ CALL GSPMCI(ICOL(J-1))
+! print *,' ZDIRV(JILOOP,JJLOOP) J+1 ',ZDIRV(JILOOP,JJLOOP),ICOL(J)
+ EXIT
+ ENDIF
+ ENDDO
+ CALL GSMK(2)
+ ZINTX=ZX(JILOOP,1)
+ ZINTY=ZZY(JJLOOP)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(3)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(5)
+ CALL GPM(1,ZINTX,ZINTY)
+ ENDDO
+ ENDDO
+!
+! Legende couleurs
+ CALL GSCLIP(0)
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZVL,ZVR,ZVB,ZVT,1)
+ ZVINT=(ZVT-ZVB)/12.
+ ZVY=ZVB
+ YTE=' '
+ WRITE(YTE,'(F4.0)')ZCOL(1)
+ CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
+! print *,'ZVR,ZVY,YTE ',ZVR,ZVY,YTE
+ DO J=1,6
+ CALL GSPMCI(ICOL(1))
+ ZINTX=ZVR+.005*J
+ ZINTY=ZVY+.015
+ CALL GSMK(2)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(3)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(5)
+ CALL GPM(1,ZINTX,ZINTY)
+ ENDDO
+ ZVY=ZVY+ZVINT/2.
+ YTE=' '
+ WRITE(YTE,'(F4.0)')ZCOL(2)
+ CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
+! print *,'ZVR,ZVY,YTE ',ZVR,ZVY,YTE
+ DO J=1,6
+ CALL GSPMCI(ICOL(2))
+ ZINTX=ZVR+.005*J
+ ZINTY=ZVY+.015
+ CALL GSMK(2)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(3)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(5)
+ CALL GPM(1,ZINTX,ZINTY)
+ ENDDO
+ DO J=3,13
+ ZVY=ZVY+ZVINT
+ YTE=' '
+ WRITE(YTE,'(F4.0)')ZCOL(J)
+ CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
+! print *,'ZVR,ZVY,YTE ',ZVR,ZVY,YTE
+ DO JA=1,6
+ CALL GSPMCI(ICOL(J))
+ ZINTX=ZVR+.005*JA
+ ZINTY=ZVY+.015
+ CALL GSMK(2)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(3)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(5)
+ CALL GPM(1,ZINTX,ZINTY)
+ ENDDO
+ ENDDO
+ ZVY=ZVY+ZVINT/2.
+ YTE=' '
+ WRITE(YTE,'(F4.0)')ZCOL(14)
+ CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
+!
+! Titre N1 TOP
+!! WRITE(YPLANH,1001)NIINF,NISUP,NJINF,NJSUP
+!! ZXPOSTITT1=.002
+!! ZXYPOSTITT1=.98
+!! IF(XPOSTITT1 /= 0.)THEN
+!! ZXPOSTITT1=XPOSTITT1
+!! ENDIF
+!! IF(XYPOSTITT1 /= 0.)THEN
+!! ZXYPOSTITT1=XYPOSTITT1
+!! ENDIF
+!! CALL RESOLV_TIT('CTITT1',YPLANH)
+!! IF(YPLANH /= ' ')THEN
+!! IF(XSZTITT1 /= 0.)THEN
+!! CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YPLANH,XSZTITT1,0.,-1.)
+!!! CALL PLCHHQ(0.002,0.98,YPLANH,XSZTITT1,0.,-1.)
+!! ELSE
+!! CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YPLANH,.012,0.,-1.)
+!!! CALL PLCHHQ(0.002,0.98,YPLANH,.012,0.,-1.)
+!! ENDIF
+!! ENDIF
+!! IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ IF(.NOT.LCARTESIAN)CALL BCGRD_FORDIACHRO(2)
+ if(nverbia > 0)then
+ print *,'**imagev AP CALL BCGRD_FORDIACHRO(2) 1 '
+ endif
+ CALL TABCOL_FORDIACHRO
+
+ IF(LPRINT)THEN
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ ILOOP=SIZE(ZDIRV,1)/5
+ IF(ILOOP * 5 < SIZE(ZDIRV,1))ILOOP=ILOOP+1
+ WRITE(INUM,'(''CH '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'')')CGROUP,&
+ & CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ IF(LMINUS .OR. LPLUS)THEN
+ WRITE(INUM,'(A55,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITB3(1:55)
+ ELSE
+ WRITE(INUM,'(''WIND-DIRECTION'',26X,''(NIINF-NISUP,NJINF-NJSUP)'')')
+ ! WRITE(INUM,'(A40,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITGAL
+ ENDIF
+ WRITE(INUM,'(''niinf'',i4,'' njinf'',i4,'' nisup'',i4,'' njsup'',i4,&
+ &'' '',A1,'' '',i6)')&
+ &NIINF,NJINF,NISUP,NJSUP,CTYPHOR,KLREF
+ WRITE(INUM,'(''NBVAL en I '',i4,'' NBVAL en J '',i4,'' iter'',i3)') &
+ &NISUP-NIINF+1,NJSUP-NJINF+1,ILOOP
+! JUin 2001 Ecriture des dates (Demande G.Jaubert ) si LPRDAT=T
+ IF(LPRDAT)THEN
+ IF(.NOT.ALLOCATED(XPRDAT))THEN
+ print *,'**IMAGEV XPRDAT NON ALLOUE.Dates non ecrites ds FICVAL .Prevenir J.Duron'
+ ELSE
+ WRITE(INUM,'(1X,75(1H*))')
+ WRITE(INUM,'(1X,'' Dates courante * modele * experience * segment'')')
+ WRITE(INUM,'(1X,'' J An M J Sec. * An M J Sec. * An M J Sec. * An M J Sec.'')')
+ WRITE(INUM,'(1X,75(1H*))')
+ DO J=1,SIZE(XPRDAT,2)
+ WRITE(INUM,'(1X,I3,1X,3(I4,I3,I3,I6,'' *''),I4,I3,I3,I6)')J,INT(XPRDAT(:,J))
+ ENDDO
+ ENDIF
+ ENDIF
+! JUin 2001 Ecriture des dates
+ DO JLOOPI=1,ILOOP
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=5
+ IDEB=IDEB+NIINF-1; IFIN=IFIN+NIINF-1
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+5
+ ENDIF
+ IF(JLOOPI == ILOOP)THEN
+ IFIN=SIZE(ZDIRV,1)+NIINF-1
+ ENDIF
+
+ WRITE(INUM,'(1X,78(1H*))')
+ WRITE(INUM,'('' J I-> '',3X,I4,6X,4(6X,I4,6X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'(''.'',78(1H*))')
+ DO JLOOPJ=SIZE(ZDIRV,2),1,-1
+ WRITE(INUM,'(I4,2X,5(1X,E14.7))')JLOOPJ+NJINF-1,(ZDIRV(II,JLOOPJ),II=IDEB-NIINF+1,IFIN-NIINF+1)
+
+ ! WRITE(INUM,'(I3,2X,5E15.8)')JLOOPJ+NJINF-1,(ZDIRV(II,JLOOPJ),II=IDEB-NIINF+1,IFIN-NIINF+1)
+ ENDDO
+ WRITE(INUM,'(1X,78(1H*))')
+ ENDDO
+ ENDIF
+
+ IF(LPRINTXY)THEN
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ WRITE(INUM,'(''CH XY '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'')')CGROUP,&
+ & CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ IF(LMINUS .OR. LPLUS)THEN
+ WRITE(INUM,'(A55,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITB3(1:55)
+ ELSE
+ WRITE(INUM,'(''WIND-DIRECTION'',26X,''(NIINF-NISUP,NJINF-NJSUP)'')')
+ ! WRITE(INUM,'(A40,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITGAL
+ ENDIF
+ WRITE(INUM,'(''niinf'',i4,'' njinf'',i4,'' nisup'',i4,'' njsup'',i4,&
+ &'' '',A1,'' '',i6)')&
+ &NIINF,NJINF,NISUP,NJSUP,CTYPHOR,KLREF
+ WRITE(INUM,'(''NBVAL en I '',i4,'' NBVAL en J '',i4)') &
+ &NISUP-NIINF+1,NJSUP-NJINF+1
+
+ II=MAX(SIZE(ZDIRV,1),SIZE(ZDIRV,2))
+ WRITE(INUM,'(1X,73(1H*))')
+ WRITE(INUM,'(26X,''X'',38X,''Y'')')
+ WRITE(INUM,'(1X,73(1H*))')
+ DO JLOOPJ=1,II
+ IF(JLOOPJ ==1)THEN
+ YC4=' '
+ YC42=' '
+ WRITE(YC4,'(I4,'')'')')NIINF
+ WRITE(YC42,'(I4,'')'')')NJINF
+ WRITE(INUM,'(''NIINF('',A4,I4,5X,E15.8,5X,''NJINF('',A4,I4,5X,E15.8)') &
+ YC4,JLOOPJ,XZZX(JLOOPJ),YC42,JLOOPJ,XZZY(JLOOPJ)
+ YC4=' '
+ YC42=' '
+ WRITE(YC4,'(I4,'')'')')NISUP
+ WRITE(YC42,'(I4,'')'')')NJSUP
+ ELSE
+ IF(SIZE(ZDIRV,1) > SIZE(ZDIRV,2))THEN
+ IF(JLOOPJ < SIZE(ZDIRV,2))THEN
+ WRITE(INUM,'(5X,I9,5X,E15.8,5X,5X,I9,5X,E15.8)')JLOOPJ,XZZX(JLOOPJ), &
+ JLOOPJ,XZZY(JLOOPJ)
+ ELSE IF(JLOOPJ == SIZE(ZDIRV,1))THEN
+ WRITE(INUM,'(''NISUP('',A4,I4,5X,E15.8)')YC4,JLOOPJ,XZZX(JLOOPJ)
+ WRITE(INUM,'(1X,73(1H*))')
+ ELSE IF(JLOOPJ == SIZE(ZDIRV,2))THEN
+ WRITE(INUM,'(5X,I9,5X,E15.8,5X,''NJSUP('',A4,I4,5X,E15.8)')&
+ JLOOPJ,XZZX(JLOOPJ), &
+ YC42,JLOOPJ,XZZY(JLOOPJ)
+ ELSE IF(JLOOPJ > SIZE(ZDIRV,2))THEN
+ WRITE(INUM,'(5X,I9,5X,E15.8)')JLOOPJ,XZZX(JLOOPJ)
+ ENDIF
+ ELSE IF(SIZE(ZDIRV,2) > SIZE(ZDIRV,1))THEN
+ IF(JLOOPJ < SIZE(ZDIRV,1))THEN
+ WRITE(INUM,'(5X,I9,5X,E15.8,5X,5X,I9,5X,E15.8)')JLOOPJ,XZZX(JLOOPJ), &
+ JLOOPJ,XZZY(JLOOPJ)
+ ELSE IF(JLOOPJ == SIZE(ZDIRV,2))THEN
+ WRITE(INUM,'(29X,5X,5X,''NJSUP('',A4,I4,5X,E15.8)') &
+ YC42,JLOOPJ,XZZY(JLOOPJ)
+ WRITE(INUM,'(1X,73(1H*))')
+ ELSE IF(JLOOPJ > SIZE(ZDIRV,1))THEN
+ WRITE(INUM,'(29X,5X,5X,5X,I9,5X,E15.8)')JLOOPJ,XZZY(JLOOPJ)
+ ELSE
+ WRITE(INUM,'(''NISUP('',A4,I4,5X,E15.8,5X,5X,I9,5X,E15.8)') &
+ YC4,JLOOPJ,XZZX(JLOOPJ), &
+ JLOOPJ,XZZY(JLOOPJ)
+ ENDIF
+ ELSE
+ IF(JLOOPJ == SIZE(ZDIRV,2))THEN
+ WRITE(INUM,'(''NISUP('',A4,I4,5X,E15.8,5X,''NJSUP('',A4,I4,5X,E15.8)') &
+ YC4,JLOOPJ,XZZX(JLOOPJ), &
+ YC42,JLOOPJ,XZZY(JLOOPJ)
+ WRITE(INUM,'(1X,73(1H*))')
+ ELSE
+ WRITE(INUM,'(5X,I9,5X,E15.8,5X,5X,I9,5X,E15.8)')JLOOPJ,XZZX(JLOOPJ), &
+ JLOOPJ,XZZY(JLOOPJ)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+
+ NISKIP=ISKIP
+ NIGRNC=IGRNC
+ DEALLOCATE(ZX,ZZY,ZDIRU,ZDIRV)
+! DEALLOCATE(ZX,ZZY,ZYY,ZLAT,ZLON,ZLA,ZLO,ZDIRU,ZDIRV)
+ IF(ALLOCATED(ZYY))DEALLOCATE(ZYY)
+ IF(ALLOCATED(ZLAT))DEALLOCATE(ZLAT)
+ IF(ALLOCATED(ZLON))DEALLOCATE(ZLON)
+ IF(ALLOCATED(ZLA))DEALLOCATE(ZLA)
+ IF(ALLOCATED(ZLO))DEALLOCATE(ZLO)
+
+!000000000000000000000000000000000000000000000000000000000000000
+ELSE
+!000000000000000000000000000000000000000000000000000000000000000
+!
+!* 1.4 Selects display window as requested by LCARTESIAN
+!* Sets Map projection, overlays coastlines and landmarks
+!* if required
+!
+!
+ CALL GSLN(1)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+
+ IF(LSUPER)THEN
+ NSUPER=NSUPER+1
+! print *,' ** imagev NSUPER ',NSUPER
+
+ IF(NSUPER == 1)THEN
+ NCOLUVG=NCOLUV1
+ ELSEIF(NSUPER == 2)THEN
+ NCOLUVG=NCOLUV2
+ ELSEIF(NSUPER == 3)THEN
+ NCOLUVG=NCOLUV3
+ ELSEIF(NSUPER == 4)THEN
+ NCOLUVG=NCOLUV4
+ ELSEIF(NSUPER == 5)THEN
+ NCOLUVG=NCOLUV5
+ ELSE
+ NCOLUVG=1
+ ENDIF
+ IF(NSUPER == 1)THEN
+ IF(.NOT.LCARTESIAN)CALL BCGRD_FORDIACHRO(2)
+ IF(LCARTESIAN)CALL DEFENETRE
+ if(nverbia > 0)then
+ print *,' **imagev AP CALL BCGRD_FORDIACHRO(2) 2 '
+ endif
+ ENDIF
+ ELSE
+ IF(.NOT.LCARTESIAN)CALL BCGRD_FORDIACHRO(2)
+ IF(LCARTESIAN)CALL DEFENETRE
+ NCOLUVG=NCOLUV1
+ ENDIF
+!
+!* 1.5 Routine VVUMXY of provided by TRACE to locate and scale wind
+!* arrows on the display
+!
+ LHOR=LHORIZ
+ LVERT=LVERTI
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!STREAM
+! GO TO 1000
+IF(.NOT.LSTREAM)THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!STREAM
+ CALL VVSETI('MAP',4)
+ CALL VVSETI('SET',0)
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ if(nverbia > 0)then
+ print *,' **imagev ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT
+ endif
+ CALL VVSETR('VPL',ZVL)
+ CALL VVSETR('VPR',ZVR)
+ CALL VVSETR('VPB',ZVB)
+ CALL VVSETR('VPT',ZVT)
+ !CALL VVSETR('WDL',100000.)
+ CALL VVSETR('WDL',ZWL)
+ !CALL VVSETR('WDR',2500000.)
+ CALL VVSETR('WDR',ZWR)
+ CALL VVSETR('WDB',ZWB)
+ CALL VVSETR('WDT',ZWT)
+
+! CALL SET(ZVL,ZVR,ZVB,ZVT,100000.,2500000.,ZWB,ZWT,ID)
+! Sortie statistiques
+ IF(LVST)THEN
+ CALL VVSETI('VST',1)
+ ELSE
+ CALL VVSETI('VST',0)
+ ENDIF
+ CALL VVSETR('AMX',XAMX)
+ CALL VVSETR('VHC',XVHC)
+ CALL VVSETR('VRL',XVRL)
+ CALL VVSETR('VLC',XVLC)
+ IF(XVHC < 0. )THEN
+ CALL VVSETC('MXT',' ')
+ CALL VVSETC('MXT','Scale')
+ END IF
+!
+!* 1.6 Masks vectors where wind coponents have XSPVAL values
+!
+ CALL VVSETI('SVF',3)
+ CALL VVSETR('USV',XSPVAL)
+ CALL VVSETR('VSV',XSPVAL)
+!
+!* 1.6 Selects look and feel options for the vector display
+! (Text strings, etc..)
+!
+ if(nverbia > 0)then
+ print *,' **imagev AP VVSETR(VSV,XSPVAL)'
+ endif
+ CALL VVSETI('MNP',-4)
+ CALL VVSETR('MNX',(-ZVL+.002)/(ZVR-ZVL))
+!
+! ZY=-1./5.
+! IF(ZVB-(ZVT-ZVB)/5..LT.0.05)ZY=(0.05-ZVB)/(ZVT-ZVB)
+! Oct 2000 Essai de repositionnement des fleches min et max
+ IF(ZVB <= .1)THEN
+ ZY=(-ZVB+0.0395)/(ZVT-ZVB)
+ ELSE
+ ZY=(-ZVB+0.0545)/(ZVT-ZVB)
+ ENDIF
+ CALL VVSETR('MNY',ZY)
+ CALL VVSETI('MXP',-4)
+ CALL VVSETR('MXX',(-ZVL+.14+.002)/(ZVR-ZVL))
+ CALL VVSETR('MXY',ZY)
+ CALL VVSETR('MXS',.008*.9/(ZVR-ZVL))
+! CALL VVSETR('MXS',.008)
+ CALL VVSETR('MNS',.008*.9/(ZVR-ZVL))
+! CALL VVSETR('MNS',.008)
+! Elimination de la legende des fleches si LEGVECT=F
+ IF(.NOT.LEGVECT)THEN
+ CALL VVSETC('MXT',' ')
+ CALL VVSETC('MNT',' ')
+ ENDIF
+ IF(XVHC >= 0.)THEN
+! Janv 2001
+ GVSUPSCA=LVSUPSCA
+ LVSUPSCA=.FALSE.
+ ENDIF
+!
+!* 1.7 Draws the arrows
+!
+ IF(XLWV > 0.)THEN
+ CALL VVSETR('LWD',XLWV)
+ ELSE
+ CALL VVSETR('LWD',XLWVDEF)
+ ENDIF
+ CALL GSCLIP(0) ! Clipping off
+ CALL VVSETI('VPO',1)
+! CALL GSCLIP(1) ! Clipping off
+! if(nverbia > 0)then
+! Oct 2000 La ligne suivante est obligatoire sinon plantage avec visu
+! dans certains cas -> besoin de revenir sur le pb un jour
+ print *,' **imagev AV VVINIT '
+!endif
+ CALL VVINIT(ZZU,IUB1,ZZV,IUB1,0.,0,IUB1,IUB2,0.,0) ! Initializes VVECTR
+ CALL VVECTR(ZZU,ZZV,0.,0,0,0.) ! Draws arrows
+ CALL GSCLIP(1) ! Clipping back on
+ CALL GSLWSC(1.)
+ CALL VVRSET
+ if(nverbia > 0)then
+ print *,' **imagev AP VVRSET '
+ endif
+! Janv 2001
+ IF(XVHC >= 0.)THEN
+ LVSUPSCA=GVSUPSCA
+ ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!STREAM
+!1000 CONTINUE
+ELSE
+NIIMAX=ITER
+!NIIMAX=NIMAXT
+NIJMAX=JTER
+ CALL STSETI('MAP',4)
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ if(nverbia > 0)then
+ print *,' **imagev ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT,NIIMAX,NIJMAX
+ print *,' **imagev ap getset ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT,NIIMAX,NIJMAX
+ endif
+ CALL STSETI('SET',0)
+ CALL STSETR('VPL',ZVL)
+ CALL STSETR('VPR',ZVR)
+ CALL STSETR('VPB',ZVB)
+ CALL STSETR('VPT',ZVT)
+ CALL STSETR('WDL',ZWL)
+ CALL STSETR('WDR',ZWR)
+ CALL STSETR('WDB',ZWB)
+ CALL STSETR('WDT',ZWT)
+ if(nverbia > 0)then
+ print *,' **imagev ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT
+ endif
+
+ CALL STSETI('AGD',NARSTR)
+ CALL STSETI('GBS',0)
+ CALL STSETI('CPM',0)
+! CALL STSETR('ARL',.009)
+ CALL STSETR('ARL',XARLSTR)
+ CALL STSETR('DFM',.02)
+ CALL STSETR('CDS',1.)
+ CALL STSETR('SSP',XSSP)
+! CALL STSETR('SSP',.004)
+ CALL STSETR('LWD',XLWSTR)
+ CALL STSETI('MSK',0)
+ CALL STSETI('SVF',3)
+ CALL STSETR('USV',XSPVAL)
+ CALL STSETR('VSV',XSPVAL)
+ CALL GQPLCI(IER,ICOL1)
+ CALL GSPLCI(NCOLUVG)
+ IZS=4*ITER*JTER
+ CALL STINIT(ZSTRU,ITER,ZSTRV,ITER,0.,0,ITER,JTER,ZSTR1,IZS) ! Initializes VVECTR
+! CALL STINIT(ZSTRU,ITER,ZSTRV,ITER,ZTEM,ITER,ITER,JTER,ZSTR1,IZS) ! Initializes VVECTR
+ CALL STREAM(ZSTRU,ZSTRV,0.,0,STUMXY,ZSTR1) ! Draws arrows
+ CALL STRSET
+ CALL GSPLCI(ICOL1)
+ XZZX(1:IUB1)=ZTEMX(1:IUB1)
+ XZZY(1:IUB2)=ZTEMY(1:IUB2)
+ DEALLOCATE(ZSTR1,ZSTRU,ZSTRV,ZTEMX,ZTEMY)
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!STREAM
+!
+!000000000000000000000000000000000000000000000000000000000000000
+ENDIF
+!000000000000000000000000000000000000000000000000000000000000000
+!------------------------------------------------------------------------------
+!
+!* 2. TOPOGRAPHY MASKING WHEN PLOTTED LEVEL INTERCEPTS TERRAIN
+! --------------------------------------------------------
+!
+!
+!* 2.1 Initialization of a topographic mask using
+!* the NCAR "area" features (see NCAR manual)
+!
+LVERT=LVERTI
+LHOR=LHORIZ
+if(nverbia >0)then
+ print *,' **imagev LVERT, LHOR ',LVERT,LHOR
+endif
+CALL CPSETI('MAP',4)
+CALL CPSETI('SET',0)
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+NIIMAX=IUB1
+!NIIMAX=NIMAXT
+NIJMAX=IUB2
+!NIJMAX=NJMAXT
+!print *,' **NIIMAX,NIJMAX ',NIIMAX,NIJMAX
+!
+IF(CTYPHOR.EQ.'Z' .AND. (.NOT.LSUPER .OR. NSUPER == 1))THEN
+ ZLREF=KLREF
+ !
+ DO JILOOP=NIINF,NISUP
+ DO JJLOOP=NJINF,NJSUP
+ ! If terrain higher than topography
+ ! a 888. mask value is forced
+ !
+ IF(ZLREF.LT.XXZS(JILOOP,JJLOOP,1))PU(JILOOP-NIINF+1,JJLOOP-NJINF+1)=888.
+ ENDDO
+ ENDDO
+ !
+ ICL=1 ! A single contour is drawn
+ CALL CPSETI('CLS',0) ! Contour value forced
+ CALL CPSETI('HCF',1) ! All contoured areas will be hatched
+ CALL CPSETC('CFT',' ') ! No 'CONSTANT FIELD' message
+ CALL CPSETI('NCL',ICL) ! A single contour is drawn
+ CALL CPSETI('PAI',ICL) ! A single contour is drawn
+ CALL CPSETI('AIA',ICL+1) ! Area number where field values are > 888.
+ CALL CPSETI('AIB',ICL) ! Area number where field values are < 888.
+ CALL CPSETI('CLU',1) ! Area without contour, if =1 unlabeled contour
+ CALL CPSETR('SPV',0.) ! Resets SPV, erases the special value setting
+ CALL CPSETR('CLV',888.) ! Value of the single contour drawn
+!
+! As the topography-intercepted area has been set to 888., the rest of the
+! field array is set to ZZSPVAL to hide it in the subsequent processing
+!
+ ZZSPVAL=7777.
+ WHERE(PU(:,:)/=888.)PU(:,:)=ZZSPVAL
+ WHERE(PU(:,::2)==888.)PU(:,::2)=PU(:,::2)+1.E-3
+ CALL CPSETR('SPV',ZZSPVAL) ! Valeur speciale = ZZSPVAL
+!
+!* 2.2 Effective area computation and contour drawing
+!
+ CALL ARINAM(IIMAP,JPMAP) !Initialize areas
+ CALL CPRECT(PU,IUB1,IUB1,IUB2,ZRWRK,JPLRWK,IWRK,JPLIWK)!Initialize conpack
+ CALL CPCLAM(PU,ZRWRK,IWRK,IIMAP) !Contours terrain area
+ CALL CPCLDR(PU,ZRWRK,IWRK) !Contours outside field
+ CALL ARSCAM(IIMAP,ZXWRK,ZYWRK,JPWRK,IAREA,IGRP,JPAREAGRP,SFILL)!Hatches
+ ! !terrain area
+ENDIF
+!
+!-----------------------------------------------------------------------------
+!
+!* 3. COMPLETING THE PLOT
+! -------------------
+!
+!* 3.1 Page information labels
+!
+
+CALL GSCLIP(0)
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+XCURVPTL=ZVL;XCURVPTR=ZVR;XCURVPTB=ZVB;XCURVPTT=ZVT
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZVL,ZVR,ZVB,ZVT,1)
+if(nverbia > 0)then
+ print *,' **imagev 2 ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT
+endif
+
+IF(NLOOPSUPER == 1)THEN
+ CALL RESOLV_TIT('CTITVAR1',HTEXTE)
+ELSE IF(NLOOPSUPER == 2)THEN
+ CALL RESOLV_TIT('CTITVAR2',HTEXTE)
+ELSE IF(NLOOPSUPER == 3)THEN
+ CALL RESOLV_TIT('CTITVAR3',HTEXTE)
+ELSE IF(NLOOPSUPER == 4)THEN
+ CALL RESOLV_TIT('CTITVAR4',HTEXTE)
+ELSE IF(NLOOPSUPER == 5)THEN
+ CALL RESOLV_TIT('CTITVAR5',HTEXTE)
+ELSE IF(NLOOPSUPER == 6)THEN
+ CALL RESOLV_TIT('CTITVAR6',HTEXTE)
+ELSE IF(NLOOPSUPER == 7)THEN
+ CALL RESOLV_TIT('CTITVAR7',HTEXTE)
+ELSE IF(NLOOPSUPER == 8)THEN
+ CALL RESOLV_TIT('CTITVAR8',HTEXTE)
+ENDIF
+
+IF(.NOT.LSUPER)THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ IF(HTEXTE /= ' ')THEN
+ CALL PLCHHQ(MAX(ZVR,.99),0.007,HTEXTE(1:LEN_TRIM(HTEXTE)),.011,0.,+1.)
+ ENDIF
+! CALL PLCHHQ(ZVR-(ZVR-ZVL)/4.,0.007,HTEXTE,.011,0.,-1.)
+ELSE
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ IF(HTEXTE /= ' ')THEN
+ CALL PLCHHQ(MAX(ZVR,.99),0.007+(NSUPER-1)*.017,HTEXTE(1:LEN_TRIM(HTEXTE)),.009,0.,+1.)
+ ENDIF
+! CALL PLCHHQ(ZVR-(ZVR-ZVL)/4.,0.007+(NSUPER-1)*.017,HTEXTE,.009,0.,-1.)
+ENDIF
+
+IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN
+
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+
+! Modifs for diachro
+! Titres en X
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(XSZTITXL /= 0.)THEN
+ CALL PLCHHQ(ZVL,ZVB/2.,YTEM,XSZTITXL,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVL,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(XSZTITXM /= 0.)THEN
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),XSZTITXM,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/2.,ZVB/2.,YTEM,XSZTITXM,0.,-1.)
+ ELSE
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(XSZTITXR /= 0.)THEN
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,XSZTITXR,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+! Titres en Y
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYT',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYM',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYB',ZVL,ZVR,ZVB,ZVT,YTEM)
+
+! Titres TOP
+! Top2
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.95
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+! Top3
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT3',YTEM)
+ ZXPOSTITT3=.002
+ ZXYPOSTITT3=.93
+ IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ ENDIF
+ IF(XYPOSTITT3 /= 0.)THEN
+ ZXYPOSTITT3=XYPOSTITT3
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,XSZTITT3,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+
+! Titre N1 BOTTOM
+ CALL RESOLV_TIT('CTITB1',CLEGEND)
+ ZXPOSTITB1=.002
+ ZXYPOSTITB1=.005
+ IF(XPOSTITB1 /= 0.)THEN
+ ZXPOSTITB1=XPOSTITB1
+ ENDIF
+ IF(XYPOSTITB1 /= 0.)THEN
+ ZXYPOSTITB1=XYPOSTITB1
+ ENDIF
+ IF(CLEGEND /= ' ')THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,CLEGEND,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,CLEGEND,.007,0.,-1.)
+ ENDIF
+! Titre N2 BOTTOM
+ CALL RESOLV_TIT('CTITB2',CLEGEND2)
+ ZXPOSTITB2=.002
+ ZXYPOSTITB2=.025
+ IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ ENDIF
+ IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ ENDIF
+ IF(CLEGEND2 /= ' ')THEN
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
+ ENDIF
+! Titre N3 BOTTOM
+ YTEM(1:LEN(YTEM))=' '
+ ZXPOSTITB3=.002
+ ZXYPOSTITB3=.045
+ IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ ENDIF
+ IF(XYPOSTITB3 /= 0.)THEN
+ ZXYPOSTITB3=XYPOSTITB3
+ ENDIF
+ IF(LMINUS .OR. LPLUS)THEN
+ IF(.NOT.LTITDEFM .AND. CTITB3MEM /= 'DEFAULT' .AND. &
+ CTITB3MEM /= 'default' .AND. CTITB3MEM /= 'DEFAUT' .AND. &
+ CTITB3MEM /= 'defaut')THEN
+ if(nverbia > 0)then
+ print *,' imagev CTITB3MEM ',CTITB3MEM(1:LEN_TRIM(CTITB3MEM))
+ endif
+ IF(CTITB3MEM /= ' ' .AND. CTITB3MEM /= 'WHITE' .AND. &
+ CTITB3MEM /= 'white' .AND. CTITB3MEM /= 'BLANC' .AND. &
+ CTITB3MEM /= 'blanc')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),.009,0.,-1.)
+ ENDIF
+ ENDIF
+
+ ELSE
+! print *,' **imagev CTITB3 AV RESOLV_TIT ',CTITB3
+ CALL RESOLV_TIT('CTITB3',CTITB3)
+! print *,' **imagev CTITB3 AP RESOLV_TIT ',CTITB3
+ IF(CTITB3 /= ' ')THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3,.009,0.,-1.)
+ ENDIF
+ ENDIF
+ ELSE
+ CALL RESOLV_TIT('CTITB3',YTEM)
+ IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,.009,0.,-1.)
+! CALL PLCHHQ(0.002,0.050,YTEM,.009,0.,-1.)
+ ENDIF
+ ENDIF
+
+! Titre N1 TOP
+! Top1
+ WRITE(YPLANH,1001)NIINF,NISUP,NJINF,NJSUP
+ ZXPOSTITT1=.002
+ ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+ CALL RESOLV_TIT('CTITT1',YPLANH)
+ IF(YPLANH /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YPLANH,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YPLANH,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YPLANH,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YPLANH,.012,0.,-1.)
+ ENDIF
+ ENDIF
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+ENDIF
+
+IF(LMINUS .OR. LPLUS)THEN
+
+ ZXPOSTITB3=.002
+ ZXYPOSTITB3=.045
+ IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ ENDIF
+ IF(XYPOSTITB3 /= 0.)THEN
+ ZXYPOSTITB3=XYPOSTITB3
+ ENDIF
+
+ IF(.NOT.LTITDEFM .AND. CTITB3MEM /= 'DEFAULT' .AND. &
+ CTITB3MEM /= 'default' .AND. CTITB3MEM /= 'DEFAUT' .AND. &
+ CTITB3MEM /= 'defaut')THEN
+ if(nverbia > 0)then
+ print *,' imagev CTITB3MEM ',CTITB3MEM(1:LEN_TRIM(CTITB3MEM))
+ endif
+ IF(CTITB3MEM /= ' ' .AND. CTITB3MEM /= 'WHITE' .AND. &
+ CTITB3MEM /= 'white' .AND. CTITB3MEM /= 'BLANC' .AND. &
+ CTITB3MEM /= 'blanc')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),.009,0.,-1.)
+ ENDIF
+ ENDIF
+
+ ELSE
+
+! print *,' **imagev CTITB3 AV RESOLV_TIT ',CTITB3
+ CALL RESOLV_TIT('CTITB3',CTITB3)
+! print *,' **imagev CTITB3 AP RESOLV_TIT ',CTITB3
+ IF(CTITB3 /= ' ')THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3,.009,0.,-1.)
+ ENDIF
+ ENDIF
+
+ENDIF
+
+1001 FORMAT('HORIZONTAL SECTION NIINF=',I4,' NISUP=',I4, &
+ ' NJINF=',I4,' NJSUP=',I4)
+CALL GSCLIP(1)
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+!IF(.NOT.LDIRWIND)THEN
+! Conservation de la valeur du logique suivant pour la direction du vent
+! pour beneficier des traits pleins en cas de superposition (Mai 99)
+IF(LSUPER)THEN
+ LARROVL=.TRUE.
+ELSE
+ LARROVL=.FALSE.
+ENDIF
+!
+IF(LDIRWIND)THEN
+! LDIRWIND=.FALSE.
+ENDIF
+!
+!* 3.2 NCAR parameter reset
+!
+CALL CPSETI('CLS',16)
+CALL CPRSET
+!
+!-------------------------------------------------------------------------
+!
+!* 4. EXIT
+! ----
+!
+if(nverbia > 0)then
+print *,' **imagev Sortie'
+endif
+RETURN
+END SUBROUTINE IMAGEV_FORDIACHRO
+
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/imcou_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/imcou_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8f6cbc4711ef52257cc36f0c762cf2ec60719fa7
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/imcou_fordiachro.f90
@@ -0,0 +1,4147 @@
+! ######spl
+ SUBROUTINE IMCOU_FORDIACHRO(PTABV,PINT,HLEGEND,HTEXT)
+! #####################################################
+!
+!!**** *IMCOU_FORDIACHRO* - Contour plot manager for vertical cross-sections
+!!
+!! PURPOSE
+!! -------
+! Draws contour plots in the vertical cross-section case
+!
+!!** METHOD
+!! ------
+!! Calls the NCAR contour routines and defines the display environment
+!! for the vertical cross-sections
+!!
+!! EXTERNAL
+!! --------
+!! GMNMX computes min, max and contour increment for current field
+!! TRACEXZ draws a model-level stencil background if i) the current
+!! plot is a East-West cross-section, ii) the section origin
+!! is directly defined by grid indexes, and iii) if LXZ = .TRUE.
+!!
+!! CURVE draws a curve made by a series of data points !
+!! SFSETR sets parameters for NCAR softfill environment !
+!! SFWRLD fills the inside of a closed curve as requested by !
+!! the previous SFSETR calls !
+!! !
+!! CPSETI ! INTEGER !
+!! CPSETR ! gives a value to a NCAR variabe, type: REEL !
+!! CPSETC ! CHARACTER !
+!! CPGETI ! INTEGER !Routines
+!! CPGETI ! INTEGER !
+!! CPGETR ! retrieves a NCAR parmeter value, type REEL !
+!! CPGETC ! CHARACTER !
+!! CPRECT initialize contour drawing !
+!! CPPKCL selects the contour values !
+!! CPCLDR draws the contours !
+!! CPLBDR activates High and Low option !
+!! CPRSET restores NCAR default values !
+!! !
+!! GSLWSC sets line widths !
+!! SET defines the display window limits in both !
+!! normalised and user coordinates !
+!! GETSET retrieves the user and normalized coordinate ranges!
+!! for current window for the current display window.!
+!! PLCHHQ prints high qualty text !
+!! GSCLIP CLIPS the display window !
+!!
+!! CPMPXY TRACE provided FORTRAN-77 routine directly called
+!! within CONPACK to map the array space onto the
+!! Gal-Chen stretched space
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist
+!! (former PARA common)
+!! XIDEBCOU, XJDEBCOU : Origin of a vertical cross-section
+!! in cartesian (or conformal) real values
+!! XHMIN : Altitude of the vert. cross-section
+!! bottom (in meters above sea-level)
+!! XHMAX : Altitude of the vert. cross-section
+!! top (in meters above sea-level)
+!! LHORIZ : Horizontal mode selector
+!! =.TRUE. to perform horizontal cross-sections
+!! (LVERTI must be = to .FALSE.)
+!! LVERTI : Vertical mode selector
+!! =.TRUE. to perform vertical cross-sections,
+!! including vert. 1D profiles.
+!! (LHORIZ must be = to .FALSE.)
+!! NIDEBCOU, : Origin of a vertical cross-section
+!! NJDEBCOU in grid index integer values
+!! (XIDEBCOU and XJDEBCOU must be = to -999.)
+!! NLANGLE : Angle between X Meso-NH axis and
+!! cross-section direction in degrees
+!! (Integer value anticlockwise)
+!! NLMAX : Number of points horizontally along
+!! the vertical section
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NKMAX : z array dimension
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!! Module MODD_NMGRID : declares global variable NMGRID
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!! Module MODD_CVERT: Declares work arrays for vertical cross-sections
+!! XWORKZ : working array for true altitude storage (all grids)
+!! XWZ : working array for topography (all grids)
+!!
+!! Module MODD_COORD : declares gridpoint coordinates
+!! (TRACE use only)
+!! XDS : Abscissa array along the horizontal axis of an oblique
+!! vertical cross-section (meters), for all grid locations
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!! NIOFFD : Label normalisation (=0 none, =/=0 active)
+!! NULBLL : Nb of contours between 2 labelled contours
+!! NIOFFM : =0 --> message at picture bottom
+!! =/= 0 --> no message
+!! NDOT : Line style
+!! (=0|1|1023|65535 --> solid lines;
+!! <0 --> solid lines for positive values and
+!! dotted lines(ABS(NDOT))for negative values;
+!! >0 --> dotted lines(ABS(NDOT)) )
+!! NHI : Extrema detection
+!! (=0 --> H+L, <0 nothing)
+!! NIMNMX : Contour selection option
+!! (=-1 Min, max and inc. automatically set;
+!! =0 Min, max automatically set; inc. given;
+!! >0 Min, max, inc. given by user)
+!! XSPVAL : Special value
+!! XSIZEL : Label size
+!!
+!! Module MODD_SUPER : defines plot overlay control variables
+!! LSUPER : =.TRUE. --> plot overlay is active
+!! =.FALSE. --> plot overlay is not active
+!! NSUPER : Rank of the current plot in the overlay
+!! sequence. The initial plot is rank 1.
+!!
+!! Module MODD_ALLVAR
+!! >>>>>>>>>>DRAGOON QUERY: Is this one really necessary????
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 19/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+#ifdef NAGf95
+USE F90_UNIX ! for FLUSH and GETENV
+#endif
+
+USE MODN_PARA
+USE MODD_PARAMETERS
+USE MODD_NMGRID
+USE MODD_CVERT
+USE MODD_COORD
+USE MODD_CONF
+USE MODD_GRID
+USE MODD_GRID1
+USE MODD_DIM1
+USE MODD_TYPE_AND_LH
+USE MODN_NCAR
+USE MODD_SUPER
+USE MODD_ALLVAR
+USE MODD_TITLE
+USE MODD_LUNIT1
+USE MODD_OUT
+USE MODD_PVT
+USE MODD_RSISOCOL
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+USE MODI_RESOLV_TIT
+USE MODI_RESOLV_TITY
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODI_READMNMXINT_ISO
+USE MODI_READREFINT_ISO
+USE MODI_READXISOLEVP
+USE MODD_TIT
+USE MODD_HACH
+USE MODD_DEFCV
+USE MODE_GRIDPROJ
+USE MODD_CTL_AXES_AND_STYL
+USE MODD_MASK3D
+!
+USE MODI_CREATLINK
+USE MODI_WRITEDIR
+!
+IMPLICIT NONE
+INTERFACE
+SUBROUTINE AXELOGPRES(PHMIN,PHMAX)
+REAL :: PHMIN,PHMAX
+END SUBROUTINE AXELOGPRES
+END INTERFACE
+!
+!* 0.0 TRACE interface with the "CPMPXY" routine of the NCAR package
+!
+! NOTICE: The CPMPXY and the NCAR graphical utilities are NOT written
+! ------ in Fortran 90, but in Fortran 77.. This sub-section of TRACE
+! does not follow the Meso-NH usual rules: it has to be made using
+! a COMMON stack with static memory allocation of XZZXX and
+! XZZXY arrays.
+!
+COMMON/TEMV/XZWORKZ,XZZDS,NINX,NINY
+COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+COMMON/COLAREA/ICOL(300)
+COMMON/HACHAREA/IHACH(300)
+#include "big.h"
+REAL,DIMENSION(N2DVERTX,2500) :: XZWORKZ
+!REAL,DIMENSION(1000,400) :: XZWORKZ
+!REAL,DIMENSION(200,200) :: XZWORKZ
+REAL,DIMENSION(N2DVERTX) :: XZZDS
+!REAL,DIMENSION(1000) :: XZZDS
+!REAL,DIMENSION(200) :: XZZDS
+INTEGER :: NINX, NINY
+LOGICAL :: LVERT, LHOR, LPT, LXABS
+INTEGER :: ICOL
+!
+!* 0.1 Work arrays for NCAR
+!
+INTEGER,PARAMETER :: JPLRWK=50000, JPLIWK=50000
+INTEGER,PARAMETER :: JPRSCR=20000, JPISCR=20000
+INTEGER,PARAMETER :: JPMAP=NPMAP, JPAREAGRP=300, JPWRK=50000
+!INTEGER,PARAMETER :: JPMAP=800000, JPAREAGRP=300, JPWRK=50000
+!
+REAL,DIMENSION(JPLRWK) :: ZRWRK
+INTEGER,DIMENSION(JPLIWK) :: IWRK
+REAL,DIMENSION(JPRSCR) :: ZRSCR
+INTEGER,DIMENSION(JPISCR) :: ISCR
+INTEGER,DIMENSION(JPMAP) :: IIMAP
+INTEGER,DIMENSION(JPAREAGRP):: IAREA, IGRP
+REAL,DIMENSION(JPWRK) :: ZXWRK, ZYWRK
+INTEGER :: IHACH
+!
+!* 0.2 Dummy arguments and results
+!
+REAL,DIMENSION(:,:) :: PTABV ! Vertical section data array
+ ! to be plotted
+REAL :: PINT ! Contour increment fo the
+ ! current plot
+CHARACTER(LEN=*) :: HTEXT ! PLot heading with section location
+CHARACTER(LEN=*) :: HLEGEND ! PLot heading with variable name
+!CHARACTER(LEN=8) :: YDAT8, YTIM8, YTEM8
+CHARACTER(LEN=32):: YLBL
+CHARACTER(LEN=80) :: YCAR80
+CHARACTER(LEN=160) :: YCAR160,YCAR161
+!
+!* 0.3 Local variables
+!
+INTEGER :: IA, IB
+INTEGER :: IKU, IKB, IKE, JILOOP, JKLOOP, J, JU
+INTEGER :: ICL, INCL2, ILMAX
+INTEGER :: INCL, I, ICLD, III, IO
+INTEGER :: INBC, IDX, INBCT
+INTEGER :: JJD, JJF, JI, JJ
+INTEGER :: JB, ISTOK
+INTEGER,SAVE :: ILUCOL, IRESP, ID, IDD
+INTEGER,SAVE :: ISUIT, ISUI, INDISTM
+INTEGER :: ILENT, IND, II2,IJ2
+INTEGER :: JLBL, JL
+INTEGER :: ISTA, IER, IWK, INB, INBB
+INTEGER,SAVE :: IH, IHT, IMI, ILE
+INTEGER,DIMENSION(32):: INDHACHREF=(/0,54,52,60,14,59,58,1,57,56,55,54,53,52,51,50, &
+ 1,49,48,47,46,45,44,43,42,41,40,39,38,37,36,35/)
+INTEGER :: INUM, ILOOP, JLOOPI, IDEB,IFIN, II, JLOOPJ
+INTEGER,DIMENSION(:),ALLOCATABLE :: ICOL2
+INTEGER,DIMENSION(:),ALLOCATABLE :: IE
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: ISTM
+#ifdef RHODES
+INTEGER :: ISTAF
+#endif
+
+REAL :: ZWLC, ZWRC, ZWBC, ZWTC
+REAL :: ZTA, ZTB, ZTD, ZTF, ZTINT,ZINTV
+REAL :: ZINT, ZMIN, ZMAX
+REAL :: ZINTT, ZH, ZJ, ZJJ, ZWBBB
+REAL :: ZISO
+REAL :: ZTEMP
+REAL,SAVE :: ZWL, ZWR, ZWB, ZWT
+REAL,SAVE :: ZWLL, ZWRR, ZWBB, ZWTT
+REAL,SAVE :: ZVL, ZVR, ZVB, ZVT
+REAL :: ZCLV, ZINTERV, ZCLV2
+REAL :: ZCLVD, ZCLVF
+REAL :: RED, GREEN, BLUE
+REAL :: ZMN, ZMX
+REAL :: ZDIXEPS
+REAL :: ZX, ZY, ZXE, ZYE
+REAL :: ZLAT, ZLON
+REAL :: ZMI, ZMA, ZMIG, ZMAG
+REAL :: ZVLDEF, ZWIDTH
+REAL :: ZSC
+REAL :: ZXPOSTITT1, ZXYPOSTITT1
+REAL :: ZXPOSTITT2, ZXYPOSTITT2
+REAL :: ZXPOSTITT3, ZXYPOSTITT3
+REAL :: ZXPOSTITB1, ZXYPOSTITB1
+REAL :: ZXPOSTITB2, ZXYPOSTITB2
+REAL :: ZXPOSTITB3, ZXYPOSTITB3
+REAL,DIMENSION(5) :: ZX5, ZY5
+REAL :: ZEPX, ZEPYD, ZEPYU
+!
+REAL,SAVE :: ZD, ZF, ZVERA, ZINTE
+REAL,DIMENSION(SIZE(PTABV,1),SIZE(PTABV,2)):: ZTEMV, ZTEMV2
+REAL,DIMENSION(N2DVERTX+20) :: ZDS, ZWZ
+!REAL,DIMENSION(1020) :: ZDS, ZWZ
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZDS2, ZWZ2
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZLA, ZLO
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZZCLV2, ZTDX
+
+!REAL,DIMENSION(300) :: ZDS, ZWZ
+REAL,DIMENSION(300) :: ZLEV, ZISOLEVP
+!
+CHARACTER(LEN=5) :: YFORMAT
+CHARACTER(LEN=82),SAVE :: YCARCOU, YCAR
+CHARACTER(LEN=100) :: YTEM
+CHARACTER(LEN=1) :: YREP
+CHARACTER(LEN=2) :: YC2
+CHARACTER(LEN=3) :: YC3
+CHARACTER(LEN=4) :: YC4
+CHARACTER(LEN=8),DIMENSION(300) :: YLLBS
+CHARACTER(LEN=32),SAVE :: YNAMTABCOL
+CHARACTER(LEN=40) :: YTEXT
+CHARACTER(LEN=45) :: YTEX ! 45=40+5
+CHARACTER(LEN=8) :: YC8
+CHARACTER(LEN=20) :: YXYO
+CHARACTER(LEN=20) :: YCAR20
+CHARACTER(LEN=10) :: FORMAX, FORMAY,FORMA160
+!
+EXTERNAL SFILL
+EXTERNAL SFILLH
+EXTERNAL CCOLR
+!
+!-----------------------------------------------------------------------------
+!
+!* 1. DISPLAY ENVIRONMENT SETUP
+! -------------------------
+!
+!-----------------------------------------------------------------------------
+if(nverbia > 0)then
+ print *,' ENTREE IMCOU'
+ print *,' LEN_TRIM(HTEXT) ',LEN_TRIM(HTEXT),HTEXT(1:LEN_TRIM(HTEXT))
+ print *,' LPRESY,XHMIN,XHMAX CTIMEC ',LPRESY,XHMIN,XHMAX,CTIMEC
+ print *,' CLEGEND2 ',CLEGEND2
+endif
+ZVLDEF=.1
+YTEXT(1:LEN(YTEXT))=' '
+YTEX(1:LEN(YTEX))=' '
+!HTEXT=ADJUSTL(HTEXT)
+JU=0
+DO J=1,LEN_TRIM(HTEXT)
+ IF(HTEXT(J:J) == ' ')THEN
+ JU=JU+1
+ YTEXT(1:J-1)=HTEXT(1:J-1)
+ IF(YTEXT(1:4) == 'MASK')THEN
+ IF(JU == 2)THEN
+ IF(YTEXT(1:4) == 'MASK')THEN
+ IF(YTEXT(6:6) /= ' ')THEN
+ YTEXT(1:6)=' '
+ ELSE
+ YTEXT(1:5)=' '
+ ENDIF
+ YTEXT=ADJUSTL(YTEXT)
+ EXIT
+ ENDIF
+ ENDIF
+ ELSE
+ EXIT
+ ENDIF
+ ENDIF
+ IF(J == LEN_TRIM(HTEXT))THEN
+ YTEXT=HTEXT
+ YTEXT=ADJUSTL(YTEXT)
+ IF(YTEXT(1:4) == 'MASK')THEN
+ IF(YTEXT(6:6) /= ' ')THEN
+ YTEXT(1:6)=' '
+ ELSE
+ YTEXT(1:5)=' '
+ ENDIF
+ YTEXT=ADJUSTL(YTEXT)
+ ENDIF
+ ENDIF
+ENDDO
+
+IF(nverbia > 0)then
+ print *,' IMCOU NMGRID YTEXT ',NMGRID,YTEXT
+ print *,' PTABV',size(PTABV,1),size(PTABV,2),PTABV(1,1),PTABV(size(PTABV,1),6)
+endif
+NLUOUT=6
+
+IF(LPRINT)THEN
+
+! IF(LDEFCV2CC)THEN !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! print *,' Pour l''instant, cette operation n''est prevue que pour une coupe definie avec :'
+! print *,' NIDEBCOU= NJDEBCOU= NLANGLE= NLMAX= '
+! print *,' A suivre ........ '
+! ELSE !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ ILOOP=SIZE(PTABV,1)/5
+ IF(ILOOP * 5 < SIZE(PTABV,1))ILOOP=ILOOP+1
+ IF(.NOT.LPVT)THEN
+ WRITE(INUM,'(''CV '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'','' (1-NLMAX,1-IKU)'')')CGROUP,&
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ ELSE
+ WRITE(INUM,'(''CV '',''G:'',A16,'' P:'',A25)')CGROUP,&
+& CTITRE(NLOOPP)(1:25)
+ ENDIF
+ IF(LMINUS .OR. LPLUS)THEN
+ WRITE(INUM,'(A70)')CTITB3
+ ELSE
+ WRITE(INUM,'(A40)')CTITGAL
+ ENDIF
+ IF(.NOT.LPVT)THEN
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2)THEN
+ WRITE(INUM,'(''cc(deb)-(fin)=('',F8.0,'','',F8.0,'')-('',F8.0,'','',F8.0,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCV,XJDEBCV,XIFINCV,XJFINCV,NLMAX,SIZE(PTABV,2),ILOOP
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(INUM,'(''ll(deb)-(fin)=('',F8.3,'','',F8.3,'')-('',F8.3,'','',F8.3,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL,NLMAX,SIZE(PTABV,2),ILOOP
+ ELSE IF(LDEFCV2IND)THEN
+ WRITE(INUM,'(''ij(deb)-(fin)=('',I4,'','',I4,'')-('',I4,'','',I4,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &NIDEBCV,NJDEBCV,NIFINCV,NJFINCV,NLMAX,SIZE(PTABV,2),ILOOP
+ ENDIF
+ ELSE
+ IF(XIDEBCOU /= -999.)THEN
+ WRITE(INUM,'(''xidebcou'',F8.0,'' xjdebcou'',F8.0,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCOU,XJDEBCOU,NLMAX,NLANGLE,SIZE(PTABV,2),ILOOP
+ ELSE
+ WRITE(INUM,'(''nidebcou'',i4,'' njdebcou'',i4,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,SIZE(PTABV,2),ILOOP
+ ENDIF
+ ENDIF
+ ELSE
+ WRITE(INUM,'(''NBVAL en I (TIME): '',i4, &
+& '' NBVAL en K (Z)'',i4,'' iter'',i3)') &
+ & SIZE(PTABV,1),SIZE(PTABV,2),ILOOP
+ ENDIF
+ DO JLOOPI=1,ILOOP
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=5
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+5
+ ENDIF
+ IF(JLOOPI == ILOOP)THEN
+ IFIN=SIZE(PTABV,1)
+ ENDIF
+
+! JUin 2001 Ecriture des dates (Demande G.Jaubert ) si LPRDAT=T
+ IF(LPRDAT)THEN
+ IF(.NOT.ALLOCATED(XPRDAT))THEN
+ print *,'** IMCOU XPRDAT NON ALLOUE.Dates non ecrites ds FICVAL .Prevenir J.Duron'
+ ELSE
+ WRITE(INUM,'(1X,75(1H*))')
+ WRITE(INUM,'(1X,'' Dates courante * modele * experience * segment'')')
+ WRITE(INUM,'(1X,'' J An M J Sec. * An M J Sec. * An M J Sec. * An M J Sec.'')')
+ WRITE(INUM,'(1X,75(1H*))')
+ DO J=1,SIZE(XPRDAT,2)
+ WRITE(INUM,'(1X,I3,1X,3(I4,I3,I3,I6,'' *''),I4,I3,I3,I6)')J,INT(XPRDAT(:,J))
+ ENDDO
+ ENDIF
+ ENDIF
+ WRITE(INUM,'(1X,79(1H*))')
+ WRITE(INUM,'('' K I-> '',I4,6X,4(6X,I4,6X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'(''.'',79(1H*))')
+ DO JLOOPJ=SIZE(PTABV,2),1,-1
+ WRITE(INUM,'(I4,1X,5(1X,E14.7))')JLOOPJ,(PTABV(II,JLOOPJ),II=IDEB,IFIN)
+! WRITE(INUM,'(I4,1X,5E15.8)')JLOOPJ,(PTABV(II,JLOOPJ),II=IDEB,IFIN)
+ ENDDO
+ WRITE(INUM,'(1X,79(1H*))')
+ ENDDO
+! ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ENDIF
+
+
+ZDIXEPS=1.E-11
+!print *,' ZDIXEPS ',ZDIXEPS
+IKU=NKMAX+2*JPVEXT
+IKB=1+JPVEXT
+IKE=IKU-JPVEXT
+LVERTI=.TRUE.; LHORIZ=.FALSE.
+!IF(.NOT.LCVXZ .AND. .NOT.LCVYZ)THEN
+!
+!* 1.1 Window definition, NDC and user coordinate setting
+!
+XLWIDTH=XLWDEF
+IF(LSUPER)THEN
+ NSUPER=NSUPER+1
+ SELECT CASE(NSUPER)
+ CASE(1)
+ IF(XLW >= 0)THEN
+ XLWIDTH=XLW
+ ENDIF
+ IF(XLW1 >= 0)THEN
+ XLWIDTH=XLW1
+ ENDIF
+
+ IH=0; IHT=0
+
+ IF(LHACH2 .AND. LHACH3 .AND. LHACH4)THEN
+
+ IHT=3
+ ELSE IF((LHACH2 .AND. LHACH3 .AND. .NOT.LHACH4) .OR. &
+ (LHACH2 .AND. LHACH4 .AND. .NOT.LHACH3) .OR. &
+ (LHACH3 .AND. LHACH4 .AND. .NOT.LHACH2))THEN
+ IHT=2
+ ELSE IF((LHACH2 .AND. .NOT.LHACH3 .AND. .NOT.LHACH4) .OR. &
+ (LHACH3 .AND. .NOT.LHACH2 .AND. .NOT.LHACH4) .OR. &
+ (LHACH4 .AND. .NOT.LHACH2 .AND. .NOT.LHACH3))THEN
+ IHT=1
+ ENDIF
+
+ CASE(2)
+ IF(XLW2 >= 0)THEN
+ XLWIDTH=XLW2
+ ENDIF
+ CASE(3)
+ IF(XLW3 >= 0)THEN
+ XLWIDTH=XLW3
+ ENDIF
+ CASE(4)
+ IF(XLW4 >= 0)THEN
+ XLWIDTH=XLW4
+ ENDIF
+ END SELECT
+ELSE
+ IF(XLW >= 0)THEN
+ XLWIDTH=XLW
+ ENDIF
+ IF(XLW1 >= 0)THEN
+ XLWIDTH=XLW1
+ ENDIF
+ IH=0; IHT=0
+END IF
+
+LPT=LPXT
+IF(.NOT.LPVT .AND. .NOT.LPXT .AND. .NOT.LPYT .AND. .NOT.LCVXZ .AND. .NOT.LCVYZ)THEN
+
+ IF((.NOT.LSUPER) .OR. (LSUPER .AND. NSUPER == 1))THEN
+ ZWL=XDS(1,NMGRID)
+ ZWR=XDS(NLMAX,NMGRID)
+! Nov 2000
+ IF(LPRESY)THEN
+ IF(XHMIN<=XHMAX)THEN
+! Bornes en altitude -> besoin de calculer bornes en pression +loin
+ !XHMIN=0.
+ !XHMAX=XWORKZ(1,IKE,NMGRID)
+ IF(XPMIN==XPMAX)THEN
+ print*,' ordonnee en Log(P): indiquez XPMIN et XPMAX'
+ read(5,*) XPMIN,XPMAX
+ CALL WRITEDIR(NDIR,XPMIN)
+ CALL WRITEDIR(NDIR,XPMAX)
+ ENDIF
+ IF(XPMIN<XPMAX) THEN
+ ZTEMP=XPMIN
+ XPMIN=XPMAX
+ XPMAX=ZTEMP
+ ENDIF
+ XHMIN=XPMIN
+ XHMAX=XPMAX
+ ENDIF
+! Bornes fournies en pression . Verifier qu'elles sont en pascals
+! Besoin de calculer les bornes en altitudes +loin
+ IF (XHMIN < 1500)THEN
+ XHMIN=XHMIN*100
+ ENDIF
+ IF (XHMAX < 1500)THEN
+ XHMAX=XHMAX*100
+ ENDIF
+ ELSE
+ IF((XHMIN==0..AND.XHMAX==0.).OR.(XHMAX<=XHMIN))THEN
+! Nov 2000 -> Petite modif a signaler aux utilisateurs
+ XHMIN=0.
+! XHMIN=XWORKZ(1,IKB,NMGRID)
+ XHMAX=XWORKZ(1,IKE,NMGRID)
+ ENDIF
+ ENDIF
+ ZWB=XHMIN
+ ZWT=XHMAX
+ IF (.NOT. LPRESY .AND. ZWB==ZWT) THEN
+ print *,' min, max identiques pour la 2e direction: ',XHMIN,XHMAX
+ print *,'entrez 2 valeurs telles que XHMIN < XHMAX '
+ read(5,*) ZWB,ZWT
+ CALL WRITEDIR(NDIR,ZWB)
+ CALL WRITEDIR(NDIR,ZWT)
+ END IF
+!
+ if(nverbia > 0)then
+ print *,' ****** IMCOU_FORDIACHRO ZWL R B T',ZWL,ZWR,ZWB,ZWT
+ endif
+ LVERT=LVERTI
+ LHOR=LHORIZ
+!
+! Nov 2000
+ IF(LPRESY)THEN
+ CALL SETUSV('MI',1)
+ CALL SETUSV('LS',2)
+ IF(LVPTVUSER)THEN
+ CALL SET(XVPTVL,XVPTVR,XVPTVB,XVPTVT,ZWL,ZWR,ZWB,ZWT,2)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZWL,ZWR,ZWB,ZWT,2)
+ ENDIF
+ ELSE
+! Nov 2000
+ CALL SETUSV('MI',1)
+ IF(LVPTVUSER)THEN
+ CALL SET(XVPTVL,XVPTVR,XVPTVB,XVPTVT,ZWL,ZWR,ZWB,ZWT,1)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZWL,ZWR,ZWB,ZWT,1)
+ ENDIF
+! Nov 2000
+ ENDIF
+! Nov 2000
+ END IF
+
+ELSE
+
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+
+ IF(LCVXZ .OR. LCVYZ)THEN
+ IF(LVPTVUSER)THEN
+ CALL SET(XVPTVL,XVPTVR,XVPTVB,XVPTVT,ZWL,ZWR,ZWB,ZWT,1)
+ ELSE
+! Dans ce cas definition de la fenetre ds OPER avec .1,.9,.1,.9
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+ ENDIF
+ ELSE
+!!!!!PROVI
+ IF(LPXT .AND. .NOT.LXABSC .AND. LXMINTOP)THEN
+ CALL SETUSV('MI',2)
+! Attention ici inversion de ZWB et ZWT
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWT,ZWB,ID)
+ ELSEIF(LPVT .AND. LPRESY)THEN
+ CALL SETUSV('MI',1)
+ CALL SETUSV('LS',2)
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,2)
+! CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ ELSE
+ CALL SETUSV('MI',1)
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ ENDIF
+ ENDIF
+
+ENDIF
+CALL GETUSV('MI',IMI)
+!
+IF(.NOT.LPVT .AND. .NOT.LPXT .AND. .NOT.LPYT .AND. .NOT.(LCVXZ.AND.LJCP) .AND. .NOT.(LCVYZ.AND.LICP))THEN
+ CALL GSCLIP(1) ! Display clipping activated
+!
+ CALL CPSETI('SET',0) ! Compack keeps user's call to set
+ CALL CPSETI('MAP',4) ! Customized vertical z-stretching used in CPMPXY
+!
+!* 1.2 Topography outline drawing
+!
+
+ ZDS(1)=XDS(1,NMGRID)
+ ZWZ(1)=XHMIN
+ IF(LCVYZ .AND.LICP)THEN
+ ZWZ(1)=0.
+ ENDIF
+ IF(LCVYZ .AND. .NOT.LICP)THEN
+ ZWZ(2:NLMAX+1)=XXZS(NIDEBCOU,NJDEBCOU:NJDEBCOU+NLMAX-1,NMGRID)
+ ENDIF
+ DO JILOOP=2,NLMAX+1
+ ZDS(JILOOP)=XDS(JILOOP-1,NMGRID)
+ IF(LCVYZ .AND. .NOT.LICP)THEN
+ ELSEIF(LCVYZ .AND.LICP)THEN
+ ZWZ(JILOOP)=0.
+ ELSE
+ ZWZ(JILOOP)=XWZ(JILOOP-1,NMGRID)
+ ENDIF
+ ENDDO
+ ZDS(NLMAX+2)=ZDS(NLMAX+1)
+ ZWZ(NLMAX+2)=XHMIN
+ IF(LCVYZ .AND.LICP)THEN
+ ZWZ(NLMAX+2)=0.
+ ENDIF
+!
+ IF(ALLOCATED(ZDS2))THEN
+ DEALLOCATE(ZDS2)
+ ENDIF
+ IF(ALLOCATED(ZWZ2))THEN
+ DEALLOCATE(ZWZ2)
+ ENDIF
+ ALLOCATE(ZDS2(NLMAX+2))
+ ALLOCATE(ZWZ2(NLMAX+2))
+ ZDS2=ZDS(1:NLMAX+2)
+ ZWZ2=ZWZ(1:NLMAX+2)
+ if(nverbia > 4)then
+print *,' ********IMCOU_FORDIACHRO NLMAX ZDS',NLMAX
+print *,(ZDS(JILOOP),JILOOP=1,NLMAX)
+print *,' ********IMCOU_FORDIACHRO ZWZ'
+print *,(ZWZ(JILOOP),JILOOP=1,NLMAX)
+ endif
+!
+ IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN
+ IF(.NOT. LPRESY) THEN
+ CALL CURVE(ZDS2,ZWZ2,NLMAX+2) ! draws Topo outline
+! CALL CURVE(ZDS,ZWZ,NLMAX+2) ! draws Topo outline
+ CALL SFSETR('SP',.008) ! Softfill setting
+ CALL SFSETR('AN',45.) ! Softfill setting
+ CALL SFSETI('DO',0) ! Softfill setting
+ CALL SFWRLD(ZDS2,ZWZ2,NLMAX+2,ZRSCR,JPRSCR,ISCR,JPISCR) ! Hatched under
+! CALL SFWRLD(ZDS,ZWZ,NLMAX+2,ZRSCR,JPRSCR,ISCR,JPISCR) ! Hatched under
+! ! topography
+ ENDIF
+!
+!* 1.3 If required, draws a model-level background
+!
+ IF(.NOT.LDEFCV2CC)THEN !%%%%%%%%%%%%%%%%%%%%%%
+
+ IF(NLANGLE.EQ.0.AND.XIDEBCOU.EQ.-999..AND.LXZ)THEN
+ CALL GSCLIP(0)
+ CALL TRACEXZ
+ CALL GSCLIP(1)
+ END IF
+
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%
+
+ ENDIF
+
+ENDIF
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. CONTOUR DRAWING
+! ---------------
+!
+!* 2.1 Loads abscissa and true-altitudes along
+!* the section in work arrays
+
+IF(.NOT.LPVT .AND. .NOT.LPXT .AND. .NOT.LPYT .AND. .NOT.LCVXZ .AND. .NOT.LCVYZ)THEN
+
+ NINX=NLMAX
+ NINY=IKU
+ DO JILOOP=1,NLMAX
+ XZZDS(JILOOP)=XDS(JILOOP,NMGRID)
+ ENDDO
+!print *,' ********IMCOU_FORDIACHRO NLMAX XZZDS',NLMAX
+!print *,(XZZDS(JILOOP),JILOOP=1,NLMAX)
+ DO JILOOP=1,NLMAX
+ DO JKLOOP=1,IKU
+ XZWORKZ(JILOOP,JKLOOP)=XWORKZ(JILOOP,JKLOOP,NMGRID)
+ ENDDO
+ ENDDO
+
+ENDIF
+!-----------------------------------------------------------------------------
+IF(LPRINTXY)THEN
+! IF(LDEFCV2CC .OR. XIDEBCOU /= -999.)THEN !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+! print *,' Pour l''instant, cette operation n''est prevue que pour une coupe definie avec :'
+! print *,' NIDEBCOU= NJDEBCOU= NLANGLE= NLMAX= '
+! print *,' A suivre ........ '
+! ELSE !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ ILOOP=SIZE(PTABV,1)/5
+ IF(ILOOP * 5 < SIZE(PTABV,1))ILOOP=ILOOP+1
+ IF(.NOT. LPVT)THEN
+!!Oct 2002
+ IF(LCVYZ)THEN
+ WRITE(INUM,'(''CV YZ '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'','' (1-NLMAX,1-IKU)'')')CGROUP, &
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ ELSE
+!!Oct 2002
+ WRITE(INUM,'(''CV XZ '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'','' (1-NLMAX,1-IKU)'')')CGROUP, &
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ ENDIF
+ ELSE
+ WRITE(INUM,'(''CV TIMEZ '','' G:'',A16,'' P:'',A40)')CGROUP, &
+!& CTITGAL
+& CTITRE(NLOOPP)(1:40)
+ ENDIF
+ IF(LMINUS .OR. LPLUS)THEN
+ WRITE(INUM,'(A70)')CTITB3
+ ELSE
+ WRITE(INUM,'(A40)')CTITGAL
+ ENDIF
+ IF(.NOT. LPVT)THEN
+ IF(.NOT.LCARTESIAN)THEN
+ ALLOCATE(ZLA(NLMAX),ZLO(NLMAX))
+ DO J=1,NLMAX
+ ZX=XDSX(J,NMGRID)
+ ZY=XDSY(J,NMGRID)
+ CALL SM_LATLON_S(XLATORI,XLONORI,ZX,ZY,ZLAT,ZLON)
+ ZLA(J)=ZLAT
+ ZLO(J)=ZLON
+ ENDDO
+ IF(LDEFCV2LL)THEN
+ ZLA(1)=XIDEBCVLL
+ ZLO(1)=XJDEBCVLL
+ ENDIF
+ if(nverbia > 0)then
+! print *,' ZLA'
+! print *,ZLA
+! print *,' ZLO'
+! print *,ZLO
+ endif
+! DEALLOCATE(ZLA,ZLO)
+ ENDIF
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2)THEN
+ WRITE(INUM,'(''cc(deb)-(fin)=('',F8.0,'','',F8.0,'')-('',F8.0,'','',F8.0,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCV,XJDEBCV,XIFINCV,XJFINCV,NLMAX,SIZE(PTABV,2),ILOOP
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(INUM,'(''ll(deb)-(fin)=('',F8.3,'','',F8.3,'')-('',F8.3,'','',F8.3,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL,NLMAX,SIZE(PTABV,2),ILOOP
+ ELSE IF(LDEFCV2IND)THEN
+ WRITE(INUM,'(''ij(deb)-(fin)=('',I4,'','',I4,'')-('',I4,'','',I4,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &NIDEBCV,NJDEBCV,NIFINCV,NJFINCV,NLMAX,SIZE(PTABV,2),ILOOP
+ ENDIF
+ ELSE
+ IF(XIDEBCOU /= -999.)THEN
+ WRITE(INUM,'(''xidebcou'',F8.0,'' xjdebcou'',F8.0,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCOU,XJDEBCOU,NLMAX,NLANGLE,SIZE(PTABV,2),ILOOP
+ ELSE
+ WRITE(INUM,'(''nidebcou'',i4,'' njdebcou'',i4,'' nlmax'',i5,'' nlangle'',i4, &
+& '' iku'',i4,'' iter'',i3)') &
+ & NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,SIZE(PTABV,2),ILOOP
+ ENDIF
+ ENDIF
+ IF(LCARTESIAN)THEN
+ WRITE(INUM,'(1X,41(1H*))')
+ WRITE(INUM,'(18X,''X'',12X,''RELIEF'')')
+ WRITE(INUM,'(1X,41(1H*))')
+ DO JLOOPI=1,NLMAX
+ IF(JLOOPI == 1)THEN
+ WRITE(INUM,'('' 1 '',I5,2(1X,E15.8))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ XWZ(JLOOPI,NMGRID)
+ ELSE IF(JLOOPI == NLMAX)THEN
+ WRITE(INUM,'(''NLMAX'',I5,2(1X,E15.8))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ XWZ(JLOOPI,NMGRID)
+ ELSE
+ WRITE(INUM,'('' '',I5,2(1X,E15.8))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ XWZ(JLOOPI,NMGRID)
+ ENDIF
+ ENDDO
+ WRITE(INUM,'(1X,41(1H*))')
+ ELSE
+ WRITE(INUM,'(1X,66(1H*))')
+ WRITE(INUM,'(18X,''X'',12X,''RELIEF'',11X,''LAT'',10X,''LONG'')')
+ WRITE(INUM,'(1X,66(1H*))')
+ DO JLOOPI=1,NLMAX
+ IF(JLOOPI == 1)THEN
+ IF(LCVYZ)THEN
+ WRITE(INUM,'('' 1 '',I5,2(1X,E15.8),2(2X,F10.5))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ ZWZ(JLOOPI+1),ZLA(JLOOPI),ZLO(JLOOPI)
+ ELSE
+ WRITE(INUM,'('' 1 '',I5,2(1X,E15.8),2(2X,F10.5))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ XWZ(JLOOPI,NMGRID),ZLA(JLOOPI),ZLO(JLOOPI)
+ END IF
+ ELSE IF(JLOOPI == NLMAX)THEN
+ IF(LCVYZ)THEN
+ WRITE(INUM,'(''NLMAX'',I5,2(1X,E15.8),2(2X,F10.5))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ ZWZ(JLOOPI+1),ZLA(JLOOPI),ZLO(JLOOPI)
+ ELSE
+ WRITE(INUM,'(''NLMAX'',I5,2(1X,E15.8),2(2X,F10.5))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ XWZ(JLOOPI,NMGRID),ZLA(JLOOPI),ZLO(JLOOPI)
+ END IF
+ ELSE
+ IF(LCVYZ)THEN
+ WRITE(INUM,'('' '',I5,2(1X,E15.8),2(2X,F10.5))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ ZWZ(JLOOPI+1),ZLA(JLOOPI),ZLO(JLOOPI)
+ ELSE
+ WRITE(INUM,'('' '',I5,2(1X,E15.8),2(2X,F10.5))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ XWZ(JLOOPI,NMGRID),ZLA(JLOOPI),ZLO(JLOOPI)
+ END IF
+ ENDIF
+ ENDDO
+ WRITE(INUM,'(1X,66(1H*))')
+ DEALLOCATE(ZLA,ZLO)
+ ENDIF
+
+ DO JLOOPI=1,ILOOP
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=5
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+5
+ ENDIF
+ IF(JLOOPI == ILOOP)THEN
+ IFIN=SIZE(PTABV,1)
+ ENDIF
+
+ WRITE(INUM,'(''ALTITUDES (1-NLMAX,1-IKU)'')')
+ WRITE(INUM,'(1X,79(1H*))')
+ WRITE(INUM,'('' K X-> '',I4,6X,4(6X,I4,6X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'(''.'',79(1H*))')
+ DO JLOOPJ=SIZE(PTABV,2),1,-1
+ IF(LCVYZ)THEN
+ WRITE(INUM,'(I4,1X,5(1X,E14.7))')JLOOPJ,(XZWORKZ(II,JLOOPJ),II=IDEB,IFIN)
+ ELSE
+ WRITE(INUM,'(I4,1X,5(1X,E14.7))')JLOOPJ,(XWORKZ(II,JLOOPJ,NMGRID),II=IDEB,IFIN)
+! WRITE(INUM,'(I4,1X,5E15.8)')JLOOPJ,(XWORKZ(II,JLOOPJ,NMGRID),II=IDEB,IFIN)
+ ENDIF
+ ENDDO
+ WRITE(INUM,'(1X,79(1H*))')
+ ENDDO
+
+ ELSE
+
+ WRITE(INUM,'(''NBVAL en I (TIME): '',i4, &
+& '' NBVAL en K (Z)'',i4)') &
+ & SIZE(PTABV,1),SIZE(PTABV,2)
+ ZMIG=MINVAL(XZWORKZ(1:NINX,1:NINY))
+ ZMAG=MAXVAL(XZWORKZ(1:NINX,1:NINY))
+ ZMI=MINVAL(XZWORKZ(NINX/2,1:NINY))
+ ZMA=MAXVAL(XZWORKZ(NINX/2,1:NINY))
+! print *,' ZMIG,ZMAG,ZMI,ZMA ',ZMIG,ZMAG,ZMI,ZMA
+
+ IF(ZMIG == ZMI .AND. ZMAG == ZMA)THEN
+
+ II=MAX(SIZE(PTABV,1),SIZE(PTABV,2))
+ WRITE(INUM,'(1X,43(1H*))')
+ WRITE(INUM,'(2X,'' I'',7X,''TIME'',10X,''K'',9X,''Z'')')
+ WRITE(INUM,'(1X,43(1H*))')
+ DO JLOOPJ=1,II
+ IF(SIZE(PTABV,1) > SIZE(PTABV,2))THEN
+ IF(JLOOPJ <= SIZE(PTABV,2))THEN
+ WRITE(INUM,'(I5,2X,E15.8,1X,I4,2X,E15.8)')JLOOPJ,XZZDS(JLOOPJ), &
+ JLOOPJ,XZWORKZ(1,JLOOPJ)
+ ELSE
+ WRITE(INUM,'(I5,2X,E15.8)')JLOOPJ,XZZDS(JLOOPJ)
+ ENDIF
+ ELSE IF(SIZE(PTABV,2) > SIZE(PTABV,1))THEN
+ IF(JLOOPJ <= SIZE(PTABV,1))THEN
+ WRITE(INUM,'(I5,2X,E15.8,1X,I4,2X,E15.8)')JLOOPJ,XZZDS(JLOOPJ), &
+ JLOOPJ,XZWORKZ(1,JLOOPJ)
+ ELSE
+ WRITE(INUM,'(23X,I4,2X,E15.8)')JLOOPJ,XZWORKZ(1,JLOOPJ)
+ ENDIF
+ ELSE
+ WRITE(INUM,'(I5,2X,E15.8,1X,I4,2X,E15.8)')JLOOPJ,XZZDS(JLOOPJ), &
+ JLOOPJ,XZWORKZ(1,JLOOPJ)
+ ENDIF
+ ENDDO
+ WRITE(INUM,'(1X,43(1H*))')
+
+ ELSE
+
+ DO JLOOPI=1,ILOOP
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=5
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+5
+ ENDIF
+ IF(JLOOPI == ILOOP)THEN
+ IFIN=SIZE(PTABV,1)
+ ENDIF
+
+ WRITE(INUM,'(''TEMPS - ALTITUDES '')')
+ WRITE(INUM,'(1X,79(1H*))')
+! WRITE(INUM,'(" K I-> ",I5,5X,4(5X,I5,5X))')
+ ALLOCATE(IE(IFIN-IDEB+1))
+ DO III=IDEB,IFIN
+ IE(III-IDEB+1)=III
+ ENDDO
+ WRITE(INUM,'(" K I-> ",I5,5X,4(5X,I5,5X))')IE
+! WRITE(INUM,'(" K I-> ",I5,5X,4(5X,I5,5X))')(/(III,III=IDEB,IFIN)/)
+ DEALLOCATE(IE)
+ WRITE(INUM,'(1X,79(1H.))')
+ WRITE(INUM,'(" . TIME->",F7.0,3X,4(4X,F7.0,4X))')(XZZDS(II),II=IDEB,IFIN)
+! WRITE(INUM,'(" ")')
+! WRITE(INUM,'(F7.0,3X,4(4X,F7.0,4X))')(XZZDS(II),II=IDEB,IFIN)
+ WRITE(INUM,'(''.'',79(1H*))')
+ DO JLOOPJ=SIZE(PTABV,2),1,-1
+ WRITE(INUM,'(I4,2X,5(1X,E14.7))')JLOOPJ,(XZWORKZ(II,JLOOPJ),II=IDEB,IFIN)
+! WRITE(INUM,'(I3,2X,5E15.8)')JLOOPJ,(XZWORKZ(II,JLOOPJ),II=IDEB,IFIN)
+ ENDDO
+ WRITE(INUM,'(1X,79(1H*))')
+ ENDDO
+ ENDIF
+
+ ENDIF
+! ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ENDIF
+!-----------------------------------------------------------------------------
+!
+!* 2.2 If required, the user provides Max and Min of the field
+!* to be plotted (within section)
+!
+ZINT=PINT
+
+IF(NIMNMX == 0 .OR. NIMNMX == 1)THEN
+
+! Modifs for Diachro
+!
+!CALL GMNMX(ZMIN,ZMAX,ZINT)
+ LISOK=.FALSE.
+ ZMIN=0.; ZMAX=0.
+ CALL READMNMXINT_ISO(NIMNMX,YTEXT(1:LEN_TRIM(YTEXT)),ZMIN,ZMAX,ZINT)
+
+ELSE IF(NIMNMX == 2)THEN
+ CALL READXISOLEVP(YTEXT(1:LEN_TRIM(YTEXT)),ILE,ZISOLEVP)
+ IF(NVERBIA > 5)THEN
+ print *,' IMCOU YTEXT,ILE,ZISOLEVP ',YTEXT(1:LEN_TRIM(YTEXT)),ILE,ZISOLEVP(1:ILE)
+ ENDIF
+
+ELSE IF (NIMNMX==3) THEN ! compute contour values from XISOREF and XDIAINT
+ ZISOLEVP(:)=9999.
+ ZMN=MINVAL(PTABV,MASK=PTABV/=XSPVAL)
+ ZMX=MAXVAL(PTABV,MASK=PTABV/=XSPVAL)
+ CALL READREFINT_ISO(YTEXT(1:LEN_TRIM(YTEXT)),ZMN,ZMX,ZINT,ZISOLEVP)
+ENDIF
+
+IF(.NOT.LPVT .AND. .NOT.LPXT .AND. .NOT.LPYT)THEN
+! min + max matrice
+if(nverbia >0)then
+print *,' ** imcou NLMAX ',NLMAX
+endif
+ZMN=PTABV(NLMAX/2,SIZE(PTABV,2)/2)
+ZMX=PTABV(NLMAX/2,SIZE(PTABV,2)/2)
+if(nverbia >0)then
+print *,' ** imcou AP ZMN=PTABV(NLMAX/2,SIZE(PTABV,2)/2); ZM...'
+endif
+ELSE
+II2=MAX(1,SIZE(PTABV,1)/2); IJ2=MAX(1,SIZE(PTABV,2)/2)
+ZMN=PTABV(II2,IJ2); ZMX=ZMN
+!ZMN=999999.; ZMX=-999999.
+ENDIF
+!-----------------------------------------------------------------------------
+IF(.NOT.LPVT .AND. .NOT.LPXT .AND. .NOT.LPYT)THEN
+DO JILOOP=1,NLMAX
+ DO JKLOOP=1,IKU
+ IF(LPRESY)THEN
+! en log(pression)
+ IF(XZWORKZ(JILOOP,JKLOOP) < XHMAX)CYCLE
+ IF(XZWORKZ(JILOOP,JKLOOP) > XHMIN)CYCLE
+ ELSE
+ IF(XZWORKZ(JILOOP,JKLOOP) > XHMAX)CYCLE
+ IF(XZWORKZ(JILOOP,JKLOOP) < XHMIN)CYCLE
+ ENDIF
+ IF(PTABV(JILOOP,JKLOOP) == XSPVAL)CYCLE
+ IF(PTABV(JILOOP,JKLOOP) < ZMN)ZMN=PTABV(JILOOP,JKLOOP)
+ IF(PTABV(JILOOP,JKLOOP) > ZMX)ZMX=PTABV(JILOOP,JKLOOP)
+ ENDDO
+ENDDO
+!-----------------------------------------------------------------------------
+ELSE
+IF(.NOT.LPXT .AND..NOT.LPYT)THEN
+DO JILOOP=1,SIZE(PTABV,1)
+ DO JKLOOP=1,SIZE(PTABV,2)
+ IF(LPRESY)THEN
+! en log(pression)
+ IF(XZWORKZ(JILOOP,JKLOOP) < XHMAX)CYCLE
+ IF(XZWORKZ(JILOOP,JKLOOP) > XHMIN)CYCLE
+ ELSE
+ IF(XZWORKZ(JILOOP,JKLOOP) > XHMAX)CYCLE
+ IF(XZWORKZ(JILOOP,JKLOOP) < XHMIN)CYCLE
+ ENDIF
+ IF(PTABV(JILOOP,JKLOOP) == XSPVAL)CYCLE
+ IF(PTABV(JILOOP,JKLOOP) < ZMN)ZMN=PTABV(JILOOP,JKLOOP)
+ IF(PTABV(JILOOP,JKLOOP) > ZMX)ZMX=PTABV(JILOOP,JKLOOP)
+ ENDDO
+ENDDO
+ELSE
+ ZMN=MINVAL(PTABV)
+ ZMX=MAXVAL(PTABV)
+ENDIF
+ENDIF
+!-----------------------------------------------------------------------------
+YLBL(1:5)='(Min:'
+WRITE(YLBL(6:15),'(E10.3)')ZMN
+YLBL(16:21)=', Max:'
+WRITE(YLBL(22:31),'(E10.3)')ZMX
+YLBL(32:32)=')'
+!
+!* 2.3 Conpack display options
+!
+CALL GSLWSC(1.) ! Line width
+!
+!
+!* 2.4 Contour selection rules
+!
+!print *,' ** imcou AV SELECT CASE(NIMNMX) '
+SELECT CASE(NIMNMX)
+ CASE(-1) ! Automatic contour scanning
+ CALL CPSETI('CLS',+16)
+ IF((LHACH1 .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))) .OR. &
+ (LHACH2 .AND. NSUPER == 2) .OR. &
+ (LHACH3 .AND. NSUPER == 3) .OR. &
+ (LHACH4 .AND. NSUPER == 4))CALL CPSETI('CLS',+7)
+
+ CALL CPSETR('CIS',-ZINT)
+!
+ CASE(0) ! Automatic range with given increment
+ CALL CPSETI('CLS',16)
+ CALL CPSETR('CIS',ZINT)
+ CALL CPSETI('LIS',NULBLL+1)
+ CALL CPSETR('CMN',100000000000.)
+! CALL CPSETR('CMN',MAXVAL(PTAB))
+ CALL CPSETR('CMX',10000000000.)
+! CALL CPSETR('CMX',MINVAL(PTAB))
+!
+ CASE(1) ! Given min, max and increment
+ IF(ZMAX == ZMIN)THEN
+ ICL=1
+ CALL CPSETI('NCL',ICL)
+ ELSE
+ ICL=NINT((ZMAX-ZMIN)/ZINT)
+ IF(ZMIN + ICL*ZINT <= ZMAX)ICL=ICL+1
+ CALL CPSETI('NCL',ICL)
+! IF(LCOLAREA .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1)))CALL CPSETI('NCL',ICL+1)
+ ENDIF
+ CALL CPSETI('CLS',0)
+ ZISO=ZMIN-ZINT
+ DO I=1,ICL
+ CALL CPSETI('PAI',I)
+ CALL CPSETI('AIA',I+1)
+ CALL CPSETI('AIB',I)
+ ZISO=ZISO+ZINT
+ IF(ABS(ZISO)<1.E-20)ZISO=0.
+ CALL CPSETR('CLV',ZISO)
+ CALL CPSETR('CLU',1.)
+ IF(.NOT.LSUPER.OR. (LSUPER .AND. NSUPER == 1))THEN
+ IF(LBLUSER1)THEN
+ DO JLBL=1,SIZE(XLBLUSER1)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER1(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ if(nverbia > 0)then
+ print *,' ISO LABELLE ',ZISO
+ endif
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 2)THEN
+ IF(LBLUSER2)THEN
+ DO JLBL=1,SIZE(XLBLUSER2)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER2(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 3)THEN
+ IF(LBLUSER3)THEN
+ DO JLBL=1,SIZE(XLBLUSER3)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER3(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 4)THEN
+ IF(LBLUSER4)THEN
+ DO JLBL=1,SIZE(XLBLUSER4)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER4(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ENDDO
+
+ CASE(2,3) ! Given contour values
+ ICL=0
+ DO I=1,1000
+ ICL=ICL+1
+! modifs for diachro
+ IF(NIMNMX==3 .OR. (NIMNMX==2 .AND.LISOLEVP))THEN
+ ZLEV(ICL)=ZISOLEVP(ICL)
+ IF(NVERBIA > 5)then
+ print *,' ** imcou ICL ZLEV ',ICL,ZLEV(ICL)
+ ENDIF
+ ELSE IF (NIMNMX==2 .AND. .NOT.LISOLEVP) THEN
+ IF(I == 1 .AND. XISOLEV(1) == 9999.)THEN
+ print *,' NIMNMX=2 . ABSENCE DE VALEURS DANS XISOLEV='
+ print *,' RENTREZ LES AU CLAVIER PAR ORDRE CROISSANT ET A RAISON D''1'
+ print *,' VALEUR PAR LIGNE. TERMINEZ PAR 9999.'
+ print *,' (REMARQUE : elles ne sont pas memorisees et donc valides pour le seul parametre'
+ print *,' en cours :',YTEXT(1:LEN_TRIM(YTEXT)),')'
+ ENDIF
+ IF(XISOLEV(1) == 9999.)THEN
+ READ(5,*)ZLEV(ICL)
+ ELSE
+ ZLEV(ICL)=XISOLEV(ICL)
+ ENDIF
+ ENDIF
+ IF(ZLEV(ICL) == 9999.)EXIT
+ ENDDO
+ IF(NVERBIA > 5) PRINT*,'ICL= ',ICL
+ ICL=ICL-1
+ CALL CPSETI('NCL',ICL)
+! IF(LCOLAREA .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1)))CALL CPSETI('NCL',ICL+1)
+ CALL CPSETI('CLS',0)
+ DO I=1,ICL
+ CALL CPSETI('PAI',I)
+ CALL CPSETI('AIA',I+1)
+ CALL CPSETI('AIB',I)
+ CALL CPSETR('CLV',ZLEV(I))
+ CALL CPSETR('CLU',1.)
+ IF(.NOT.LSUPER.OR. (LSUPER .AND. NSUPER == 1))THEN
+ IF(LBLUSER1)THEN
+ DO JLBL=1,SIZE(XLBLUSER1)
+ DO JL=-20,20,1
+ IF(ZLEV(I) == XLBLUSER1(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ if(nverbia > 0)then
+ print *,' ISO LABELLE ',ZLEV(I)
+ endif
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 2)THEN
+ IF(LBLUSER2)THEN
+ DO JLBL=1,SIZE(XLBLUSER2)
+ DO JL=-20,20,1
+ IF(ZLEV(I) == XLBLUSER2(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 3)THEN
+ IF(LBLUSER3)THEN
+ DO JLBL=1,SIZE(XLBLUSER3)
+ DO JL=-20,20,1
+ IF(ZLEV(I) == XLBLUSER3(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 4)THEN
+ IF(LBLUSER4)THEN
+ DO JLBL=1,SIZE(XLBLUSER4)
+ DO JL=-20,20,1
+ IF(ZLEV(I) == XLBLUSER4(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(I,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(I-1,NULBLL+1)==0).OR.I==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ENDDO
+!
+END SELECT
+!
+!* 2.5 Further Conpack cosmetic parameters
+!
+SELECT CASE(NIOFFD)
+ CASE(0) !! No label normalisation, decimal point kept
+ III=8 !
+ CALL CPSETI('NEU',III)! 'Numeric exponent use flag'
+ CALL CPSETI('NOF',7)!
+ CALL CPSETI('NET',0) ! Exponent shown as "E"
+ ! III > 0 --> decimal point kept if the number of
+ ! significant digits is << III; else form requiring
+ ! the fewest character is used
+ IF(NSD /= 0)THEN
+ CALL CPSETI('NSD',-NSD) ! Nb de digits significatifs
+ ELSE
+ CALL CPSETI('NSD',-6) ! Nb de digits significatifs
+ ENDIF
+ CASE DEFAULT !! Label normalization, exponent to the right
+ CALL CPSETI('NEU',-2) ! Exponent notation forced in any case
+ CALL CPSETI('NOF',7)!
+ CALL CPSETI('NET',0) ! Exponent shown as "E"
+END SELECT
+!
+!* 2.6 Special value handling
+!
+SELECT CASE(NIOFFP)
+
+ CASE(0) ! No special value used
+ CALL CPSETR('SPV',0.)
+ CASE DEFAULT ! XSPVAL used as a special value
+ CALL CPSETR('SPV',XSPVAL)
+
+END SELECT
+!
+!* 2.7 Information label under the plot
+!
+SELECT CASE(NIOFFM)
+
+ CASE(0) ! a label is printed under the plot
+ CASE DEFAULT ! no label
+ CALL CPSETC('ILT',' ')
+
+END SELECT
+
+ZTEMV=PTABV
+CALL CPSETR('SPV',XSPVAL)
+!
+!* 2.8 Conpack initialization
+!
+!-----------------------------------------------------------------------------
+ IF(LPVT .OR. LPXT .OR. LPYT)THEN
+ ILMAX=NLMAX
+ NLMAX=SIZE(PTABV,1)
+ ENDIF
+!-----------------------------------------------------------------------------
+IF(NIMNMX <= 0)THEN
+
+ ZTEMV2=ZTEMV
+ IF(.NOT.LPXT .AND. .NOT.LPYT)THEN
+ IF(LPRESY)THEN
+! En log(P)
+ WHERE(XZWORKZ(1:NLMAX,1:SIZE(ZTEMV2,2)) < XHMAX+ZDIXEPS)
+ ZTEMV2=XSPVAL
+ END WHERE
+ WHERE(XZWORKZ(1:NLMAX,1:SIZE(ZTEMV2,2)) > XHMIN-ZDIXEPS)
+ ZTEMV2=XSPVAL
+ END WHERE
+ ELSE
+ WHERE(XZWORKZ(1:NLMAX,1:SIZE(ZTEMV2,2)) > XHMAX+ZDIXEPS)
+ ZTEMV2=XSPVAL
+ END WHERE
+ WHERE(XZWORKZ(1:NLMAX,1:SIZE(ZTEMV2,2)) < XHMIN-ZDIXEPS)
+ ZTEMV2=XSPVAL
+ END WHERE
+ ENDIF
+ ENDIF
+
+!print *,' ZTEMV2'
+!print *,ZTEMV2
+!print *,' XHMIN XHMAX ',XHMIN-ZDIXEPS,XHMAX+ZDIXEPS
+!print *,XZWORKZ(1,1:IKU)
+
+if(nverbia > 0)then
+ print *,' BALISE1 IMCOU'
+endif
+ CALL CPRECT(ZTEMV2,NLMAX,NLMAX,SIZE(ZTEMV2,2),ZRWRK,JPLRWK,IWRK,JPLIWK)
+! CALL CPRECT(ZTEMV2,NLMAX,NLMAX,IKU,ZRWRK,JPLRWK,IWRK,JPLIWK)
+ CALL CPPKCL(ZTEMV2,ZRWRK,IWRK)
+ CALL CPGETI('NCL',INCL2)
+!Janv 2001
+! print *,' INCL2 ZTEMV2 ',INCL2
+ IF(ALLOCATED(ZZCLV2))THEN
+ DEALLOCATE(ZZCLV2)
+ ENDIF
+ ALLOCATE(ZZCLV2(INCL2))
+!Janv 2001
+ DO J=1,INCL2
+ CALL CPSETI('PAI',J)
+ CALL CPGETR('CLV',ZCLV2)
+!Janv 2001
+! PRINT *,' ZCLV2 ',ZCLV2
+ ZZCLV2(J)=ZCLV2
+!Janv 2001
+ IF(J == 1)ZCLVD=ZCLV2
+ IF(J == INCL2)ZCLVF=ZCLV2
+ ENDDO
+END IF
+!Janv 2001
+!print *,' ZCLVD ZCLVF ',ZCLVD,ZCLVF
+
+CALL CPRECT(ZTEMV,NLMAX,NLMAX,SIZE(ZTEMV,2),ZRWRK,JPLRWK,IWRK,JPLIWK)
+
+!CALL CPRECT(ZTEMV,NLMAX,NLMAX,IKU,ZRWRK,JPLRWK,IWRK,JPLIWK)
+CALL CPSETR('CWM',XSIZEL/.01)
+if(nverbia > 0)then
+ print *,' BALISE2 IMCOU NLMAX',NLMAX
+endif
+!-----------------------------------------------------------------------------
+IF(LPVT .OR. LPXT .OR. LPYT)THEN
+ NLMAX=ILMAX
+ENDIF
+if(nverbia > 0)then
+ print *,' BALISE3 IMCOU INCL2= ',INCL2
+endif
+!-----------------------------------------------------------------------------
+INCL=0
+CALL CPPKCL(ZTEMV,ZRWRK,IWRK)
+! Janv 2001
+!CALL CPGETI('NCL',INCL)
+IF(LCVZOOM)THEN
+ IF(NIMNMX <= 0)THEN
+ CALL CPSETI('CLS',0)
+ IF(INCL2==0)THEN
+ CALL CPSETI('NCL',1)
+ ELSE
+ CALL CPSETI('NCL',INCL2)
+ ENDIF
+ DO J=1,INCL2
+ CALL CPSETI('PAI',J)
+ CALL CPSETR('CLV',ZZCLV2(J))
+ ENDDO
+ ENDIF
+! DEALLOCATE(ZZCLV2)
+ENDIF
+CALL CPGETI('NCL',INCL)
+! Janv 2001
+if(nverbia > 0)then
+ print *,' BALISE3a IMCOU LCVZOOM= ',LCVZOOM
+endif
+!
+!* 2.9 High and low handling
+!
+SELECT CASE(NHI)
+
+ CASE(0) ! H + L are displayed
+ IF(INCL /= 0)THEN
+ CALL CPLBDR(ZTEMV,ZRWRK,IWRK)
+ ENDIF
+ CASE DEFAULT ! TO BE REVISED*********************
+ ! <0 --> no action (:-1 to be set)
+ ! >0 --> gridpoint value displayed
+ ! (1: to be set)
+END SELECT
+!
+!print *,' ZTEMV in IMCOU_FORDIACHRO 2.9' ! Technical message for developper's need
+!!print *,ZTEMV
+!* 2.10 Line style and color handling
+!
+! Janv 2001
+IF(NIMNMX <= 0)THEN
+!IF(NIMNMX < 0)THEN
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETR('CLU',1.)
+ CALL CPGETR('CLV',ZISO)
+ IF(.NOT.LSUPER.OR. (LSUPER .AND. NSUPER == 1))THEN
+ IF(LBLUSER1)THEN
+ DO JLBL=1,SIZE(XLBLUSER1)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER1(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ if(nverbia > 0)then
+ print *,' ISO LABELLE ',ZISO
+ endif
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(J,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(J-1,NULBLL+1)==0).OR.J==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 2)THEN
+ IF(LBLUSER2)THEN
+ DO JLBL=1,SIZE(XLBLUSER2)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER2(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(J,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(J-1,NULBLL+1)==0).OR.J==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 3)THEN
+ IF(LBLUSER3)THEN
+ DO JLBL=1,SIZE(XLBLUSER3)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER3(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(J,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(J-1,NULBLL+1)==0).OR.J==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER == 4)THEN
+ IF(LBLUSER4)THEN
+ DO JLBL=1,SIZE(XLBLUSER4)
+ DO JL=-20,20,1
+ IF(ZISO == XLBLUSER4(JLBL)*10.**FLOAT(JL))THEN
+ CALL CPSETR('CLU',3.)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(J,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(J-1,NULBLL+1)==0).OR.J==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(.NOT.LABEL1)THEN
+ IF((MOD(J,NULBLL+1)==0))CALL CPSETR('CLU',3.)
+ ELSE
+ IF((MOD(J-1,NULBLL+1)==0).OR.J==1)CALL CPSETR('CLU',3.)
+ ENDIF
+ ENDIF
+ ENDDO
+END IF
+
+if(nverbia > 0)then
+ print *,' BALISE3b IMCOU '
+endif
+SELECT CASE(NDOT)
+
+ CASE(0,1,1023,65535) ! Solid line
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('CLD',65535)
+ ENDDO
+ CASE (:-1) !<0 Dashed negative values,
+ ! solid positive values
+ ICLD=ABS(NDOT)
+! write(0,*)' NDOT',NDOT,' INCL ',INCL
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPGETR('CLV',ZCLV)
+ IF(ZCLV.GE.0.)CALL CPSETI('CLD',65535)
+ IF(ZCLV.LT.0.)CALL CPSETI('CLD',ICLD)
+! write(0,*)' J ZCLV',J,ZCLV
+ ENDDO
+
+ CASE DEFAULT ! NDOT used as a dash pattern
+ ICLD=ABS(NDOT)
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('CLD',ICLD)
+ ENDDO
+
+END SELECT
+!-----------------------------------------------------------------------------
+!
+! **************************************************************************
+! Surfaces en hachures ou/et grises; LHACHx=.TRUE. avec x=1 ou 2 ou 3 ou 4)
+! **************************************************************************
+
+IF((LHACH1 .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))) .OR. &
+ (LHACH2 .AND. NSUPER == 2) .OR. &
+ (LHACH3 .AND. NSUPER == 3) .OR. &
+ (LHACH4 .AND. NSUPER == 4))THEN !++++++++++++++++++++++++++++++++++++++++++
+
+ IF(NSUPER > 1)THEN
+ IH=IH+1
+! print *,' IHT IH ',IHT,IH
+ ENDIF
+
+ WRITE(NLUOUT,*)' >>>>>>>IMCOU_FORDIACHRO VARIABLE : ',HTEXT,' NB ISOC. : ',INCL,' VALEURS:'
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('AIB',J)
+ CALL CPSETI('AIA',J+1)
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ CALL GENFORMAT_FORDIACHRO(ZCLV,YLLBS(J))
+ ENDDO
+
+ IF(.NOT.LHACHSEL)THEN
+ IF(INCL+1 <= 8)THEN
+ DO J=1,INCL
+ IHACH(J)=INDHACHREF(J)
+ ENDDO
+ IHACH(INCL+1)=INDHACHREF(8)
+ ELSE
+ IHACH(1:2)=INDHACHREF(1:2)
+ IHACH(3)=INDHACHREF(2)
+ IHACH(INCL-1:INCL+1)=INDHACHREF(6:8)
+
+ IF(INCL+1 < 13)THEN
+ IHACH(4)=INDHACHREF(3)
+ ELSE
+ IHACH(4)=INDHACHREF(2)
+ ENDIF
+
+ IF(INCL+1 == 9)THEN
+ IHACH(5)=INDHACHREF(4)
+ IHACH(6)=INDHACHREF(5)
+ ELSE
+ IHACH(5)=INDHACHREF(3)
+ IF(INCL+1 < 13)THEN
+ IHACH(6)=INDHACHREF(4)
+ ELSE
+ IHACH(6)=INDHACHREF(3)
+ ENDIF
+ ENDIF
+
+ IF(INCL+1 == 10)THEN
+ IHACH(7)=INDHACHREF(5)
+ ELSE IF(INCL+1 >= 11 .AND. INCL+1 < 14)THEN
+ IHACH(7)=INDHACHREF(4)
+ ELSE IF(INCL+1 >= 14)THEN
+ IHACH(7)=INDHACHREF(3)
+ ENDIF
+
+ IF(INCL+1 >= 11 .AND. INCL+1 < 13)THEN
+ IHACH(8)=INDHACHREF(5)
+ ELSE IF(INCL+1 >= 13)THEN
+ IHACH(8)=INDHACHREF(4)
+ ENDIF
+
+ IF(INCL+1 >= 12 .AND. INCL+1 < 14)THEN
+ IHACH(9)=INDHACHREF(5)
+ ELSE IF(INCL+1 >= 14)THEN
+ IHACH(9)=INDHACHREF(4)
+ ENDIF
+
+ IF(INCL+1 == 13)THEN
+ IHACH(10)=INDHACHREF(5)
+ ELSE IF(INCL+1 >= 14 .AND. INCL+1 < 15)THEN
+ IHACH(10)=INDHACHREF(5)
+ ELSE IF(INCL+1 >= 15)THEN
+ IHACH(10)=INDHACHREF(4)
+ ENDIF
+
+ IF(INCL+1 >= 14)THEN
+ IHACH(11)=INDHACHREF(5)
+ ENDIF
+
+ IF(INCL+1 >= 15)THEN
+ IHACH(12)=INDHACHREF(5)
+ ENDIF
+
+ IF(INCL+1 == 16)THEN
+ IHACH(13)=INDHACHREF(5)
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ DO J=1,300
+ IHACH(J)=0
+ ENDDO
+ WRITE(NLUOUT,*)' >>>>>>>SELECTION DES GRISES ET HACHURES PAR L''UTILISATEUR'
+ WRITE(NLUOUT,*)' >>>>>>>VOUS DEVEZ FOURNIR ',INCL+1,' INDICES'
+ WRITE(NLUOUT,*)' Rentrez sur 1 premiere ligne le nombre d''indices fournis dans la ligne suivante'
+ WRITE(NLUOUT,*)' Puis sur la(es) ligne(s) suivante(s) les indices des grises ou hachures'
+ WRITE(NLUOUT,*)' pris dans la table de reference (de grises ou hachures)'
+ WRITE(NLUOUT,*)' correspondant aux isocontours ranges par ordre croissant'
+ WRITE(NLUOUT,*)' (Entiers separes par 1 blanc)'
+ READ(5,*,END=10)INBC
+ GO TO 11
+ 10 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez le nombre d indices '
+ READ(5,*)INBC
+ 11 CONTINUE
+ WRITE(YCAR80,*)INBC
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,YCAR80)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ READ(5,*,END=12)(IHACH(J),J=1,INBC)
+ GO TO 13
+ 12 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez la valeur des indices '
+ READ(5,*)(IHACH(J),J=1,INBC)
+ 13 CONTINUE
+! WRITE(YCAR160,*)IHACH(1:INBC)
+! YCAR160=ADJUSTL(YCAR160)
+! IF(LEN_TRIM(YCAR160) > 80 .OR. INBC > 20)THEN
+ IF(INBC > 20)THEN
+!Juillet 99
+! WRITE(YCAR80,'(20I4)')IHACH(1:INBC/2)
+! WRITE(YCAR80,*)IHACH(1:INBC/2)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,IHACH(1:INBC/2))
+! WRITE(YCAR80,'(20I4)')IHACH(INBC/2+1:INBC)
+! WRITE(YCAR80,*)IHACH(INBC/2+1:INBC)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,IHACH(INBC/2+1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ELSE
+ ! WRITE(YCAR80,'(20I4)')IHACH(1:INBC)
+! WRITE(YCAR80,*)IHACH(1:INBC)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,IHACH(1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ENDIF
+ ENDIF
+
+ IF(LCOLZERO)THEN
+ IHACH(NCOLZERO)=0
+ ENDIF
+ WRITE(NLUOUT,*)(ZLEV(J),IHACH(J),J=1,INCL)
+ WRITE(NLUOUT,*)IHACH(INCL+1)
+
+! Trace des zones hachurees
+ CALL GSFAIS(1)
+ CALL GSLN(1)
+! CALL GSFACI(1)
+ CALL GSPLCI(1)
+ CALL ARINAM(IIMAP,JPMAP)
+ CALL CPCLAM(ZTEMV,ZRWRK,IWRK,IIMAP)
+ CALL ARSCAM(IIMAP,ZXWRK,ZYWRK,JPWRK,IAREA,IGRP,JPAREAGRP,SFILLH)
+ print *,' Hach: MAP 1 6 5 ',IIMAP(1),IIMAP(6),IIMAP(5)
+ CALL GSFAIS(0)
+!
+! Trace des valeurs
+
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ CALL GSFAIS(1)
+ CALL LBSETI('CBL',1)
+! CALL LBSETI('CBL',0)
+ DO J=1,INCL
+ YLLBS(J)=ADJUSTL(YLLBS(J))
+ ENDDO
+ IF(NIMNMX <= 0)THEN
+ DO J=1,INCL
+ IF(ZLEV(J).GT.ZCLVD)EXIT
+ ENDDO
+ JJD=MAX(1,J-1)
+ DO J=INCL,1,-1
+ IF(ZLEV(J).LE.ZCLVF)EXIT
+ ENDDO
+ JJF=MIN(INCL,J)
+ INCL2=JJF-JJD+1
+ ENDIF
+ IF(.NOT.LSUPER .OR. NSUPER == 1)THEN
+ IF(ZVR < .8999999)THEN
+ print *,' ZVR < .9 ',ZVR
+ IF(NIMNMX <= 0)THEN
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(MIN(ZVR+.2,1.)-ZVR)/10.,MIN(ZVR+.2,1.),&
+ ZVB,ZVT,INCL2+1,.15,1.,IHACH(JJD:JJF+1),2,YLLBS(JJD:JJF),INCL2,1)
+ ELSE
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(MIN(ZVR+.2,1.)-ZVR)/10.,MIN(ZVR+.2,1.),ZVB,ZVT,INCL+1,.15,1.,IHACH,2,YLLBS,INCL,1)
+ ENDIF
+ ELSE
+ IF(INCL <= 8)THEN
+ print *,' INCL <= 8 ',INCL
+ IF(NIMNMX <= 0)THEN
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB+(ZVT-ZVB)/4.,ZVT,&
+ INCL2+1,.15,1.,IHACH(JJD:JJF+1),2,YLLBS(JJD:JJF),INCL2,1)
+ ELSE
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB+(ZVT-ZVB)/4.,ZVT,INCL+1,.15,1.,IHACH,2,YLLBS,INCL,1)
+ ENDIF
+ ELSE
+ print *,' INCL > 8 ',INCL
+ IF(NIMNMX <= 0)THEN
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB,ZVT,INCL2+1,.15,1.,IHACH(JJD:JJF+1),2,YLLBS(JJD:JJF),INCL2,1)
+ ELSE
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB,ZVT,INCL+1,.15,1.,IHACH,2,YLLBS,INCL,1)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ELSE
+
+! IF(NSUPERDIA > 2)THEN
+! ZVERA=ZVR-(ZVR-ZVL)/4.
+! ELSE
+! ZVERA=ZVR-(ZVR-ZVL)/3.
+! ENDIF
+! ZINTE=(ZVERA-ZVLDEF)/FLOAT(IHT)
+! IF(IHT == 1)THEN
+! ZD=ZVL; ZF=ZVERA
+! ELSE IF(IHT == 2 .OR. IHT == 3)THEN
+! ZD=ZVLDEF+ZINTE*(IH-1)
+! ZF=ZVLDEF+ZINTE*(IH)-.01
+! ENDIF
+ IF(NSUPERDIA > 2)THEN
+ ZVLDEF=.05
+ ZINTE=.26
+ ELSE
+ ZVLDEF=.1
+ ZINTE=.40
+ ENDIF
+ ZD=ZVLDEF+ZINTE*(NSUPER-2)
+ ZF=ZD+ZINTE-.02
+ IF(NIMNMX <= 0)THEN
+ IF(INCL2 == 1)THEN
+ ZF=ZF-(ZF-ZD)/2.
+ ELSE IF(INCL2 <= 4)THEN
+ ZF=ZF-(ZF-ZD)/4.
+ ENDIF
+ ELSE
+ IF(INCL == 1)THEN
+ ZF=ZF-(ZF-ZD)/2.
+ ELSE IF(INCL <= 4)THEN
+ ZF=ZF-(ZF-ZD)/4.
+ ENDIF
+ ENDIF
+ IF(NIMNMX <= 0)THEN
+ CALL LBLBAR_FORDIACHRO(0,ZD,ZF,ZVT+.01,ZVT+.04,INCL2+1,1.,.33,IHACH(JJD:JJF+1),2,YLLBS(JJD:JJF),INCL2,2)
+ ELSE
+ CALL LBLBAR_FORDIACHRO(0,ZD,ZF,ZVT+.01,ZVT+.04,INCL+1,1.,.33,IHACH,2,YLLBS,INCL,2)
+ ENDIF
+ ENDIF
+
+ CALL GSFAIS(0)
+!
+! Definition de la couleur des isos (0 -> blanc sur papier; 1 -> noir sur papier)
+ IF(LISOWHI)CALL GSPLCI(0)
+ IF(LISOWHI)CALL GSTXCI(0)
+
+!
+!
+ELSE IF(LCOLAREA)THEN !+++++++++++++++++++++++++++++++++++++++++++++++++
+
+! **************************************************************************
+! Surfaces couleur (reservees aux dessins avec ou sans superpositions; LCOLAREA=.TRUE.)
+! **************************************************************************
+
+ IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN !00000000000000000000000000000000000000000000
+
+! Selection automatique des couleurs par le programme
+! ***************************************************
+ IF(.NOT.LCOLAREASEL)THEN !====================================
+ CALL COLOR_FORDIACHRO(INCL+1,1)
+ WRITE(NLUOUT,*)' >>>>>>>IMCOU_FORDIACHRO VARIABLE : ',HTEXT,' NB ISOC. : ',INCL,' VALEURS:'
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('AIB',J)
+ CALL CPSETI('AIA',J+1)
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ ICOL(J)=J+2
+ CALL GENFORMAT_FORDIACHRO(ZCLV,YLLBS(J))
+ if(nverbia >5)then
+ print *,' J ZLEV(J) ICOL(J) A ',J,ZLEV(J),ICOL(J)
+ endif
+ ENDDO
+ ICOL(INCL+1)=INCL+3
+ if(nverbia >0)then
+ print *,' ICOL(INCL+1) A ',ICOL(INCL+1),' LCOLBR ',LCOLBR
+ print *,' LCOLZERO NCOLZERO ',LCOLZERO,NCOLZERO
+ endif
+ IF(LCOLBR)THEN
+ IF(ZLEV(MAX(1,INCL)) > ZLEV(1) .AND. ICOL(INCL+1) > ICOL(1))THEN
+ ALLOCATE(ICOL2(INCL+1))
+ if(nverbia >0)then
+ print *,' APRES ALLOCATE(ICOL2) '
+ endif
+ ICOL2(1:INCL+1)=ICOL(INCL+1:1:-1)
+ ICOL(1:INCL+1)=ICOL2
+! ICOL(:)=ICOL2
+ if(nverbia >0)then
+ print *,' AVANT DEALLOCATE(ICOL2) '
+ endif
+ DEALLOCATE(ICOL2)
+ END IF
+ END IF
+ if(nverbia >0)then
+ print *,' LCOLZERO NCOLZERO ',LCOLZERO,NCOLZERO
+ endif
+ IF(LCOLZERO)THEN
+ ICOL(NCOLZERO)=0
+ ENDIF
+ if(nverbia >0)then
+ print *,' **imcou NLUOUT ',NLUOUT
+ endif
+ WRITE(NLUOUT,*)(ZLEV(J),ICOL(J),J=1,INCL)
+ WRITE(NLUOUT,*)ICOL(INCL+1)
+ ELSE !====================================
+
+! Selection des couleurs par l'utilisateur
+! ****************************************
+
+ IF(LTABCOLDEF)THEN
+ ! Choix de la table de couleurs par defaut
+ WRITE(NLUOUT,*)' <<< TABCOLDEF >>>'
+ CALL TABCOL_FORDIACHRO
+ ELSE
+ ! Choix d'une table creee par l'utilisateur
+ CALL FMLOOK(YNAMTABCOL,CLUOUT,ILUCOL,IRESP)
+ IF(IRESP == -54)THEN
+ YNAMTABCOL(1:32)=' '
+ print *,' Entrez le nom de VOTRE TABLE de COULEURS '
+! Lecture du nom de la table de couleurs (1 seule fois)
+ READ(5,*,END=14)YNAMTABCOL
+ GO TO 15
+ 14 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez le nom de VOTRE TABLE de COULEURS'
+ READ(5,*)YNAMTABCOL
+ 15 CONTINUE
+ YNAMTABCOL=ADJUSTL(YNAMTABCOL)
+ !WRITE(NDIR,'(A80)')YNAMTABCOL
+ CALL WRITEDIR(NDIR,YNAMTABCOL)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+! Janv 2001
+ CALL FMLOOK(YNAMTABCOL,CLUOUT,ILUCOL,IRESP)
+ IF(IRESP /= 0)THEN
+! Janv 2001
+ CALL CREATLINK('DIRCOL',YNAMTABCOL,'CREAT',NVERBIA)
+ CALL FMATTR(YNAMTABCOL,CLUOUT,ILUCOL,IRESP)
+ OPEN(UNIT=ILUCOL,FILE=YNAMTABCOL,FORM='FORMATTED')
+! Janv 2001
+ ENDIF
+! Janv 2001
+ END IF
+
+ WRITE(NLUOUT,*)' <<< ',YNAMTABCOL,' >>>'
+ REWIND (ILUCOL)
+ CALL GQOPS(ISTA)
+ CALL GQACWK(1,IER,INB,IWK)
+!print *,' COLOR_FORDIACHRO AP GQACWK INB IWK ',INB,IWK
+ CALL GQOPWK(1,IER,INB,IWK)
+! Lecture du nb de couleurs de la table, des index de couleur et des
+! proportions relatives de rouge, vert, bleu
+ READ(ILUCOL,*)INBCT
+ DO J=1,INBCT
+ READ(ILUCOL,*)IDX,RED,GREEN,BLUE
+ DO JU=1,INB
+ CALL GQOPWK(JU,IER,INBB,IWK)
+ IF(IWK == 9)THEN
+ CYCLE
+ ELSE
+ CALL GSCR(IWK,IDX,RED,GREEN,BLUE)
+! CALL GSCR(1,IDX,RED,GREEN,BLUE)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+ WRITE(NLUOUT,*)' >>>>>>>IMCOU_FORDIACHRO VARIABLE : ',HTEXT,' NB ISOC. : ',INCL,' VALEURS:'
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('AIB',J)
+ CALL CPSETI('AIA',J+1)
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ if(nverbia >5)then
+ print *,' J ZLEV(J) B ',J,ZLEV(J)
+ endif
+ CALL GENFORMAT_FORDIACHRO(ZCLV,YLLBS(J))
+ ENDDO
+ DO J=1,300
+ ICOL(J)=0
+ ENDDO
+! Pour 1 dessin donne, lecture du nb d'indices de couleurs et de leur valeur
+! sur la ligne suivante
+ READ(5,*,END=16)INBC
+ GO TO 17
+ 16 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez le nb d indices de couleur'
+ READ(5,*)INBC
+ 17 CONTINUE
+ ! WRITE(YCAR80,*)INBC
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,INBC)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ READ(5,*,END=18)(ICOL(J),J=1,INBC)
+ GO TO 19
+ 18 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez la valeur des indices de couleur'
+ READ(5,*)(ICOL(J),J=1,INBC)
+ 19 CONTINUE
+! WRITE(YCAR160,*) ICOL(1:INBC)
+! YCAR160=ADJUSTL(YCAR160)
+! IF(LEN_TRIM(YCAR160) > 80 .OR. INBC > 20)THEN
+ IF(INBC > 20)THEN
+! Juillet 99
+ ! WRITE(YCAR80,'(20I4)')ICOL(1:INBC/2)
+! WRITE(YCAR80,*)ICOL(1:INBC/2)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ICOL(1:INBC/2))
+ ! WRITE(YCAR80,'(20I4)')ICOL(INBC/2+1:INBC)
+! WRITE(YCAR80,*)ICOL(INBC/2+1:INBC)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ICOL(INBC/2+1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ELSE
+! Juillet 99
+ ! WRITE(YCAR80,'(20I4)')ICOL(1:INBC)
+! WRITE(YCAR80,*)ICOL(1:INBC)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ICOL(1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ENDIF
+ WRITE(NLUOUT,*)(ZLEV(J),ICOL(J),J=1,INCL)
+ WRITE(NLUOUT,*)ICOL(INCL+1)
+! fin de la selection des couleurs par l'utilisateur
+ ENDIF !====================================
+!
+! Trace des zones colorees
+!*************************
+ IF(LMARKER .AND. .NOT. LSPOT)THEN
+ ! en etoiles colorees
+ !IF(.NOT.LPVT .AND. .NOT.LPXT .AND. .NOT.LPYT .AND. .NOT.LCVXZ .AND. .NOT.LCVYZ)THEN
+ IF(.NOT.LPYT .AND. .NOT.LCVXZ .AND. .NOT.LCVYZ)THEN
+ CALL GSMK(3) ! asterisk is the type of marker
+ DO JJ=1,SIZE(ZTEMV,2)
+ DO JI=1,SIZE(ZTEMV,1)
+ IF(ZTEMV(JI,JJ) /= XSPVAL)THEN
+ IF(ZTEMV(JI,JJ) < ZLEV(1))THEN
+ CALL GSPMCI(ICOL(1))
+ ELSE IF(ZTEMV(JI,JJ) >= ZLEV(INCL))THEN
+ CALL GSPMCI(ICOL(INCL+1))
+ ELSE
+ DO J=1,INCL-1
+ IF(ZTEMV(JI,JJ) >= ZLEV(J) .AND. &
+ ZTEMV(JI,JJ) < ZLEV(J+1))THEN
+ CALL GSPMCI(ICOL(J+1))
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ZX=XZZDS(JI)
+ ZY=XZWORKZ(JI,JJ)
+ CALL GPM(1,ZX,ZY)
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ print *,'pas de LMARKER teste pour ce type de tracé (PYT, 2D vert //X ou 2D vert //Y)'
+ print *,'essayer en modifiant le test IF(.NOT.LPVT... dans imcou_fordiachro'
+ ENDIF
+
+ ELSE IF (LSPOT .AND. .NOT. LMARKER) THEN
+ ! en paves de couleur
+ !IF(.NOT.LPVT .AND. .NOT.LPXT .AND. .NOT.LPYT .AND. .NOT.LCVXZ .AND. .NOT.LCVYZ)THEN
+ IF(.NOT.LPYT .AND. .NOT.LCVXZ .AND. .NOT.LCVYZ)THEN
+ CALL GSFAIS(1) ! solid filling of the polygon
+ IND=SIZE(ZTEMV,1)
+ ZEPX=(XZZDS(IND/2+1)-XZZDS(IND/2))*0.5
+ print *,'LSPOT: contour du pave en noir ?'
+ print *,' (o/O/y/Y recommande pour trace d observations '
+ print *,' epaisseur du contour gere avec XLW1)'
+ read(5,*) YREP
+ CALL WRITEDIR(NDIR,YREP)
+ IF(YREP=='o' .OR. YREP=='O' .OR. YREP=='y' .OR. YREP=='Y') THEN
+ ! contour en trait plein noir
+ CALL DASHDB(65535)
+ END IF
+ DO JJ=1,SIZE(ZTEMV,2)-1
+ DO JI=1,SIZE(ZTEMV,1)
+ IF (JJ==1) THEN
+ ZEPYD= XZWORKZ(JI,JJ) - ZWZ(JI+1) ! ZWZ(1:NLMAX+2)
+ ELSE
+ ZEPYD=XZWORKZ(JI,JJ) - (XZWORKZ(JI,JJ)+XZWORKZ(JI,JJ-1))*0.5
+ ENDIF
+ IF (JJ==SIZE(ZTEMV,2)-1) THEN
+ ZEPYU=0
+ ELSE
+ ZEPYU=(XZWORKZ(JI,JJ+1)+XZWORKZ(JI,JJ))*0.5 - XZWORKZ(JI,JJ)
+ ENDIF
+ IF(ZTEMV(JI,JJ) /= XSPVAL)THEN
+ IF(ZTEMV(JI,JJ) < ZLEV(1))THEN
+ CALL GSFACI(ICOL(1))
+ ELSE IF(ZTEMV(JI,JJ) >= ZLEV(INCL))THEN
+ CALL GSFACI(ICOL(INCL+1))
+ ELSE
+ DO J=1,INCL-1
+ IF(ZTEMV(JI,JJ) >= ZLEV(J) .AND. &
+ ZTEMV(JI,JJ) < ZLEV(J+1))THEN
+ CALL GSFACI(ICOL(J+1))
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ZX5(1)=XZZDS(JI)-ZEPX ; ZY5(1)=XZWORKZ(JI,JJ)-ZEPYD
+ ZX5(2)=XZZDS(JI)-ZEPX ; ZY5(2)=XZWORKZ(JI,JJ)+ZEPYU
+ ZX5(3)=XZZDS(JI)+ZEPX ; ZY5(3)=XZWORKZ(JI,JJ)+ZEPYU
+ ZX5(4)=XZZDS(JI)+ZEPX ; ZY5(4)=XZWORKZ(JI,JJ)-ZEPYD
+ ZX5(5)=XZZDS(JI)-ZEPX ; ZY5(5)=XZWORKZ(JI,JJ)-ZEPYD
+ ! paves
+ CALL GFA(5,ZX5,ZY5)
+ IF(YREP=='o' .OR. YREP=='O' .OR. YREP=='y' .OR. YREP=='Y') THEN
+ ! contour
+ CALL GQLWSC(IER,ZWIDTH)
+ CALL GSLWSC(XLWIDTH)
+ CALL CURVED(ZX5,ZY5,5)
+ CALL GSLWSC(ZWIDTH)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ ELSE
+ print *,'pas de LSPOT teste pour ce type de tracé (PYT, 2D vert //X ou 2D vert //Y)'
+ print *,'essayer en modifiant le test IF(.NOT.LPVT... dans imcou_fordiachro'
+ ENDIF
+ ELSE
+ ! Trace des surfaces colorees
+ CALL GSFAIS(1)
+ CALL ARINAM(IIMAP,JPMAP)
+ CALL CPCLAM(ZTEMV,ZRWRK,IWRK,IIMAP)
+ CALL ARSCAM(IIMAP,ZXWRK,ZYWRK,JPWRK,IAREA,IGRP,JPAREAGRP,CCOLR)
+ print *,' Col: MAP 1 6 5 ',IIMAP(1),IIMAP(6),IIMAP(5)
+ CALL GSPLCI(1)
+ CALL GSFAIS(0)
+! CALL GSLN(1)
+ ENDIF
+ ! Trace de la palette de couleurs (legende)
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ CALL GSFAIS(1)
+ CALL LBSETI('CBL',0)
+ DO J=1,INCL
+ YLLBS(J)=ADJUSTL(YLLBS(J))
+ ENDDO
+ IF(NIMNMX <= 0)THEN
+ DO J=1,INCL
+ IF(ZLEV(J).GT.ZCLVD)EXIT
+ ENDDO
+ JJD=MAX(1,J-1)
+ DO J=INCL,1,-1
+ IF(ZLEV(J).LE.ZCLVF)EXIT
+ ENDDO
+ JJF=MIN(INCL,J)
+ INCL2=JJF-JJD+1
+!print *,'ZLEV(1:INCL) ',ZLEV(1:INCL)
+!print *,' JJD JJF ZLEV(JJD:JJF) ',ZLEV(JJD:JJF)
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(MIN(1.-ZVR,.2))/10.,1.,ZVB,ZVT,INCL2+1,.15,1.,ICOL(JJD:JJF+1),1,YLLBS(JJD:JJF),INCL2,1)
+! CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB,ZVT,INCL2+1,.15,1.,ICOL(JJD:JJF+1),1,YLLBS(JJD:JJF),INCL2,1)
+ ELSE
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(MIN(1.-ZVR,.2))/10.,1.,ZVB,ZVT,INCL+1,.15,1.,ICOL,1,YLLBS,INCL,1)
+! CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB,ZVT,INCL+1,.15,1.,ICOL,1,YLLBS,INCL,1)
+ END IF
+ CALL GSFAIS(0)
+!
+! Definition de la couleur des isos (0 -> blanc sur papier; 1 -> noir sur papier)
+ IF(LISOWHI)CALL GSPLCI(0)
+ IF(LISOWHI)CALL GSTXCI(0)
+!
+ ELSE IF(LCOLINE)THEN !00000000000000000000000000000000000000000000
+
+! Traits couleur dans le cas de superpositions (LCOLAREA=.TRUE. et LCOLINE=.TRUE.)
+! **************************************************************************
+! Modifs 220396
+ IF((LSUPER .AND. NSUPER == 1) .OR. .NOT.LSUPER)CALL TABCOL_FORDIACHRO
+ IF(LSUPER)THEN
+!Mars 2000
+ IF(LCOLISONE)THEN
+ IF(NSUPER == 1)CALL GSPLCI(NCOLISONE1)
+ IF(NSUPER == 1)CALL GSTXCI(NCOLISONE1)
+ IF(NSUPER == 2)CALL GSPLCI(NCOLISONE2)
+ IF(NSUPER == 2)CALL GSTXCI(NCOLISONE2)
+ IF(NSUPER == 3)CALL GSPLCI(NCOLISONE3)
+ IF(NSUPER == 3)CALL GSTXCI(NCOLISONE3)
+ IF(NSUPER == 4)CALL GSPLCI(NCOLISONE4)
+ IF(NSUPER == 4)CALL GSTXCI(NCOLISONE4)
+ IF(NSUPER == 5)CALL GSPLCI(NCOLISONE5)
+ IF(NSUPER == 5)CALL GSTXCI(NCOLISONE5)
+ ELSE
+!Mars 2000
+ IF(NSUPER == 1)CALL GSPLCI(2)
+ IF(NSUPER == 1)CALL GSTXCI(2)
+ IF(NSUPER == 2)CALL GSPLCI(4)
+ IF(NSUPER == 2)CALL GSTXCI(4)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==2)CALL GSPLCI(2)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==2)CALL GSTXCI(2)
+ IF(NSUPER == 3)CALL GSPLCI(3)
+ IF(NSUPER == 3)CALL GSTXCI(3)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==3)CALL GSPLCI(4)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==3)CALL GSTXCI(4)
+ IF(NSUPER == 4)CALL GSPLCI(7)
+ IF(NSUPER == 4)CALL GSTXCI(7)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==4)CALL GSPLCI(3)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==4)CALL GSTXCI(3)
+!!!!!!!! PROVI
+!CALL FRSTPT(XDS(1,NMGRID),XHMIN)
+!CALL VECTOR(XDS(1,NMGRID),XHMAX)
+!CALL VECTOR(XDS(NLMAX,NMGRID),XHMAX)
+!CALL VECTOR(XDS(NLMAX,NMGRID),XHMIN)
+!CALL VECTOR(XDS(1,NMGRID),XHMIN)
+!!!!!!!! PROVI
+!Mars 2000
+ ENDIF
+!Mars 2000
+ END IF
+ ELSE !00000000000000000000000000000000000000000000
+
+! Traits noir et blanc dans le cas de superpositions (LCOLAREA=.TRUE. et LCOLINE=.FALSE.)
+! ********************************************************************************
+if(nverbia > 0)then
+ print *,' BALISE3c IMCOU '
+endif
+
+ CALL GSPLCI(1)
+ CALL GSLN(1)
+ IF(LSUPER)THEN
+ IF(NSUPER == 1)CALL GSLN(1)
+ IF(NSUPER == 2)CALL GSLN(1)
+
+ IF(LINVPTIR)THEN
+
+ IF(NSUPER == 3)THEN
+ CALL GSLN(2)
+ IF((LCOLAREA.OR.LHACH1) .AND. LHACH2)CALL GSLN(1)
+ ENDIF
+ IF(NSUPER == 4)CALL GSLN(3)
+
+ ELSE
+
+ IF(NSUPER == 3)THEN
+ CALL GSLN(3)
+ IF((LCOLAREA.OR.LHACH1) .AND. LHACH2)CALL GSLN(1)
+ ENDIF
+ IF(NSUPER == 4)CALL GSLN(2)
+
+ ENDIF
+
+ END IF
+
+ END IF !00000000000000000000000000000000000000000000
+
+ELSE IF( LGREY .AND. .NOT.LCOLAREA ) THEN !++++++++++++++++++++++++++++++
+! **************************************************************
+! Surfaces en grises ( LGREY=.TRUE.)
+! En cas de superpositions, obligatoirement le 1er dessin
+! **************************************************************
+ IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN !000000000000000000
+!
+! Selection automatique des grises par le programme
+! **************************************************
+!
+ CALL COLOR_FORDIACHRO(INCL+1,2)
+ WRITE(NLUOUT,*)' >>>>>>>IMCOU_FORDIACHRO VARIABLE : ',HTEXT,' NB ISOC. : ',INCL,' VALEURS:'
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('AIB',J)
+ CALL CPSETI('AIA',J+1)
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ ICOL(J)=J+2
+ CALL GENFORMAT_FORDIACHRO(ZCLV,YLLBS(J))
+ ENDDO
+ ICOL(INCL+1)=INCL+3
+ if(nverbia >0)then
+ print *,' Grey: ICOL(INCL+1) A ',ICOL(INCL+1),' LCOLBR ',LCOLBR
+ endif
+ IF(LCOLBR)THEN
+ IF(ZLEV(MAX(1,INCL)) > ZLEV(1) .AND. ICOL(INCL+1) > ICOL(1))THEN
+ ALLOCATE(ICOL2(INCL+1))
+ ICOL2(1:INCL+1)=ICOL(INCL+1:1:-1)
+ ICOL(1:INCL+1)=ICOL2
+! ICOL(:)=ICOL2
+ DEALLOCATE(ICOL2)
+ END IF
+ END IF
+ if(nverbia >0)then
+ print *,' Grey: LCOLZERO NCOLZERO ',LCOLZERO,NCOLZERO
+ endif
+ IF(LCOLZERO)THEN
+ ICOL(NCOLZERO)=0
+ ENDIF
+ WRITE(NLUOUT,*)(ZLEV(J),ICOL(J),J=1,INCL)
+ WRITE(NLUOUT,*)ICOL(INCL+1)
+ ! Trace des surfaces grisees
+ CALL GSFAIS(1)
+ CALL ARINAM(IIMAP,JPMAP)
+ CALL CPCLAM(ZTEMV,ZRWRK,IWRK,IIMAP)
+ CALL ARSCAM(IIMAP,ZXWRK,ZYWRK,JPWRK,IAREA,IGRP,JPAREAGRP,CCOLR)
+ print *,' Grey: MAP 1 6 5 ',IIMAP(1),IIMAP(6),IIMAP(5)
+ CALL GSPLCI(1)
+ CALL GSFAIS(0)
+! CALL GSLN(1)
+ ! Trace de la palette de couleurs (legende)
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ CALL GSFAIS(1)
+ CALL LBSETI('CBL',0)
+ DO J=1,INCL
+ YLLBS(J)=ADJUSTL(YLLBS(J))
+ ENDDO
+ IF(NIMNMX <= 0)THEN
+ DO J=1,INCL
+ IF(ZLEV(J).GT.ZCLVD)EXIT
+ ENDDO
+ JJD=MAX(1,J-1)
+ DO J=INCL,1,-1
+ IF(ZLEV(J).LE.ZCLVF)EXIT
+ ENDDO
+ JJF=MIN(INCL,J)
+ INCL2=JJF-JJD+1
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(MIN(1.-ZVR,.2))/10.,1.,ZVB,ZVT,INCL2+1,.15,1.,ICOL(JJD:JJF+1),1,YLLBS(JJD:JJF),INCL2,1)
+! CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB,ZVT,INCL2+1,.15,1.,ICOL(JJD:JJF+1),1,YLLBS(JJD:JJF),INCL2,1)
+ ELSE
+ CALL LBLBAR_FORDIACHRO(1,ZVR+(MIN(1.-ZVR,.2))/10.,1.,ZVB,ZVT,INCL+1,.15,1.,ICOL,1,YLLBS,INCL,1)
+! CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB,ZVT,INCL+1,.15,1.,ICOL,1,YLLBS,INCL,1)
+ ENDIF
+ CALL GSFAIS(0)
+!
+! Definition de la couleur des isos (0 -> blanc sur papier; 1 -> noir sur papier)
+ IF(LISOWHI)CALL GSPLCI(0)
+ IF(LISOWHI)CALL GSTXCI(0)
+
+ ELSE IF(LCOLINE)THEN !00000000000000000000000000000000000000000000
+
+! Traits couleur dans le cas de superpositions (LGREY=.TRUE. et LCOLINE=.TRUE.)
+! **************************************************************************
+ CALL TABCOL_FORDIACHRO
+ IF(LSUPER)THEN
+!Mars 2000
+ IF(LCOLISONE)THEN
+ IF(NSUPER == 1)CALL GSPLCI(NCOLISONE1)
+ IF(NSUPER == 1)CALL GSTXCI(NCOLISONE1)
+ IF(NSUPER == 2)CALL GSPLCI(NCOLISONE2)
+ IF(NSUPER == 2)CALL GSTXCI(NCOLISONE2)
+ IF(NSUPER == 3)CALL GSPLCI(NCOLISONE3)
+ IF(NSUPER == 3)CALL GSTXCI(NCOLISONE3)
+ IF(NSUPER == 4)CALL GSPLCI(NCOLISONE4)
+ IF(NSUPER == 4)CALL GSTXCI(NCOLISONE4)
+ IF(NSUPER == 5)CALL GSPLCI(NCOLISONE5)
+ IF(NSUPER == 5)CALL GSTXCI(NCOLISONE5)
+ ELSE
+!Mars 2000
+ IF(NSUPER == 1)CALL GSPLCI(2)
+ IF(NSUPER == 1)CALL GSTXCI(2)
+ IF(NSUPER == 2)CALL GSPLCI(4)
+ IF(NSUPER == 2)CALL GSTXCI(4)
+ IF((LARROVL .OR. LGREY .OR. LHACH1) .AND. NSUPER ==2)CALL GSPLCI(2)
+ IF((LARROVL .OR. LGREY .OR. LHACH1) .AND. NSUPER ==2)CALL GSTXCI(2)
+ IF(NSUPER == 3)CALL GSPLCI(3)
+ IF(NSUPER == 3)CALL GSTXCI(3)
+ IF((LARROVL .OR. LGREY .OR. LHACH1) .AND. NSUPER ==3)CALL GSPLCI(4)
+ IF((LARROVL .OR. LGREY .OR. LHACH1) .AND. NSUPER ==3)CALL GSTXCI(4)
+ IF(NSUPER == 4)CALL GSPLCI(7)
+ IF(NSUPER == 4)CALL GSTXCI(7)
+ IF((LARROVL .OR. LGREY .OR. LHACH1) .AND. NSUPER ==4)CALL GSPLCI(3)
+ IF((LARROVL .OR. LGREY .OR. LHACH1) .AND. NSUPER ==4)CALL GSTXCI(3)
+!!!!!!!! PROVI
+!CALL FRSTPT(XDS(1,NMGRID),XHMIN)
+!CALL VECTOR(XDS(1,NMGRID),XHMAX)
+!CALL VECTOR(XDS(NLMAX,NMGRID),XHMAX)
+!CALL VECTOR(XDS(NLMAX,NMGRID),XHMIN)
+!CALL VECTOR(XDS(1,NMGRID),XHMIN)
+!!!!!!!! PROVI
+!Mars 2000
+ ENDIF
+!Mars 2000
+ END IF
+
+ ELSE !00000000000000000000000000000000000000000000
+
+! Traits noir et blanc dans le cas de superpositions (LGREY=.TRUE. et LCOLINE=.FALSE.)
+! ********************************************************************************
+
+ CALL GSPLCI(1)
+ CALL GSLN(1)
+ IF(LSUPER)THEN
+ IF(NSUPER == 1)CALL GSLN(1)
+ IF(NSUPER == 2)CALL GSLN(1)
+
+ IF(LINVPTIR)THEN
+
+ IF(NSUPER == 3)THEN
+ CALL GSLN(2)
+ IF((LGREY.OR.LHACH1) .AND. LHACH2)CALL GSLN(1)
+ ENDIF
+ IF(NSUPER == 4)CALL GSLN(3)
+
+ ELSE
+
+ IF(NSUPER == 3)THEN
+ CALL GSLN(3)
+ IF((LGREY.OR.LHACH1) .AND. LHACH2)CALL GSLN(1)
+ ENDIF
+ IF(NSUPER == 4)CALL GSLN(2)
+
+ ENDIF
+
+ END IF
+
+ END IF !00000000000000000000000000000000000000000000
+!
+
+ELSE IF(LCOLINE)THEN !+++++++++++++++++++++++++++++++++++++++++++++++++++++
+! **********************************************
+! Traits couleur (LCOLAREA=.FALSE. et LCOLINE=.TRUE.)
+! **********************************************
+
+! Cas de superpositions
+! *********************
+! Modifs 220395=6
+ CALL TABCOL_FORDIACHRO
+! IF((LSUPER .AND. NSUPER == 1) .OR. .NOT.LSUPER)CALL TABCOL_FORDIACHRO
+! Modifs 270198
+! IF(LSUPER)THEN !............................................
+ IF(LSUPER .AND. & !............................................
+ !.NOT.((LHACH1.OR.LHACH2) .AND. NSUPERDIA == 2))THEN
+ .NOT.((LHACH1.OR.LHACH2) .AND. NSUPERDIA == 2) .AND. &
+ .NOT.( LARROVL .AND. NSUPERDIA == 2 ) )THEN
+
+!Mars 2000
+ IF(LCOLISONE)THEN
+ IF(NSUPER == 1)CALL GSPLCI(NCOLISONE1)
+ IF(NSUPER == 1)CALL GSTXCI(NCOLISONE1)
+ IF(NSUPER == 2)CALL GSPLCI(NCOLISONE2)
+ IF(NSUPER == 2)CALL GSTXCI(NCOLISONE2)
+ IF(NSUPER == 3)CALL GSPLCI(NCOLISONE3)
+ IF(NSUPER == 3)CALL GSTXCI(NCOLISONE3)
+ IF(NSUPER == 4)CALL GSPLCI(NCOLISONE4)
+ IF(NSUPER == 4)CALL GSTXCI(NCOLISONE4)
+ IF(NSUPER == 5)CALL GSPLCI(NCOLISONE5)
+ IF(NSUPER == 5)CALL GSTXCI(NCOLISONE5)
+ ELSE
+!Mars 2000
+
+ IF(NSUPER == 1)CALL GSPLCI(2)
+ IF(NSUPER == 1)CALL GSTXCI(2)
+ IF(NSUPER == 2)CALL GSPLCI(4)
+ IF(NSUPER == 2)CALL GSTXCI(4)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==2)CALL GSPLCI(2)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==2)CALL GSTXCI(2)
+ IF(NSUPER == 3)CALL GSPLCI(3)
+ IF(NSUPER == 3)CALL GSTXCI(3)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==3)CALL GSPLCI(4)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==3)CALL GSTXCI(4)
+ IF(NSUPER == 4)CALL GSPLCI(7)
+ IF(NSUPER == 4)CALL GSTXCI(7)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==4)CALL GSPLCI(3)
+ IF((LARROVL .OR. LCOLAREA .OR. LHACH1) .AND. NSUPER ==4)CALL GSTXCI(3)
+
+!Mars 2000
+ ENDIF
+!Mars 2000
+ ELSE !............................................
+! Pas de superpositions
+! *********************
+
+! Selection automatique des couleurs par le programme
+! ***************************************************
+
+ IF(.NOT.LCOLINESEL)THEN !::::::::::::::::::::::::::::::::::::
+
+!Mars 2000
+ IF(LCOLISONE)THEN
+ ICOL(1:INCL)=NCOLISONE1
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('CLC',ICOL(J))
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ ENDDO
+ WRITE(NLUOUT,*)' >>>>>>>IMCOU_FORDIACHRO VARIABLE : ',HTEXT,' NB ISOC. : ',INCL,' COULEUR UNIQUE : ',ICOL(1)
+ WRITE(NLUOUT,*)(ZLEV(J),J=1,INCL)
+ ELSE
+!Mars 2000
+
+ CALL COLOR_FORDIACHRO(INCL,1)
+ WRITE(NLUOUT,*)' >>>>>>>IMCOU_FORDIACHRO VARIABLE : ',HTEXT,' NB ISOC. : ',INCL,' VALEURS:'
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ ICOL(J)=J+2
+ if(nverbia > 5)then
+ print *,' J ZLEV(J) ICOL(J) C ',J,ZLEV(J),ICOL(J)
+ endif
+ CALL GENFORMAT_FORDIACHRO(ZCLV,YLLBS(J))
+ ENDDO
+ IF(LCOLBR)THEN
+ IF(ZLEV(MAX(1,INCL)) > ZLEV(1) .AND. ICOL(INCL) > ICOL(1))THEN
+ ALLOCATE(ICOL2(INCL))
+ ICOL2(1:INCL)=ICOL(INCL:1:-1)
+ ICOL(1:INCL)=ICOL2
+! ICOL(:)=ICOL2
+ DEALLOCATE(ICOL2)
+ END IF
+ END IF
+ WRITE(NLUOUT,*)(ZLEV(J),ICOL(J),J=1,INCL)
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('CLC',ICOL(J))
+ ENDDO
+!Mars 2000
+ ENDIF
+!Mars 2000
+
+ ELSE !::::::::::::::::::::::::::::::::::::
+
+! Selection des couleurs par l'utilisateur
+! ****************************************
+
+! Choix de la table de couleurs par defaut
+! ****************************************
+
+ IF(LTABCOLDEF)THEN
+ WRITE(NLUOUT,*)' <<< TABCOLDEF >>>'
+ CALL TABCOL_FORDIACHRO
+
+ ELSE
+
+! Choix d'une table creee par l'utilisateur
+! *****************************************
+
+ CALL FMLOOK(YNAMTABCOL,CLUOUT,ILUCOL,IRESP)
+ IF(IRESP == -54)THEN
+ YNAMTABCOL(1:32)=' '
+! Lecture du nom de la table de couleurs (1 seule fois)
+ print *,' Entrez le nom de VOTRE TABLE de COULEURS '
+ READ(5,*,END=20)YNAMTABCOL
+ GO TO 21
+ 20 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez le nom de VOTRE TABLE de COULEURS'
+ READ(5,*)YNAMTABCOL
+ 21 CONTINUE
+ YNAMTABCOL=ADJUSTL(YNAMTABCOL)
+ !WRITE(NDIR,'(A80)')YNAMTABCOL
+ CALL WRITEDIR(NDIR,YNAMTABCOL)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+! Janv 2001
+ CALL FMLOOK(YNAMTABCOL,CLUOUT,ILUCOL,IRESP)
+ IF(IRESP /= 0)THEN
+! Janv 2001
+ CALL CREATLINK('DIRCOL',YNAMTABCOL,'CREAT',NVERBIA)
+ CALL FMATTR(YNAMTABCOL,CLUOUT,ILUCOL,IRESP)
+ OPEN(UNIT=ILUCOL,FILE=YNAMTABCOL,FORM='FORMATTED')
+! Janv 2001
+ ENDIF
+! Janv 2001
+ END IF
+ WRITE(NLUOUT,*)' <<< ',YNAMTABCOL,' >>>'
+ REWIND (ILUCOL)
+ CALL GQOPS(ISTA)
+ CALL GQACWK(1,IER,INB,IWK)
+!print *,' COLOR_FORDIACHRO AP GQACWK INB IWK ',INB,IWK
+ CALL GQOPWK(1,IER,INB,IWK)
+! Lecture du nb de couleurs de la table, des index de couleur et des
+! proportions relatives de rouge, vert, bleu
+ READ(ILUCOL,*)INBCT
+ DO J=1,INBCT
+ READ(ILUCOL,*)IDX,RED,GREEN,BLUE
+ DO JU=1,INB
+ CALL GQOPWK(JU,IER,INBB,IWK)
+ IF(IWK == 9)THEN
+ CYCLE
+ ELSE
+ CALL GSCR(IWK,IDX,RED,GREEN,BLUE)
+! CALL GSCR(1,IDX,RED,GREEN,BLUE)
+ ENDIF
+ ENDDO
+ ENDDO
+ END IF
+! Pour 1 dessin donne, lecture du nb d'indices de couleurs et de leur valeur
+! sur la ligne suivante
+ DO J=1,300
+ ICOL(J)=1
+ ENDDO
+ READ(5,*,END=22)INBC
+ GO TO 23
+ 22 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez le nb d indices de couleur'
+ READ(5,*)INBC
+ 23 CONTINUE
+ !WRITE(YCAR80,*)INBC
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,INBC)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ READ(5,*,END=24)(ICOL(J),J=1,INBC)
+ GO TO 25
+ 24 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ print *,' INTERACTIF : Entrez la valeur des indices de couleur'
+ READ(5,*)(ICOL(J),J=1,INBC)
+ 25 CONTINUE
+! WRITE(YCAR160,*)ICOL(1:INBC)
+! YCAR160=ADJUSTL(YCAR160)
+! IF(LEN_TRIM(YCAR160) > 80 .OR. INBC > 20)THEN
+ IF(INBC > 20)THEN
+
+! Juillet 99
+ ! WRITE(YCAR80,'(20I4)')ICOL(1:INBC/2)
+! WRITE(YCAR80,*)ICOL(1:INBC/2)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ICOL(1:INBC/2))
+ !WRITE(YCAR80,'(20I4)')ICOL(INBC/2+1:INBC)
+! WRITE(YCAR80,*)ICOL(INBC/2+1:INBC)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ICOL(INBC/2+1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ELSE
+ ! WRITE(YCAR80,'(20I4)')ICOL(1:INBC)
+! WRITE(YCAR80,*)ICOL(1:INBC)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ICOL(1:INBC))
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ ENDIF
+ DO J=1,INCL
+ CALL CPSETI('PAI',J)
+ CALL CPSETI('CLC',ICOL(J))
+ CALL CPGETR('CLV',ZCLV)
+ ZLEV(J)=ZCLV
+ if(nverbia > 5)then
+ print *,' J ZLEV(J) ICOL(J) D ',J,ZLEV(J),ICOL(J)
+ endif
+ CALL GENFORMAT_FORDIACHRO(ZCLV,YLLBS(J))
+ ENDDO
+ WRITE(NLUOUT,*)' >>>>>>>IMCOU_FORDIACHRO VARIABLE : ',HTEXT,' NB ISOC. : ',INCL,' VALEURS:'
+ WRITE(NLUOUT,*)(ZLEV(J),ICOL(J),J=1,INCL)
+
+ END IF !::::::::::::::::::::::::::::::::::::
+
+!Mars 2000
+ IF(LCOLISONE)THEN
+ ELSE
+!Mars 2000
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ CALL GSFAIS(0)
+ CALL SETUSV('MI',1)
+ CALL SET(ZVR,1.,ZVB,ZVT,ZVR,1.,ZVB,ZVT,1)
+ IF(NIMNMX <= 0)THEN
+ DO J=1,INCL
+ IF(ZLEV(J).GE.ZCLVD)EXIT
+ ENDDO
+ JJD=MAX(1,J)
+ DO J=INCL,1,-1
+ IF(ZLEV(J).LE.ZCLVF)EXIT
+ ENDDO
+ JJF=MIN(INCL,J)
+ INCL2=JJF-JJD+1
+ IF(INCL2 <= 1)THEN
+ ZINTERV=0.
+ ELSE
+ ZINTERV=(ZVT-ZVB-.009)/(INCL2-1)
+ ENDIF
+ CALL GSCLIP(0)
+ DO J=JJD,JJF
+ YLLBS(J)=ADJUSTL(YLLBS(J))
+ CALL GSPLCI(ICOL(J))
+ CALL GSTXCI(ICOL(J))
+ if(nverbia > 0)then
+ print *,' BALISE3d IMCOU '
+ endif
+ IF(ZVR < .9 .AND. INCL < 25)THEN
+ CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.015,0.,-1.)
+ ELSEIF (ZVR < .9 .AND. INCL < 30 .AND. INCL >= 25)THEN
+ CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.012,0.,-1.)
+ ELSEIF (ZVR >= .95 )THEN
+ CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.007,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.009,0.,-1.)
+ ENDIF
+! CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.007,0.,-1.)
+ ENDDO
+ CALL GSCLIP(1)
+ ELSE
+ IF(INCL <= 1)THEN
+ ZINTERV=0.
+ ELSE
+ ZINTERV=(ZVT-ZVB-.009)/(INCL-1)
+ ENDIF
+ CALL GSCLIP(0)
+ if(nverbia > 0)then
+ print *,' BALISE3e IMCOU '
+ endif
+ DO J=1,INCL
+ YLLBS(J)=ADJUSTL(YLLBS(J))
+ CALL GSPLCI(ICOL(J))
+ CALL GSTXCI(ICOL(J))
+
+ IF(ZVR < .9 .AND. INCL < 25)THEN
+ CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.015,0.,-1.)
+ ELSEIF (ZVR < .9 .AND. INCL < 30 .AND. INCL >= 25)THEN
+ CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.012,0.,-1.)
+ ELSEIF (ZVR >= .95 )THEN
+ CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.007,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.009,0.,-1.)
+ ENDIF
+! CALL PLCHHQ(ZVR+(MIN(1.-ZVR,.2))/10.,ZVB+.004+(J-1)*ZINTERV,YLLBS(J),.007,0.,-1.)
+ ENDDO
+ CALL GSCLIP(1)
+ END IF
+ CALL SETUSV('MI',IMI)
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!Mars 2000
+ ENDIF
+!Mars 2000
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+
+
+ END IF !............................................
+
+ELSE !+++++++++++++++++++++++++++++++++++++++++++++++++++++
+if(nverbia > 0)then
+ print *,' BALISE3f IMCOU'
+endif
+
+!***************************************************
+! Traits noir et blanc (LCOLAREA=.FALSE. et LCOLINE=.FALSE.)
+!***************************************************
+
+ CALL GSPLCI(1)
+
+ IF(LSUPER)THEN !!! Overlay case
+
+
+ IF(NSUPER == 1)THEN ! If first plot of an overlay: default
+ CALL GSLN(1) ! Line is solid
+
+ ELSE ! If subsequent plots of an overlay: default
+
+ IF(LINVPTIR)THEN
+
+ IF(NSUPER ==2)CALL GSLN(2) ! line is a special dash type
+ IF((LARROVL .OR. (LCOLAREA .OR. LHACH1)) .AND. NSUPER ==2)CALL GSLN(1)
+ IF(NSUPER ==3)CALL GSLN(3)
+ IF((LARROVL .OR. (LCOLAREA .OR. LHACH1)) .AND. NSUPER ==3)THEN
+ CALL GSLN(1)
+ CALL GSLN(2)
+ IF(LHACH2)CALL GSLN(1)
+ ENDIF
+
+ ELSE
+
+ IF(NSUPER ==2)CALL GSLN(3) ! line is a special dash type
+ IF((LARROVL .OR. (LCOLAREA .OR. LHACH1)) .AND. NSUPER ==2)CALL GSLN(1)
+ IF(NSUPER ==3)CALL GSLN(2)
+ IF((LARROVL .OR. (LCOLAREA .OR. LHACH1)) .AND. NSUPER ==3)THEN
+ CALL GSLN(1)
+ CALL GSLN(3)
+ IF(LHACH2)CALL GSLN(1)
+ ENDIF
+
+ ENDIF
+
+ END IF
+
+ END IF !!! Not an overlay case
+!
+END IF !+++++++++++++++++++++++++++++++++++++++++++++++++++++
+if(nverbia > 0)then
+ print *,' BALISE3g IMCOU'
+endif
+!
+!* 2.11 High and low handling
+!
+SELECT CASE(NHI)
+
+CASE(0) ! H + L ara displayed
+ IF(INCL /=0)THEN
+ CALL CPLBDR(ZTEMV,ZRWRK,IWRK)
+ ENDIF
+CASE DEFAULT ! TO BE REVISED ********************
+ ! <0 --> no action (:-1 to be set)
+ ! >0 --> gridpoint value displayed (1: to be set)
+END SELECT
+
+!
+!* 2.12 Effective contour drawing, perimeter box, grid and labels
+!
+IF((LCOLAREA .AND. .NOT.LISO .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1)))&
+ .OR.(LHACH1 .AND. .NOT.LISO .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1)))&
+ .OR. (LHACH2 .AND. .NOT.LISO .AND. NSUPER == 2) &
+ .OR. (LHACH3 .AND. .NOT.LISO .AND. NSUPER == 3) &
+ .OR. (LHACH4 .AND. .NOT.LISO .AND. NSUPER == 4))THEN
+if(nverbia > 0)then
+ print *,' BALISE3ha IMCOU'
+endif
+
+ELSE
+
+if(nverbia > 0)then
+ print *,' BALISE3h IMCOU XLWIDTH ',XLWIDTH
+endif
+ CALL GSLWSC(XLWIDTH)
+if(nverbia > 0)then
+ print *,' BALISE3ha IMCOU APXLWIDTH '
+endif
+ IF(NSUPER == 2 .AND. LISOWHI2)THEN
+ CALL GSLN(1)
+ CALL GSPLCI(0)
+ CALL GSTXCI(0)
+ ELSE IF(NSUPER == 3 .AND. LISOWHI3)THEN
+ CALL GSLN(1)
+ CALL GSPLCI(0)
+ CALL GSTXCI(0)
+ ENDIF
+if(nverbia > 0)then
+ print *,' BALISE3ha IMCOU AV CPCLDR '
+endif
+ CALL CPCLDR(ZTEMV,ZRWRK,IWRK)
+if(nverbia > 0)then
+ print *,' BALISE3hb IMCOU AP CPCLDR '
+endif
+END IF
+IF((NSUPER == 2 .AND. LISOWHI2) .OR. (NSUPER == 3 .AND. LISOWHI3))THEN
+! CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ENDIF
+if(nverbia > 0)then
+ print *,' BALISE3I IMCOU INCL',INCL
+endif
+IF(INCL == 0)THEN
+ CALL CPLBDR(ZTEMV,ZRWRK,IWRK)
+ENDIF
+IF(nverbia > 0)THEN
+ print *,' **IMCOU AV GETSET'
+endif
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+CALL SETUSV('MI',1)
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+IF((LHACH1 .AND. NSUPER == 1) .OR. (LHACH2 .AND. NSUPER == 2) .OR. &
+ (LHACH3 .AND. NSUPER == 3) .OR. (LHACH4 .AND. NSUPER == 4))THEN
+ELSE
+ IF(LSUPER .AND. NSUPER > 1)THEN
+ IF((LCOLAREA .AND. NSUPER > 1) .OR. &
+ (.NOT.LCOLAREA .AND. &
+ .NOT.((LHACH1.OR.LHACH2) .AND. NSUPERDIA == 2)))THEN
+ ILENT=LEN_TRIM(HTEXT)+2
+ IF(LPVT)THEN
+ IF(NSUPERDIA >= 2 .AND. (LHACH2.OR.LHACH3))THEN
+ CALL FRSTPT(.1+(NSUPER-2)*.24,ZVT+.036)
+ CALL VECTOR(.1+(NSUPER-2)*.24+.03,ZVT+.036)
+ ELSE
+ CALL FRSTPT(.1+(NSUPER-2)*.24,ZVT+.016)
+ CALL VECTOR(.1+(NSUPER-2)*.24+.03,ZVT+.016)
+ ENDIF
+ ELSE
+ CALL GSLWSC(XLWIDTH)
+ IF(NSUPERDIA >= 2 .AND. (LHACH2.OR.LHACH3))THEN
+ CALL FRSTPT(.1+(NSUPER-2)*.24+ILENT*.009,ZVT+.05)
+ CALL VECTOR(.1+(NSUPER-2)*.24+ILENT*.009+.03,ZVT+.05)
+ ELSE
+ CALL FRSTPT(.1+(NSUPER-2)*.24+ILENT*.009,ZVT+.03)
+ CALL VECTOR(.1+(NSUPER-2)*.24+ILENT*.009+.03,ZVT+.03)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ENDIF
+
+CALL SETUSV('MI',IMI)
+!IF(LPRESY)THEN
+! CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,2)
+ if(nverbia > 0)then
+ print *,' ** imcou vers FIN ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,2,ID ',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID
+ endif
+!ELSE
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!ENDIF
+CALL GSLWSC(1.)
+CALL GSLN(1)
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+!
+CALL GSCLIP(0)
+CALL GASETI('LTY',1)
+! Mai 2000 Abscisses tps en heures si LHEURX=T
+IF(LPVT .AND. LHEURX)THEN
+! CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL/3600.,ZWR/3600.,ZWB,ZWT,ID)
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F8.0)'
+ ENDIF
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F7.0)'
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.0)','(F7.0)',0,0,10,10,0,0,0)
+!!!!!!!Avril 2002
+ IF(LMYHEURX)THEN
+ ZH=NHEURXGRAD*3600.
+ ELSE
+!!!!!!!Avril 2002
+
+ IF((ZWR-ZWL)/3600. > 24.)THEN
+ ZH=10800.
+ ELSE
+ ZH=3600.
+ ENDIF
+!!!!!!!Avril 2002
+ ENDIF
+!!!!!!!Avril 2002
+
+! CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ DO J=INT(ZWL),INT(ZWR)
+ ZJ=J
+!!!!!!!Avril 2002
+ IF(LMYHEURX)THEN
+ ZJJ=ZJ/ZH*NHEURXGRAD
+ ZINTT=NHEURXLBL
+ ELSE
+!!!!!!!Avril 2002
+
+ IF(ZH == 10800.)THEN
+ ZJJ=ZJ/ZH*3.
+ ZINTT=6.
+ ELSE
+ ZJJ=ZJ/ZH
+ ZINTT=3.
+ ENDIF
+!!!!!!!Avril 2002
+ ENDIF
+!!!!!!!Avril 2002
+!!!! Mars 2009 pour labels = hhHmm .besoin fournir les extremes sous
+!!!! Mars 2009 forme reelle avec OBLIG. 2 decimales pour minutes ex 9.45
+!!!! Mars 2009 pour eviter superposition ticks differents
+ IF(LHEURX .AND. LAXEXUSER .AND. LNOLABELX)THEN
+ ELSE
+!!!! Mars 2009 pour eviter superposition ticks differents
+ IF(MOD(ZJ,ZH) == 0.)THEN
+ CALL FRSTPT(ZJ,ZWB)
+ IF(LPRESY)THEN
+ CALL VECTOR(ZJ,ZWB+(ZWT-ZWB)/60.)
+ ELSE
+ IF(MOD(ZJJ,ZINTT) == 0.)THEN
+ CALL VECTOR(ZJ,ZWB+(ZWT-ZWB)/90.)
+ if(nverbia > 0)then
+ print *,' Ap VECTOR A IMCOU'
+ endif
+ ELSE
+ CALL VECTOR(ZJ,ZWB+(ZWT-ZWB)/120.)
+ if(nverbia > 0)then
+ print *,' Ap VECTOR B IMCOU'
+ endif
+ ENDIF
+ ENDIF
+!!!! Mars 2009
+ ENDIF
+!!!! Mars 2009
+ if(nverbia > 0)then
+ print *,' ** imcou vers FIN ZJ ZJJ ZINT ',ZJ,ZJJ,ZINTT
+ endif
+
+ ZWBBB=ZWB-((ZWT-ZWB)/((ZVT-ZVB)/.02))
+ IF(LPRESY)THEN
+ ZWBBB=ZWB-((ZWT-ZWB)/((ZVT-ZVB)/.05))
+ ENDIF
+ IF(.NOT.LNOLABELX)THEN
+ IF(MOD(ZJJ,ZINTT) == 0.)THEN
+ IF(ZJJ < 10.)THEN
+ YC2=' '
+ WRITE(YC2,'(F2.0)')ZJJ
+ CALL PLCHHQ(ZJ,ZWBBB,YC2,.010,0.,0.)
+ ELSEIF(ZJJ < 100.)THEN
+ YC3=' '
+ WRITE(YC3,'(F3.0)')ZJJ
+ CALL PLCHHQ(ZJ,ZWBBB,YC3,.010,0.,0.)
+ ELSE
+ YC4=' '
+ WRITE(YC4,'(F4.0)')ZJJ
+ CALL PLCHHQ(ZJ,ZWBBB,YC4,.010,0.,0.)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+! Mars 2001
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
+ IF(LFACTAXEX)THEN
+ IF(LFACTAXEY)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,&
+ ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
+ ELSE
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,&
+ ZWBB,ZWTT,IDD)
+ ENDIF
+ ELSEIF(LFACTAXEY)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
+ ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
+ ELSEIF(LAXEXUSER)THEN
+ IF(LAXEYUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,XAXEXUSERD,XAXEXUSERF,&
+ XAXEYUSERD,XAXEYUSERF,IDD)
+ ELSE
+ CALL SET(ZVL,ZVR,ZVB,ZVT,XAXEXUSERD,XAXEXUSERF,&
+ ZWBB,ZWTT,IDD)
+ ENDIF
+ ELSEIF(LAXEYUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
+ XAXEYUSERD,XAXEYUSERF,IDD)
+ ENDIF
+! Mars 2001
+ IF(LPRESY)THEN
+ CALL AXELOGPRES(XHMIN,XHMAX)
+ CALL GRIDAL(0,0,0,0,0,0,5,0.,0.)
+! CALL GRIDAL(0,0,1,9,0,1,5,0.,0.)
+ if(nverbia > 0)then
+ print *,' **imcou ap GRIDAL(0,0,2,10,0,1,5,0.,0.)'
+ endif
+ ELSE
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(0,0,NCVITVYMJ,NCVITVYMN,0,0,5,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(0,0,NCVITVYMJ,NCVITVYMN,0,1,5,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(0,0,NCVITVYMJ,NCVITVYMN,0,0,5,0.,0.)
+ ELSE
+ CALL GRIDAL(0,0,NCVITVYMJ,NCVITVYMN,0,1,5,0.,0.)
+ ENDIF
+!Avril 2002
+ ENDIF
+!!!!!!!!Mars 2009 pour ecrire des heures sous forme hhHmm sur axe X
+!!! Besoin de passer les extremes en valeurs réelles
+!!! dans XAXEXUSERD et XAXEXUSERF avec 2chiffres decimaux OBLIGATOIREMENT
+!!! pour les minutes
+!!! LAXEXUSER=T LHEURX=T LNOLABELX=T Obligatoires . 5 intervalles prevus
+!!! Intervenir sur NCVITVXMJ pour changer ce nb d'intervalles
+ IF(LAXEXUSER .AND. LHEURX .AND. LNOLABELX)THEN
+! Conversion extremes en minutes
+ ZTA=AINT(XAXEXUSERD)
+ ZTB=(XAXEXUSERD-ZTA)*100.
+ ZTD=ZTA*60+ZTB
+ ZTA=AINT(XAXEXUSERF)
+ ZTB=(XAXEXUSERF-ZTA)*100.
+ ZTF=ZTA*60+ZTB
+ ZTINT=(ZTF-ZTD)/NCVITVXMJ
+ ALLOCATE( ZTDX(NCVITVXMJ))
+ DO IA=2,NCVITVXMJ
+ ZTDX(IA)=ZTD+ZTINT*(IA-1)
+ ENDDO
+ ZTDX(1)=ZTD
+ ZINTV=(XAXEXUSERF-XAXEXUSERD)/NCVITVXMJ
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,0,0,0,1,5,0.,0.)
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWLC,ZWRC,ZWBC,ZWTC,IDD)
+!
+ DO IA=1,NCVITVXMJ+1
+ IF(IA == NCVITVXMJ+1)THEN
+ ZTD=ZTF
+ ELSE
+ ZTD=ZTDX(IA)
+ ENDIF
+ ZTA=AINT(ZTD/60.)
+ ZTB=ZTD-(ZTA*60.)
+ IF(L24H)THEN
+ DO IB=1,10
+ if(nverbia >0)print *,' IB ',IB
+ IF(ZTA > 24.)THEN
+ ZTA=ZTA-24.
+ if(nverbia >0)print *,' ZTA A ',ZTA
+ ELSE
+ IF(ZTA == 24. .AND. ZTB /= 0.)ZTA=ZTA-24.
+ if(nverbia >0)print *,' ZTA B ',ZTA
+! CYCLE
+ ENDIF
+ ENDDO
+ ENDIF
+ WRITE(YFORMAT,'(I2.2,"H",I2.2)')NINT(ZTA),NINT(ZTB)
+ CALL PLCHHQ(ZWLC+(IA-1)*ZINTV,ZWBC-(ZWTC-ZWBC)/40.,YFORMAT,.01,0.,0.)
+ ENDDO
+ DEALLOCATE(ZTDX)
+ ENDIF
+!!!!!!!!Mars 2009 pour ecrire des heures (Fin)
+ IF(LFACTAXEX .OR. LFACTAXEY .OR. LAXEXUSER .OR. LAXEYUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
+ ENDIF
+
+ELSE
+
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F8.0)'
+ ENDIF
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.0)'
+ ENDIF
+
+ IF(ABS(ZWB) > 999999. .OR. ABS(ZWT) > 999999.)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.0)','(F8.0)',0,0,10,10,0,0,0)
+ ELSE
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.0)'
+! FORMAY='(F7.0)'
+ ENDIF
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.0)','(F7.0)',0,0,10,10,0,0,0)
+ ENDIF
+ IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1) .OR. &
+ (NSUPER == 2 .AND. LISOWHI2) .OR. (NSUPER == 3 .AND. LISOWHI3))THEN
+! Mars 2001
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
+ IF(LFACTAXEX)THEN
+ IF(LFACTAXEY)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,&
+ ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
+ ELSE
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,&
+ ZWBB,ZWTT,IDD)
+ ENDIF
+ ELSEIF(LFACTAXEY)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
+ ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
+ ELSEIF(LAXEXUSER)THEN
+ IF(LAXEYUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,XAXEXUSERD,XAXEXUSERF,&
+ XAXEYUSERD,XAXEYUSERF,IDD)
+ ELSE
+ CALL SET(ZVL,ZVR,ZVB,ZVT,XAXEXUSERD,XAXEXUSERF,&
+ ZWBB,ZWTT,IDD)
+ ENDIF
+ ELSEIF(LAXEYUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
+ XAXEYUSERD,XAXEYUSERF,IDD)
+ ENDIF
+! Mars 2001
+ IF(LPRESY)THEN
+ CALL AXELOGPRES(XHMIN,XHMAX)
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,0,0,0,0,5,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,0,0,0,0,5,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,0,0,1,0,5,0.,0.)
+ ELSE
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,0,0,1,0,5,0.,0.)
+ ENDIF
+!Avril 2002
+ ELSE
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,0,0,5,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,0,1,5,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,1,0,5,0.,0.)
+ ELSE
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,1,1,5,0.,0.)
+ ENDIF
+!Avril 2002
+ ENDIF
+! CALL GRIDAL(5,0,10,0,1,1,5,0.,0.)
+ IF(LFACTAXEX .OR. LFACTAXEY .OR. LAXEXUSER .OR. LAXEYUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
+ ENDIF
+ ENDIF
+ENDIF
+!
+ IF(.NOT.LDEFCV2CC)THEN !%%%%%%%%%%%%%%%%%%%%%%
+
+ IF(NLANGLE.EQ.0.AND.XIDEBCOU.EQ.-999..AND.LXZ)THEN
+ CALL GSCLIP(0)
+ CALL TRACEXZ
+ CALL GSCLIP(1)
+ END IF
+
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%
+!
+!* 2.13 General NCAR parameter reset
+!
+CALL CPSETI('CLS',16)
+IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == NSUPERDIA))THEN
+ CALL CPRSET
+ENDIF
+CALL GSLN(1)
+!
+!* 2.14 Final touch: page information labels
+!
+IF(nverbia > 0)THEN
+ print *,' **IMCOU AV GETSET 2'
+endif
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+XCURVPTL=ZVL;XCURVPTR=ZVR;XCURVPTB=ZVB;XCURVPTT=ZVT
+IF(LANIMT)THEN
+ CALL PLCHHQ((0.002-ZVL)*(ZWR-ZWL)/(ZVR-ZVL),(0.050-ZVB)*(ZWT-ZWB)/(ZVT-ZVB), &
+ CTIMEC,.009,0.,-1.)
+ENDIF
+CALL SETUSV('MI',1)
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+!IF(LFACTIMP)THEN
+! CALL FACTIMP
+!ENDIF
+!
+!!!!!!!Debut Titres pour NSUPER = 1!!!!!!!!!!!!!!!!!!!
+IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN
+! Mars 2000
+IF(LFACTIMP)THEN
+ CALL FACTIMP
+ENDIF
+! Modifs for diachro
+!
+ IF(LXYO )THEN
+! IF(LXYO .AND. XIDEBCOU == -999. .AND. XJDEBCOU == -999.)THEN
+ YXYO(1:LEN(YXYO))=' '
+ IO=1
+ YXYO(IO:IO)='('
+! ZX=XXX(NIDEBCOU,NMGRID)
+! ZY=XXY(NJDEBCOU,NMGRID)
+ ZX=XDSX(1,NMGRID)
+ ZY=XDSY(1,NMGRID)
+ ZXE=XDSX(NLMAX,NMGRID)
+ ZYE=XDSY(NLMAX,NMGRID)
+ YC8(1:LEN(YC8))=' '
+ WRITE(YC8,'(F8.0)')ZX
+ YC8=ADJUSTL(YC8)
+ IO=IO+1
+ YXYO(IO:IO+LEN_TRIM(YC8)-1)=YC8(1:LEN_TRIM(YC8))
+ IO=IO+LEN_TRIM(YC8)
+ YXYO(IO:IO)=','
+ IO=IO+1
+ YC8(1:LEN(YC8))=' '
+ WRITE(YC8,'(F8.0)')ZY
+ YC8=ADJUSTL(YC8)
+ IO=IO+1
+ YXYO(IO:IO+LEN_TRIM(YC8)-1)=YC8(1:LEN_TRIM(YC8))
+ IO=IO+LEN_TRIM(YC8)
+ YXYO(IO:IO)=')'
+ CALL PLCHHQ(ZVL-.009,ZVB-(ZVB/7.1),YXYO(1:LEN_TRIM(YXYO)),.007,0.,-1.)
+ YXYO(1:LEN(YXYO))=' '
+ IO=1
+ YXYO(IO:IO)='('
+ YC8(1:LEN(YC8))=' '
+ WRITE(YC8,'(F8.0)')ZXE
+ YC8=ADJUSTL(YC8)
+ IO=IO+1
+ YXYO(IO:IO+LEN_TRIM(YC8)-1)=YC8(1:LEN_TRIM(YC8))
+ IO=IO+LEN_TRIM(YC8)
+ YXYO(IO:IO)=','
+ IO=IO+1
+ YC8(1:LEN(YC8))=' '
+ WRITE(YC8,'(F8.0)')ZYE
+ YC8=ADJUSTL(YC8)
+ IO=IO+1
+ YXYO(IO:IO+LEN_TRIM(YC8)-1)=YC8(1:LEN_TRIM(YC8))
+ IO=IO+LEN_TRIM(YC8)
+ YXYO(IO:IO)=')'
+ CALL PLCHHQ(ZVR,ZVB-(ZVB/7.1),YXYO(1:LEN_TRIM(YXYO)),.007,0.,+1.)
+ ENDIF
+! Remodifs le 17/05/96
+!
+! Titres en X
+!
+if(nverbia > 0)then
+ print *,' BALISE4 IMCOU NLMAX',NLMAX
+endif
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(XSZTITXL /= 0.)THEN
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/2.,.05),YTEM,XSZTITXL,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/2.,YTEM,XSZTITXL,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(XSZTITXM /= 0.)THEN
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),XSZTITXM,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),XSZTITXM,0.,0.)
+ ELSE
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+ ENDIF
+ ENDIF
+!
+! Titres en Y
+!
+IF(nverbia > 0)THEN
+ print *,' **IMCOU AV TITRES Y'
+endif
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYM',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYB',ZVL,ZVR,ZVB,ZVT,YTEM)
+ ZXPOSTITB1=.002
+ ZXYPOSTITB1=.005
+ IF(XPOSTITB1 /= 0.)THEN
+ ZXPOSTITB1=XPOSTITB1
+ ENDIF
+ IF(XYPOSTITB1 /= 0.)THEN
+ ZXYPOSTITB1=XYPOSTITB1
+ ENDIF
+ CALL RESOLV_TIT('CTITB1',HLEGEND)
+ IF(XSZTITB1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HLEGEND,XSZTITB1,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,HLEGEND,XSZTITB1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HLEGEND,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,HLEGEND,.007,0.,-1.)
+ ENDIF
+!
+! Titres TOP
+!
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT2',YTEM)
+
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.95
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+!! Oct 2001
+ IF(YTEM == ' ' .OR. YTEM == 'DEFAULT')THEN
+!!!Mars 2009 + NPROFILE /= 0
+ IF(LPVT .AND. NPROFILE /= 1 .AND. NPROFILE /= 0)THEN
+ YTEM(1:LEN(YTEM))=' '
+ WRITE(YTEM,1024)NPROFILE
+ ENDIF
+ ENDIF
+
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ ZXPOSTITT3=.002
+ ZXYPOSTITT3=.93
+ IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ ENDIF
+ IF(XYPOSTITT3 /= 0.)THEN
+ ZXYPOSTITT3=XYPOSTITT3
+ ENDIF
+ CALL RESOLV_TIT('CTITT3',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM(1:LEN_TRIM(YTEM)),XSZTITT3,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM(1:LEN_TRIM(YTEM)),XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM(1:LEN_TRIM(YTEM)),.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM(1:LEN_TRIM(YTEM)),.008,0.,-1.)
+ ENDIF
+ ENDIF
+
+ YCARCOU(1:LEN(YCARCOU))=' '
+ YCAR(1:LEN(YCAR))=' '
+
+ IF(.NOT.LPVT .AND..NOT.LPXT .AND..NOT.LPYT)THEN
+
+ YTEM(1:LEN(YTEM))=' '
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TITY('CTITYT',ZVL,ZVR,ZVB,ZVT,YTEM)
+ ENDIF
+ IF(.NOT.LANIMT)THEN
+ ! YTEM(1:LEN(YTEM))=' '
+ ZXPOSTITB3=.002
+ ZXYPOSTITB3=.045
+ IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ ENDIF
+ IF(XYPOSTITB3 /= 0.)THEN
+ ZXYPOSTITB3=XYPOSTITB3
+ ENDIF
+
+ IF(LMINUS .OR. LPLUS)THEN
+
+ IF(.NOT.LTITDEFM .AND. CTITB3MEM /= 'DEFAULT' .AND. &
+ CTITB3MEM /= 'default' .AND. CTITB3MEM /= 'DEFAUT' .AND. &
+ CTITB3MEM /= 'defaut')THEN
+ IF(CTITB3MEM /= ' ' .AND. CTITB3MEM /= 'WHITE' .AND. &
+ CTITB3MEM /= 'white' .AND. CTITB3MEM /= 'BLANC' .AND. &
+ CTITB3MEM /= 'blanc')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),.009,0.,-1.)
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ CALL RESOLV_TIT('CTITB3',CTITB3)
+ IF(CTITB3 /= ' ')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3(1:LEN_TRIM(CTITB3)),XSZTITB3,0.,-1.)
+! CALL PLCHHQ(0.002,0.050,CTITB3(1:LEN_TRIM(CTITB3)),XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTITB3(1:LEN_TRIM(CTITB3)),.009,0.,-1.)
+! CALL PLCHHQ(0.002,0.050,CTITB3(1:LEN_TRIM(CTITB3)),.009,0.,-1.)
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ELSE
+ if(nverbia > 0)then
+ print *,' **imcou CTIMEC,YTEM ',CTIMEC,YTEM
+ endif
+ YTEM(1:LEN(YTEM))=' '
+ YTEM=CTIMEC
+ YTEM=ADJUSTL(YTEM)
+ if(nverbia > 0)then
+ print *,' **imcou CTIMEC,YTEM ',CTIMEC,YTEM
+ endif
+ CALL RESOLV_TIT('CTITB3',YTEM)
+! CALL RESOLV_TIT('CTITB3',CTIMEC)
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM(1:LEN_TRIM(YTEM)),XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM(1:LEN_TRIM(YTEM)),.009,0.,-1.)
+ ENDIF
+ ENDIF
+ if(nverbia > 0)then
+ print *,' **imcou CTIMEC,YTEM ',CTIMEC,YTEM
+ endif
+! IF(CTIMEC /= ' ')THEN
+! IF(XSZTITB3 /= 0.)THEN
+! CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTIMEC,XSZTITB3,0.,-1.)
+! ELSE
+! CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTIMEC,.009,0.,-1.)
+! ENDIF
+! ENDIF
+ ENDIF
+ ENDIF
+ CALL RESOLV_TIT('CTITB2',CLEGEND2)
+ CLEGEND2=ADJUSTL(CLEGEND2)
+ if(nverbia > 0)then
+ print *,' **imcou CLEGEND2 ',CLEGEND2(1:LEN_TRIM(CLEGEND2))
+ print *,' **imcou CTITB2 ',CTITB2(1:LEN_TRIM(CTITB2))
+ endif
+ ZXPOSTITB2=.002
+ ZXYPOSTITB2=.025
+ IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ ENDIF
+ IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ ENDIF
+ IF(CLEGEND2 /= ' ')THEN
+ IF(XSZTITB2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,XSZTITB2,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,CLEGEND2,XSZTITB2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
+ ENDIF
+ ENDIF
+ IF(XIDEBCOU.NE.-999.)THEN
+
+ IF(LDEFCV2CC)THEN !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(LDEFCV2IND)THEN
+ WRITE(YCARCOU,1018)NIDEBCV,NJDEBCV,NIFINCV,NJFINCV
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(YCARCOU,1019)XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL
+ ELSE
+ WRITE(YCARCOU,1020)XIDEBCV,XJDEBCV,XIFINCV,XJFINCV
+ ENDIF
+ ELSE !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(XIDEBCOU < 99999.)THEN
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1001)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ ELSE
+ WRITE(YCARCOU,1002)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ END IF
+ ELSE
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1003)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ ELSE
+ WRITE(YCARCOU,1004)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ END IF
+ END IF
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ ELSE
+ WRITE(YCARCOU,1000)NIDEBCOU,NJDEBCOU,NLANGLE,NLMAX
+ END IF
+ if(nverbia > 0)then
+ print *,' IMCOU AV RESOLVTIT 1 ',YCARCOU(1:LEN_TRIM(YCARCOU))
+ endif
+ CALL RESOLV_TIT('CTITT1',YCARCOU)
+ if(nverbia > 0)then
+ print *,' IMCOU AP RESOLVTIT 1'
+ endif
+ ZXPOSTITT1=.002
+ ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+ IF(YCARCOU /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,.012,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(XSZTITXR /= 0.)THEN
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/2.,.05),YTEM,XSZTITXR,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,XSZTITXR,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ IND=INDEX(CLEGEND2(10:LEN_TRIM(CLEGEND2)),'DATE')
+ IF(IND == 0)THEN
+ CLEGEND2(1:LEN_TRIM(CLEGEND2))=' '
+ ELSE
+ IND=IND+10-1
+ CLEGEND2(IND:LEN_TRIM(CLEGEND2))=' '
+ ENDIF
+ CALL RESOLV_TIT('CTITB2',CLEGEND2)
+ ZXPOSTITB2=.002
+ ZXYPOSTITB2=.025
+ IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ ENDIF
+ IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ ENDIF
+ IF(CLEGEND2 /= ' ')THEN
+ IF(XSZTITB2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,XSZTITB2,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,CLEGEND2,XSZTITB2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ IF(LPVT .OR. LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
+ IF(LPVT .AND. LHEURX)THEN
+ YTEM='(H)'
+ ELSE
+ YTEM='(Sec.)'
+ ENDIF
+ ELSE IF(LPXT .AND. LXABSC)THEN
+ YTEM='(X)'
+ ENDIF
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITXR /= 0.)THEN
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/2.,.05),YTEM,XSZTITXR,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,XSZTITXR,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ IF(LPXT .AND..NOT.LXABSC)THEN
+ YTEM='(X)'
+ ELSE IF(LPXT .AND. LXABSC)THEN
+ YTEM='(S)'
+ ELSE IF(LPYT)THEN
+ YTEM='(Y)'
+ ELSE
+IF(nverbia > 0)THEN
+ print *,' **IMCOU AV Model;Levels;(M)'
+endif
+ YTEM='Model;Levels;(M)'
+ IF(LPRESY)THEN
+ YTEM='Pressure;(Mbs)'
+ ENDIF
+ ENDIF
+ CASE DEFAULT
+IF(nverbia > 0)THEN
+ print *,' **IMCOU AV Levels;(M)'
+endif
+ YTEM='Levels;(M)'
+ END SELECT
+ CALL RESOLV_TITY('CTITYT',ZVL,ZVR,ZVB,ZVT,YTEM)
+ !CALL PLCHHQ(0.,ZVT-1*.015,'Model',.008,0.,-1.)
+ !CALL PLCHHQ(0.,ZVT-2*.015,'Levels',.008,0.,-1.)
+ !CALL PLCHHQ(0.,ZVT-3*.015,'(M)',.008,0.,-1.)
+
+ IF(L1DT)THEN
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ IF(LPXT)THEN
+ WRITE(YCARCOU,1016)NIINF,NISUP
+ ELSE IF(LPYT)THEN
+ WRITE(YCARCOU,1017)NJINF,NJSUP
+ ELSE
+ WRITE(YCARCOU,1012)
+ ENDIF
+ CASE('SSOL')
+ YCARCOU(1:LEN(YCARCOU))=' '
+ YCARCOU(1:7)='SSOL N.'
+ WRITE(YCARCOU(8:10),'(I3)')NLOOPN
+ YCARCOU(11:13)=' ('
+ WRITE(YCARCOU(14:18),'(F5.0)')XTRAJX(1,1,NLOOPN)
+ YCARCOU(19:19)=','
+ WRITE(YCARCOU(20:24),'(F5.0)')XTRAJY(1,1,NLOOPN)
+ YCARCOU(25:27)=') '
+ ISUIT=28
+ ISUI=8
+ IF(ALLOCATED(ISTM))THEN
+ DEALLOCATE(ISTM)
+ ENDIF
+ ALLOCATE(ISTM(NSUPERDIA))
+! 20 Nov 2000
+ INDISTM=1
+! 20 Nov 2000
+ ISTM(INDISTM)=NLOOPN
+ CASE DEFAULT
+ YCARCOU(1:LEN(YCARCOU))=' '
+ YCARCOU(1:4)=CTYPE
+ YCARCOU(5:7)=' N.'
+ WRITE(YCARCOU(8:10),'(I3)')NLOOPN
+ if(nverbia > 0)then
+ print *,' ** IMCOU YCARCOU AP WRI NLOOPN ',YCARCOU
+ endif
+ ISUIT=11
+ IF(ALLOCATED(ISTM))THEN
+ DEALLOCATE(ISTM)
+ ENDIF
+ ALLOCATE(ISTM(NSUPERDIA))
+ if(nverbia > 0)then
+ print *,' ** IMCOU NSUPERDIA ISTM ',NSUPERDIA
+ endif
+ INDISTM=1
+ ISTM(INDISTM)=NLOOPN
+ if(nverbia > 0)then
+ print *,' ** IMCOU NSUPERDIA ISTM ',NSUPERDIA,ISTM
+ endif
+ END SELECT
+IF(nverbia > 0)THEN
+ print *,' **IMCOU FIN IF(L1DT)'
+endif
+
+ ELSE
+IF(nverbia > 0)THEN
+ print *,' **IMCOU FIN IF(L1DT) et AP ELSE'
+endif
+
+ IF(LPXT)THEN
+ WRITE(YCARCOU,1016)NIINF,NISUP
+ ELSE IF(LPYT)THEN
+ WRITE(YCARCOU,1017)NJINF,NJSUP
+ ELSE
+ IF(XIDEBCOU.NE.-999.)THEN
+ IF(LDEFCV2CC)THEN !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ YCAR(1:LEN(YCAR))=' '
+ IF(LDEFCV2IND)THEN
+ IF(LPVT .AND. NPROFILE == 1)THEN
+ WRITE(YCARCOU,1023)NIDEBCV,NJDEBCV
+ ELSE
+ IF(LPVT .AND. NPROFILE /= 1)THEN
+ WRITE(YCARCOU,1018)NIDEBCV,NJDEBCV,NIFINCV,NJFINCV
+ WRITE(YCAR,1024)NPROFILE
+ ELSE
+ WRITE(YCARCOU,1018)NIDEBCV,NJDEBCV,NIFINCV,NJFINCV
+ ENDIF
+ ENDIF
+ ELSE IF(LDEFCV2LL)THEN
+ IF(LPVT .AND. NPROFILE == 1)THEN
+ WRITE(YCARCOU,1021)XIDEBCVLL,XJDEBCVLL
+ ELSE
+ IF(LPVT .AND. NPROFILE /= 1)THEN
+ WRITE(YCARCOU,1019)XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL
+ WRITE(YCAR,1024)NPROFILE
+ ELSE
+ WRITE(YCARCOU,1019)XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL
+ ENDIF
+ ENDIF
+ ELSE
+ IF(LPVT .AND. NPROFILE == 1)THEN
+ WRITE(YCARCOU,1022)XIDEBCV,XJDEBCV
+ ELSE
+ IF(LPVT .AND. NPROFILE /= 1)THEN
+ WRITE(YCARCOU,1020)XIDEBCV,XJDEBCV,XIFINCV,XJFINCV
+ WRITE(YCAR,1024)NPROFILE
+ ELSE
+ WRITE(YCARCOU,1020)XIDEBCV,XJDEBCV,XIFINCV,XJFINCV
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(XIDEBCOU < 99999.)THEN
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1011)XIDEBCOU,XJDEBCOU,NLANGLE,NPROFILE
+ ELSE
+ WRITE(YCARCOU,1013)XIDEBCOU,XJDEBCOU,NLANGLE,NPROFILE
+ END IF
+ ELSE
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1014)XIDEBCOU,XJDEBCOU,NLANGLE,NPROFILE
+ ELSE
+ WRITE(YCARCOU,1015)XIDEBCOU,XJDEBCOU,NLANGLE,NPROFILE
+ END IF
+ END IF
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ ELSE
+ WRITE(YCARCOU,1010)NIDEBCOU,NJDEBCOU,NLANGLE,NPROFILE
+ ENDIF
+ ENDIF
+
+ END IF
+
+ if(nverbia > 0)then
+ print *,' IMCOU AV RESOLVTIT ',YCARCOU(1:LEN_TRIM(YCARCOU))
+ endif
+ CALL RESOLV_TIT('CTITT1',YCARCOU)
+ if(nverbia > 0)then
+ print *,' IMCOU AP RESOLVTIT '
+ endif
+ ZXPOSTITT1=.002
+ ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+ IF(YCARCOU /= ' ')THEN
+ IF(LSUPER)THEN
+ SELECT CASE(CTYPE)
+ CASE ('CART','MASK')
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,.009,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,.009,0.,-1.)
+ ENDIF
+ CASE DEFAULT
+ END SELECT
+ ELSE
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,.012,0.,-1.)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ENDIF ! Fin .NOT.LPVT
+
+ IF(.NOT.LPVT .AND..NOT.LPXT .AND..NOT.LPYT)THEN
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ ENDIF
+
+ENDIF ! Fin .NOT.SUPER .OR. (LSUPER ...
+!!!!!!!Fin Titres pour NSUPER = 1!!!!!!!!!!!!!!!!!!!
+
+IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN
+
+ IF(NLOOPSUPER == 1)THEN
+ CALL RESOLV_TIT('CTITVAR1',HTEXT)
+ ELSE IF(NLOOPSUPER == 2)THEN
+ CALL RESOLV_TIT('CTITVAR2',HTEXT)
+ ELSE IF(NLOOPSUPER == 3)THEN
+ CALL RESOLV_TIT('CTITVAR3',HTEXT)
+ ELSE IF(NLOOPSUPER == 4)THEN
+ CALL RESOLV_TIT('CTITVAR4',HTEXT)
+ ELSE IF(NLOOPSUPER == 5)THEN
+ CALL RESOLV_TIT('CTITVAR5',HTEXT)
+ ELSE IF(NLOOPSUPER == 6)THEN
+ CALL RESOLV_TIT('CTITVAR6',HTEXT)
+ ELSE IF(NLOOPSUPER == 7)THEN
+ CALL RESOLV_TIT('CTITVAR7',HTEXT)
+ ELSE IF(NLOOPSUPER == 8)THEN
+ CALL RESOLV_TIT('CTITVAR8',HTEXT)
+ ENDIF
+
+ if(nverbia > 0)then
+ print *,' ** IMCOU HTEXT LENTRIM(HTEXT) ',LEN_TRIM(HTEXT),' ',&
+ HTEXT(1:LEN_TRIM(HTEXT)),' NLOOPSUPER ',NLOOPSUPER,' NSUPER ',NSUPER,&
+ ' NSUPERDIA ',NSUPERDIA
+ print *,' XSZTITVAR1 ',XSZTITVAR1
+ endif
+ IF(HTEXT /= ' ')THEN
+ ZSC=.009
+ IF(XSZTITVAR1 /= 0. .AND. NLOOPSUPER == 1)ZSC=XSZTITVAR1
+ IF(XSZTITVAR2 /= 0. .AND. NLOOPSUPER == 2)ZSC=XSZTITVAR2
+ IF(XSZTITVAR3 /= 0. .AND. NLOOPSUPER == 3)ZSC=XSZTITVAR3
+ IF(XSZTITVAR4 /= 0. .AND. NLOOPSUPER == 4)ZSC=XSZTITVAR4
+ IF(XSZTITVAR5 /= 0. .AND. NLOOPSUPER == 5)ZSC=XSZTITVAR5
+ IF(XSZTITVAR6 /= 0. .AND. NLOOPSUPER == 6)ZSC=XSZTITVAR6
+ IF(XSZTITVAR7 /= 0. .AND. NLOOPSUPER == 7)ZSC=XSZTITVAR7
+ IF(XSZTITVAR8 /= 0. .AND. NLOOPSUPER == 8)ZSC=XSZTITVAR8
+ if(nverbia > 0)then
+ print *,' ZSC ',ZSC
+ endif
+ CALL PLCHHQ(MAX(ZVR,.99),0.007,HTEXT,ZSC,0.,+1.)
+ ENDIF
+
+ IF(LMINMAX)THEN
+ CALL PCSETC('FC','/')
+ IF(NSUPERDIA == 1)THEN
+ CAll PLCHHQ(ZVR,ZVT+.03,YLBL,.011,0.,+1.)
+ ELSE
+ CAll PLCHHQ(.98,ZVT+.01+(NSUPER-1)*.02,YLBL,.007,0.,+1.)
+ ENDIF
+ CALL PCSETC('FC',':')
+ ENDIF
+
+ELSE
+
+ SELECT CASE(CTYPE)
+ CASE('SSOL','DRST','RSPL','RAPL')
+ if(nverbia > 0)then
+ print *,' ** IMCOU AP CASE SSOL INDISTM ... ',INDISTM
+ endif
+ WRITE(YTEX(1:4),'(I4)')NLOOPN
+ YTEX(1+5:LEN_TRIM(HTEXT)+5)=HTEXT(1:LEN_TRIM(HTEXT))
+ YTEX=ADJUSTL(ADJUSTR(YTEX))
+ IF(NSUPER > 1)THEN
+ ISTOK=0
+ DO JB=1,INDISTM
+ IF(NLOOPN == ISTM(JB))THEN
+ ISTOK=1
+ ENDIF
+ ENDDO
+ IF(ISTOK == 1)THEN
+ ELSE
+ INDISTM=INDISTM+1
+ ISTM(INDISTM)=NLOOPN
+ IF(CTYPE == 'SSOL')THEN
+ IF(ISUIT > 50)THEN
+ WRITE(YCAR(ISUI:ISUI+3),'(I4)')NLOOPN
+ YCAR(ISUI+4:ISUI+6)=' ('
+ WRITE(YCAR(ISUI+7:ISUI+11),'(F5.0)')XTRAJX(1,1,NLOOPN)
+ ISUI=ISUI+12
+ YCAR(ISUI:ISUI)=','
+ ISUI=ISUI+1
+ WRITE(YCAR(ISUI:ISUI+4),'(F5.0)')XTRAJY(1,1,NLOOPN)
+ ISUI=ISUI+5
+ YCAR(ISUI:ISUI+2)=') '
+ ISUI=ISUI+3
+ ELSE
+ WRITE(YCARCOU(ISUIT:ISUIT+3),'(I4)')NLOOPN
+ YCARCOU(ISUIT+4:ISUIT+6)=' ('
+ WRITE(YCARCOU(ISUIT+7:ISUIT+11),'(F5.0)')XTRAJX(1,1,NLOOPN)
+ ISUIT=ISUIT+12
+ YCARCOU(ISUIT:ISUIT)=','
+ ISUIT=ISUIT+1
+ WRITE(YCARCOU(ISUIT:ISUIT+4),'(F5.0)')XTRAJY(1,1,NLOOPN)
+ ISUIT=ISUIT+5
+ YCARCOU(ISUIT:ISUIT+2)=') '
+ ISUIT=ISUIT+3
+ ENDIF
+ ELSE
+ WRITE(YCARCOU(ISUIT:ISUIT+4),'(I5)')NLOOPN
+ ISUIT=ISUIT+5
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(NSUPER == NSUPERDIA)THEN
+ CALL RESOLV_TIT('CTITT1',YCARCOU)
+ ZXPOSTITT1=.002
+ ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+ IF(YCARCOU /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,.009,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,.009,0.,-1.)
+ ENDIF
+ CALL RESOLV_TIT('CTITT2',YCAR)
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.95
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+ IF(YCAR /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCAR,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YCAR,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCAR,.009,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YCAR,.009,0.,-1.)
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(ALLOCATED(ISTM))THEN
+ DEALLOCATE(ISTM)
+ ENDIF
+ ENDIF
+ CASE DEFAULT
+ YTEX=ADJUSTL(HTEXT)
+ END SELECT
+
+ IF(NLOOPSUPER == 1)THEN
+ CALL RESOLV_TIT('CTITVAR1',YTEX)
+ ELSE IF(NLOOPSUPER == 2)THEN
+ CALL RESOLV_TIT('CTITVAR2',YTEX)
+ ELSE IF(NLOOPSUPER == 3)THEN
+ CALL RESOLV_TIT('CTITVAR3',YTEX)
+ ELSE IF(NLOOPSUPER == 4)THEN
+ CALL RESOLV_TIT('CTITVAR4',YTEX)
+ ELSE IF(NLOOPSUPER == 5)THEN
+ CALL RESOLV_TIT('CTITVAR5',YTEX)
+ ELSE IF(NLOOPSUPER == 6)THEN
+ CALL RESOLV_TIT('CTITVAR6',YTEX)
+ ELSE IF(NLOOPSUPER == 7)THEN
+ CALL RESOLV_TIT('CTITVAR7',YTEX)
+ ELSE IF(NLOOPSUPER == 8)THEN
+ CALL RESOLV_TIT('CTITVAR8',YTEX)
+ ENDIF
+
+ IF(YTEX /= ' ')THEN !************************************************
+
+ IF(LEN_TRIM(YTEX) > 25)THEN
+ IF(NSUPERDIA >= 2 .AND. (LHACH2.OR.LHACH3))THEN
+ CALL PLCHHQ(0.1+(NSUPER-2)*.24,ZVT+0.05,YTEX(1:LEN_TRIM(YTEX)),.005,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.1+(NSUPER-2)*.24,ZVT+0.03,YTEX(1:LEN_TRIM(YTEX)),.005,0.,-1.)
+ ENDIF
+ ELSE
+ IF(NSUPERDIA >= 2 .AND. (LHACH2.OR.LHACH3))THEN
+ CALL PLCHHQ(0.1+(NSUPER-2)*.24,ZVT+0.05,YTEX(1:LEN_TRIM(YTEX)),.005,0.,-1.)
+ ELSE
+! CALL PLCHHQ(0.1+(NSUPER-1)*.24,ZVT+0.03,HTEXT,.007,0.,-1.)
+ CALL PLCHHQ(0.1+(NSUPER-2)*.24,ZVT+0.03,YTEX(1:LEN_TRIM(YTEX)),.007,0.,-1.)
+ ENDIF
+ ENDIF
+! CALL PLCHHQ(0.1+(NSUPER-1)*.24,ZVT+0.03,HTEXT,.009,0.,-1.)
+
+ IF(.NOT.LPVT)THEN
+ IF(NSUPERDIA >= 2 .AND. (LHACH2.OR.LHACH3))THEN
+ ELSE
+ CALL PLCHHQ(0.1+(NSUPER-2)*.24,ZVT+0.01,ADJUSTL(CTIMEC(8:15))//'s',.007,0.,-1.)
+ ENDIF
+ ENDIF
+
+ ENDIF !**********************************************************
+ IF(LMINMAX)THEN
+ IF(LPLUS .OR. LMINUS)THEN
+ CALL PCSETC('FC','/')
+ CAll PLCHHQ(ZVR,ZVT+.03,YLBL(1:LEN_TRIM(YLBL)),.009,0.,+1.)
+! CAll PLCHHQ(0.68,ZVT+.03,YLBL,.009,0.,-1.)
+ CALL PCSETC('FC',':')
+ ELSE
+ CALL PCSETC('FC','/')
+! CAll PLCHHQ(0.1+(NSUPER-1)*.24,ZVT+.01,YLBL,.007,0.,-1.)
+ CAll PLCHHQ(.98,ZVT+.01+(NSUPER-1)*.02,YLBL,.007,0.,+1.)
+ CALL PCSETC('FC',':')
+ ENDIF
+ ENDIF
+
+END IF
+!
+CALL SETUSV('MI',IMI)
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+CALL GSCLIP(1)
+CALL GSLN(1)
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+!
+!* 2.14 Heading formats
+!
+1000 FORMAT('Vertical section IDEB=',I4,' JDEB=',I4,' ANG.=',I3,' NBPTS=',I4)
+1001 FORMAT('Vertical section XDEB=',F6.0,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I4)
+1002 FORMAT('Vertical section XDEB=',F6.0,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1003 FORMAT('Vertical section XDEB=',E7.2,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I4)
+1004 FORMAT('Vertical section XDEB=',E6.2,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1010 FORMAT('Vertical section IDEB=',I4,' JDEB=',I4,' ANG.=',I3,' IPRO=',I4)
+1011 FORMAT('Vertical section XDEB=',F6.0,' YDEB=',F6.0,' ANG.=',I3,' IPRO=',I4)
+1012 FORMAT('Vertical profile (1D)')
+1013 FORMAT('Vertical section XDEB=',F6.0,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1014 FORMAT('Vertical section XDEB=',E7.2,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I4)
+1015 FORMAT('Vertical section XDEB=',E6.2,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1016 FORMAT('Horiz. profile NIINF=',I5,' NISUP=',I5)
+1017 FORMAT('Horiz. profile NJINF=',I5,' NJSUP=',I5)
+1018 FORMAT('Vertical section IND I,J (BEGIN)-(END)=(',I4,',',I4,')-(',I4,',',I4,')')
+1019 FORMAT('Vertical section LAT,LON (BEGIN)-(END)=(',F5.1,',',F5.1,')-(',F5.1,',',F5.1,')')
+1020 FORMAT('Vertical section CONF. COORD.(BEGIN)-(END)=(',F8.0,',',F8.0,')-(',F8.0,',',F8.0,')')
+1021 FORMAT('Vertical profile LAT,LON =(',F5.1,',',F5.1,')')
+1022 FORMAT('Vertical profile CONF. COORD.=(',F8.0,',',F8.0,')')
+1023 FORMAT('Vertical profile IND I,J =(',I4,',',I4,')')
+1024 FORMAT('Profile =',I4)
+!
+!-----------------------------------------------------------------------------
+!
+!* 3. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE IMCOU_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/imcoupv_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/imcoupv_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0f2b736c9e336f2abe5ffad8bf69b5545c6b876b
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/imcoupv_fordiachro.f90
@@ -0,0 +1,1573 @@
+! ######spl
+ SUBROUTINE IMCOUPV_FORDIACHRO(PU,PW,HLEGEND,HTEXT)
+! #################################################
+!
+!!**** *IMCOUPV_FORDIACHRO* - Draws a vector arrow plot for a vertical cross-section
+!!
+!! PURPOSE
+!! -------
+! Draws an arrow plot of a UW vector field re-colocated at the
+! mass gridpoint for a vertical cross-section
+!
+!!** METHOD
+!! ------
+!!
+!! Assumption is made that wind components were re-colocated onto the mass
+!! gridpoint location prior to calling IMCOUPV.
+!! The wind arrows are plotted using the VVECTR NCAR utility.
+!!
+!! Notice that a TRACE-provided VVUMXY routine is used within the NCAR
+!! vector VVECTR utility to map the wind vectors onto the stretched
+!! MESO-NH model space. Wind vectors are given in m/s and scaled by VVUMXY
+!! to obtain arrow sizes in "NCAR fractional coordinate" (NCAR User Guide
+!! "Fundamentals", Appendix A, p345 section 1), notice this is different
+!! from what is required for Conpack... The final result is an automatic
+!! arrow scale selection on the plot.
+!! If a different procedure has to be followed VVUMXY should
+!! be updated accordingly. The parameters of the NCAR VVECTR utility can
+!! be printed online by typing "man vectors_params", these feature are not
+!! really documented elsewhere in NCAR user guide.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! GSCLIP : clips items getting out of the drawing window !
+!! GETSET : retrieves the normalized and user NCAR !
+!! coordinates of a previously used window !
+!! PLCHHQ : prints high-quality character strings !
+!! !
+!! VVSETR ! : gets the value of a NCAR parameter, REEL !
+!! VVSETI ! INTEGER !
+!! VVINIT : initialize a vector plot (arrows) !
+!! VVECTR : draws the arrows for a vector plot !
+!! !
+!! GSLWSC : sets line width !
+!! VVRSET : resets VVECTR parameters to default values !
+!!
+!!
+!! VVUMXY : TRACE provided FORTRAN-77 routine directly called
+!! within the VVECTR NCAR utility to to map the wind
+!! vectors onto the stretched MESO-NH model space.
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_TITLE : Declares heading variables for the plots (TRACE)
+!! CLEGEND: Current plot heading title
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX,XXY : coordinate values for all the MESO-NH grids
+!! XXZS : topography values for all the MESO_NH grids
+!!
+!! Module MODD_CONF : declares configuration variables of all models
+!! LCARTESIAN: Logical for cartesian geometry :
+!! .TRUE. = cartesian geometry
+!! .FALSE. = conformal projection
+!!
+!! Module MODN_PARA : defines NAM_DOMAIN_POS namelist
+!! LHORIZ : must be .FALSE. to perform vertical cross esctions
+!! LVERTI : must be .TRUE. to perform vertical cross sections
+!! Module MODD_DIM1 : Contains dimensions
+!! NIMAX, NJMAX : x, and y array dimensions
+!! NIINF, NISUP : Lower and upper array bounds in x direction
+!! NJINF, NJSUP : Lower bound and upper bound in y direction
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!! XSPVAL : Special value
+!! NISKIP : Sampling rate for drawing velocity vectors
+!!
+!! Module MODD_OUT : Defines a log. unit for printing
+!! NIMAXT : x-size of the displayed section of the model array
+!! NJMAXT : y-size of the displayed section of the model array
+!!
+!! Module MODD_TIME ! To be checked, useless..
+!! Module MODD_TIME1 ! To be checked, useless.
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 19/09/95
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_COORD
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_PARAMETERS
+USE MODD_NMGRID
+USE MODD_GRID
+USE MODD_GRID1
+USE MODD_FIELD1_CV2D
+USE MODD_SUPER
+USE MODD_TITLE
+USE MODD_OUT
+USE MODN_PARA
+USE MODN_NCAR
+USE MODD_LUNIT1
+USE MODD_CVERT
+USE MODD_PVT
+USE MODD_TYPE_AND_LH
+USE MODD_CTL_AXES_AND_STYL
+USE MODD_RESOLVCAR
+USE MODD_TIT
+USE MODD_DEFCV
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODE_GRIDPROJ
+USE MODI_RESOLV_TIT
+USE MODI_RESOLV_TITY
+!
+IMPLICIT NONE
+!
+!* 0.0 TRACE interface with the "VVUMXY" routine of the NCAR package
+!
+! NOTICE: The TRACE provided VVUMXY routine and the NCAR graphical utilities
+! ------ are NOT written in Fortran 90, but in Fortran 77.. This sub-section
+! of TRACE does not follow the Meso-NH usual rules: it has to be made
+! using a COMMON stack with static memory allocation of XZWORKZ and
+! XZZDS arrays.
+!
+!
+INTERFACE
+
+SUBROUTINE GENFORMAT_FORDIACHRO(PCLV,HLLBS)
+REAL :: PCLV
+CHARACTER(LEN=*) :: HLLBS
+END SUBROUTINE
+!
+END INTERFACE
+!
+COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+COMMON/TEMV/XZWORKZ,XZZDS,NINX,NINY
+#include "big.h"
+REAL,DIMENSION(N2DVERTX,2500):: XZWORKZ
+!REAL,DIMENSION(1000,400):: XZWORKZ
+!REAL,DIMENSION(200,200) :: XZWORKZ
+REAL,DIMENSION(N2DVERTX):: XZZDS
+!REAL,DIMENSION(1000):: XZZDS
+!REAL,DIMENSION(200) :: XZZDS
+INTEGER :: NINX, NINY
+LOGICAL :: LVERT, LHOR, LPT, LXABS
+!
+!* 0.1 NCAR work arrays
+!
+! See aforementioned notice. The dimensions of these arrays are
+! subject to possible tuning, but have to be prescribed. Add
+! extra size if necessary.
+!
+INTEGER,PARAMETER :: JPRSCR=50000, JPISCR=50000
+
+REAL,DIMENSION(JPRSCR):: ZRSCR
+INTEGER,DIMENSION(JPISCR):: ISCR
+!
+!* 0.2 Dummy arguments and results
+!
+REAL,DIMENSION(:,:) :: PU, PW
+CHARACTER(LEN=*) :: HTEXT ! Plot heading containing field name
+CHARACTER(LEN=*) :: HLEGEND
+!
+!* 0.3 Local variables
+!
+INTEGER :: JLOOPI, JLOOPJ, ILOOP, INUM, IRESP,IDEB,IFIN
+INTEGER :: JILOOP, JKLOOP, ID, J
+INTEGER :: IKB, IKE, IKU
+INTEGER :: IKL, ILMAX, JLMAX
+INTEGER :: ILENYC, ILENHT
+INTEGER :: INBCOL, IIBID
+INTEGER :: JA, JILOOPD, JILOOPF
+INTEGER :: JJ, IJ, II, IUB1, IUB2, ITER, JTER
+INTEGER :: ISKIPX, ISKIPY, ITERM, ISKIPXM
+INTEGER,DIMENSION(:),ALLOCATABLE :: ICOL
+!
+REAL,DIMENSION(SIZE(PU,2),SIZE(PU,1)) :: ZZU, ZZV
+REAL :: ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+REAL :: ZY, ZJ, ZH, ZJJ, ZWBB
+REAL :: ZDMX, ZVMX
+REAL :: ZRAP
+REAL :: ZXPOSTITT1, ZXYPOSTITT1
+REAL :: ZXPOSTITT2, ZXYPOSTITT2
+REAL :: ZXPOSTITT3, ZXYPOSTITT3
+REAL :: ZXPOSTITB1, ZXYPOSTITB1
+REAL :: ZXPOSTITB2, ZXYPOSTITB2
+REAL :: ZXPOSTITB3, ZXYPOSTITB3
+REAL,DIMENSION(1000) :: ZYY
+REAL :: ZW,ZM,ZUMN,ZWMN,ZMN,ZWMX,ZMX
+REAL,DIMENSION(:),ALLOCATABLE :: ZPARCOLUV
+REAL :: ZTEM, ZINT, ZRPK, ZLON0, ZBETA
+REAL :: ZVINT, ZVY, ZINTX, ZINTY
+REAL,DIMENSION(:,:),ALLOCATABLE :: ZX, ZLAT, ZLON, ZZY,ZZYY
+CHARACTER(LEN=4) :: YTE
+REAL,DIMENSION(:,:),ALLOCATABLE :: ZDIRU, ZDIRV, ZLA, ZLO
+REAL,DIMENSION(:),ALLOCATABLE :: ZZDS
+REAL,DIMENSION(18) :: ZCOL
+
+CHARACTER(LEN=82) :: YCARCOU, YTEM
+CHARACTER(LEN=80) :: YCAR
+CHARACTER(LEN=40) :: YLBL
+CHARACTER(LEN=40) :: YTIT
+CHARACTER(LEN=8),DIMENSION(:),ALLOCATABLE :: YLBS
+CHARACTER(LEN=8) :: YLBSTEM
+CHARACTER(LEN=2) :: YC2
+CHARACTER(LEN=3) :: YC3
+CHARACTER(LEN=4) :: YC4
+CHARACTER(LEN=10) :: YLBLMN,YLBLMX
+CHARACTER(LEN=10) :: FORMAX, FORMAY
+!
+!* 0.4 External for NCAR use
+!
+! SFILL subroutine declared as external provides area control
+! in some parts of the contour plot.
+!
+!EXTERNAL SFILL
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DISPLAY ENVIRONMENT SETUP AND ARROWS PLOTTING
+! ---------------------------------------------
+!
+!* 1.1 Array sizes calculation and default field value
+!
+!
+IKU=NKMAX+2*JPVEXT
+IKB=1+JPVEXT
+IKE=IKU-JPVEXT
+
+!!!! ATTENTION En entree ICI,PU (U) et PW (V ICI) ont comme 1ere dimension
+!!!! Z (1:IKU) et comme 2eme le temps (qui au trace sera en X) -> besoin
+!!!! de retablir l'ordre habituel : (Tps,Z) ce qui est fait ds ZZU et ZZV
+
+ILMAX=SIZE(PU,2)
+JLMAX=SIZE(PU,1)
+if(nverbia > 0)then
+print *, ' ENTREE imcoupv ',ILMAX,JLMAX
+endif
+
+ZZU=XSPVAL
+ZZV=XSPVAL
+
+! Janvier 2001
+!IF(.NOT.LUMVMPV)THEN
+
+ DO JKLOOP=1,JLMAX
+ DO JILOOP=1,ILMAX
+ ZZU(JILOOP,JKLOOP)=PU(JKLOOP,JILOOP)
+ ZZV(JILOOP,JKLOOP)=PW(JKLOOP,JILOOP)
+ ENDDO
+ ENDDO
+
+!ELSE
+
+! Janvier 2001
+! DO JKLOOP=1,JLMAX,NISKIPVY
+! DO JILOOP=1,ILMAX,NISKIPVX
+! ZZU(JILOOP,JKLOOP)=PU(JKLOOP,JILOOP)
+! ZZV(JILOOP,JKLOOP)=PW(JKLOOP,JILOOP)
+! ENDDO
+! ENDDO
+
+! Janvier 2001
+!ENDIF
+! Janvier 2001
+!
+!
+!* 1.2 Collects X and Z values
+!
+!* 1.3 Window definition and plot
+!
+
+LVERTI=.TRUE. ; LHORIZ=.FALSE.
+LVERT=LVERTI
+LHOR=LHORIZ
+
+CALL GSCLIP(0)
+
+CALL GSLN(1)
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+
+!IF(LSUPER)THEN
+! NSUPER=NSUPER+1
+! IF(NSUPER == 1)THEN
+! CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+! ELSE
+! CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+! END IF
+!ELSE
+! CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+!ENDIF
+
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+
+!!!!!!!!!!!!!!!
+FORMAX=' '
+IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ELSE
+ FORMAX='(F8.1)'
+ENDIF
+
+FORMAY=' '
+IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ELSE
+ FORMAY='(F7.0)'
+ENDIF
+!!!!!!!OCt 2001
+!IF(ZWL == ZWR)ZWR=ZWL*2
+!!!!!!!OCt 2001
+
+IF(LHEURX)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL/3600.,ZWR/3600.,ZWB,ZWT,ID)
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+
+!!!!!!!Avril 2002
+ IF(LMYHEURX)THEN
+ ZH=NHEURXGRAD*3600.
+ ELSE
+!!!!!!!Avril 2002
+ IF((ZWR-ZWL)/3600. > 24.)THEN
+ ZH=10800.
+ ELSE
+ ZH=3600.
+ ENDIF
+!!!!!!!Avril 2002
+ ENDIF
+!!!!!!!Avril 2002
+
+ELSE
+
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+ENDIF
+!!!!!!!!!!!!!!!
+
+! Utilisation de PLCHHQ pour ecriture des labels (sinon 0= WTSTR)
+CALL GASETI('LTY',1)
+
+IF(.NOT.LHEURX)THEN
+! Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,0,0,5,0.,0)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,0,1,5,0.,0)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,1,0,5,0.,0)
+ ELSE
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,1,1,5,0.,0)
+ ENDIF
+! Avril 2002
+ENDIF
+
+!!!!!!!!!!!!!!!
+IF(LHEURX)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ DO J=INT(ZWL),INT(ZWR)
+ ZJ=J
+
+ IF(MOD(ZJ,ZH) == 0.)THEN
+ CALL FRSTPT(ZJ,ZWB)
+ CALL VECTOR(ZJ,ZWB+(ZWT-ZWB)/90.)
+
+!!!!!!!Avril 2002
+ IF(LMYHEURX)THEN
+ ZJJ=ZJ/ZH*NHEURXGRAD
+ ZINT=NHEURXLBL
+ ELSE
+!!!!!!!Avril 2002
+ IF(ZH == 10800.)THEN
+ ZJJ=ZJ/ZH*3.
+ ZINT=6.
+ ELSE
+ ZJJ=ZJ/ZH
+ ZINT=3.
+ ENDIF
+
+!!!!!!!Avril 2002
+ ENDIF
+!!!!!!!Avril 2002
+ ZWBB=ZWB-((ZWT-ZWB)/((ZVT-ZVB)/.02))
+
+ IF(.NOT. LNOLABELX)THEN
+ IF(MOD(ZJJ,ZINT) == 0.)THEN
+ IF(ZJJ <10.)THEN
+ WRITE(YC2,'(F2.0)')ZJJ
+ CALL PLCHHQ(ZJ,ZWBB,YC2,.010,0.,0.)
+ ELSEIF(ZJJ <100.)THEN
+ WRITE(YC3,'(F3.0)')ZJJ
+ CALL PLCHHQ(ZJ,ZWBB,YC3,.010,0.,0.)
+ ELSE
+ WRITE(YC4,'(F4.0)')ZJJ
+ CALL PLCHHQ(ZJ,ZWBB,YC4,.010,0.,0.)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ENDIF
+ ENDDO
+! CALL GRIDAL(1,0,NCVITVYMJ,NCVITVYMN,1,1,5,0.,0)
+! Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(0,0,NCVITVYMJ,NCVITVYMN,0,0,5,0.,0)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(0,0,NCVITVYMJ,NCVITVYMN,0,1,5,0.,0)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(0,0,NCVITVYMJ,NCVITVYMN,0,0,5,0.,0)
+ ELSE
+ CALL GRIDAL(0,0,NCVITVYMJ,NCVITVYMN,0,1,5,0.,0)
+ ENDIF
+! Avril 2002
+ENDIF
+!!!!!!!!!!!!!!!
+
+! Janvier 2001
+!!! Partie commune de LPRINT
+IF(LPRINT)THEN
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ ILOOP=SIZE(ZZU,1)/5
+ IF(ILOOP * 5 < SIZE(ZZU,1))ILOOP=ILOOP+1
+
+ IF(.NOT.LPVT)THEN
+ WRITE(INUM,'(''PV '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'','' (1-1,1-IKU)'')')CGROUP,&
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ ELSE
+ IUB1=SIZE(ZZU,1)
+ WRITE(INUM,'(''PV '',''G:'',A16,'' P:'',A25,'' TD-TF:'',F8.0,''-'',F8.0,''s'')')CGROUP,&
+ CTITRE(NLOOPP)(1:25),XZZDS(1),XZZDS(IUB1)
+ WRITE(INUM,'('' (1-NBTIME,1-IKU)'')')
+ ENDIF
+
+ IF(LMINUS .OR. LPLUS)THEN
+ WRITE(INUM,'(A70)')CTITB3
+ ELSE
+! WRITE(INUM,'(A40)')CTITGAL
+ ENDIF
+
+ IF(LUMVMPV)THEN
+ WRITE(INUM,'(''I='',I4,''J='',I4)')&
+ NIL,NJL
+ ELSE
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2)THEN
+ WRITE(INUM,'(''cc(deb)-(fin)=('',F8.0,'','',F8.0,'')-('',F8.0,'','',F8.0,'')'','' nlmax'',i5,&
+ &'' profile='',I4)')&
+ &XIDEBCV,XJDEBCV,XIFINCV,XJFINCV,NLMAX,NPROFILE
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(INUM,'(''ll(deb)-(fin)=('',F8.3,'','',F8.3,'')-('',F8.3,'','',F8.3,'')'','' nlmax'',i5,&
+ &'' profile='',I4)')&
+ &XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL,NLMAX,NPROFILE
+ ELSE IF(LDEFCV2IND)THEN
+ WRITE(INUM,'(''ij(deb)-(fin)=('',I4,'','',I4,'')-('',I4,'','',I4,'')'','' nlmax'',i5,&
+ &'' profile='',i4)')&
+ &NIDEBCV,NJDEBCV,NIFINCV,NJFINCV,NLMAX,NPROFILE
+ ENDIF
+ ELSE
+ IF(XIDEBCOU /= -999.)THEN
+ WRITE(INUM,'(''xidebcou'',F8.0,'' xjdebcou'',F8.0,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' profile='',i4)')&
+ &XIDEBCOU,XJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ELSE
+ WRITE(INUM,'(''nidebcou'',i4,'' njdebcou'',i4,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' profile='',i4)')&
+ &NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ENDIF
+ ENDIF
+! WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ENDIF
+
+ WRITE(INUM,'(''NBVAL en I (TIME): '',i4, &
+& '' NBVAL en K (Z)'',i4,'' iter'',i3)') &
+ & SIZE(ZZU,1),SIZE(ZZU,2),ILOOP
+ !%%%%%%%%%%%%%%%%%%%%%%%%%
+! JUin 2001 Ecriture des dates (Demande G.Jaubert ) si LPRDAT=T
+ IF(LPRDAT)THEN
+ IF(.NOT.ALLOCATED(XPRDAT))THEN
+ print *,'**IMCOUPV XPRDAT NON ALLOUE.Dates non ecrites ds FICVAL .Prevenir J.Duron'
+ ELSE
+ WRITE(INUM,'(1X,75(1H*))')
+ WRITE(INUM,'(1X,'' Dates courante * modele * experience * segment'')')
+ WRITE(INUM,'(1X,'' J An M J Sec. * An M J Sec. * An M J Sec. * An M J Sec.'')')
+ WRITE(INUM,'(1X,75(1H*))')
+ DO J=1,SIZE(XPRDAT,2)
+ WRITE(INUM,'(1X,I3,1X,3(I4,I3,I3,I6,'' *''),I4,I3,I3,I6)')J,INT(XPRDAT(:,J))
+ ENDDO
+ ENDIF
+ ENDIF
+! JUin 2001 Ecriture des dates
+ENDIF
+
+!!!! Janvier 2001 + LDIRWIND
+IF(LDIRWIND)THEN
+ if(nverbia > 0)then
+ print *,' imcoupv LDIRWIND ',LDIRWIND
+ endif
+ ISKIPX=NISKIPVX
+ ISKIPY=NISKIPVY
+ IUB1=SIZE(ZZU,1)
+!!30/01/01
+! ITER=IUB1/ISKIPX+1
+! IF(1+(ITER-1)*ISKIPX > IUB1)ITER=ITER-1
+ ITERM=IUB1/ISKIPX+1
+ IF(1+(ITERM-1)*ISKIPX > IUB1)ITERM=ITERM-1
+ ITER=IUB1
+ ISKIPXM=ISKIPX
+ ISKIPX=1
+!!30/01/01
+ IUB2=SIZE(ZZU,2)
+! 130101
+!!! Essai de conservation de 1 a IKU en Y (pour LPRINT) mais
+!!! de 1 a ITER en X
+!!! JTER=(IUB2-IKB)/ISKIPY+1
+!!! IF(IKB+(JTER-1)*ISKIPY > IUB2)JTER=JTER-1
+ JTER=IUB2
+!!!
+ ALLOCATE(ZX(ITER,1),ZZY(ITER,JTER),ZZYY(ITER,1),ZLAT(ITER,1),ZLON(ITER,1))
+ ALLOCATE(ZLA(ITER,JTER),ZLO(ITER,JTER),ZDIRU(ITER,JTER),ZDIRV(ITER,JTER))
+ ALLOCATE(ZZDS(ITER))
+! 130101
+! print *,' IIIIIMCOUPV IUB1, ISKIPX, ITER, IUB2, ISKIPY, JTER,LPV ',IUB1,ISKIPX,ITER,IUB2,ISKIPY,JTER,LPV
+
+!!!
+ ZDIRU=XSPVAL
+ ZDIRV=XSPVAL
+!!! ZDIRU=ZZU(1:IUB1:ISKIPX,IKB:IUB2:ISKIPY)
+!!! ZDIRV=ZZV(1:IUB1:ISKIPX,IKB:IUB2:ISKIPY)
+ ZDIRU=ZZU(1:IUB1:ISKIPX,1:IUB2:1)
+ ZDIRV=ZZV(1:IUB1:ISKIPX,1:IUB2:1)
+!!!
+ if(nverbia > 0)then
+ print *,' ZDIRU AP CHARG. ZZU'
+ print *,ZDIRU
+ print *,' ZDIRV AP CHARG. ZZV'
+ print *,ZDIRV
+ endif
+
+! Chargement des temps ICI .
+ ZZDS=XTDIRWIND(1:IUB1:ISKIPX)
+! print *,' IIIIIMCOUPV XDSX(1:IUB1) ',XDSX(1:IUB1,1)
+! print *,' IIIIIMCOUPV ZX(:,1) ',ZX(:,1)
+! 130101
+ JJ=0
+!!!
+!!! DO JKLOOP=IKB,IUB2,ISKIPY
+ DO JKLOOP=1,IUB2
+!!!
+ JJ=JJ+1
+ II=0
+ DO JILOOP=1,IUB1,ISKIPX
+ II=II+1
+ ZZY(II,JJ)=XZWORKZ(JILOOP,JKLOOP)
+ ENDDO
+ ENDDO
+
+! 130101
+! print *,' IIIIMCOUPV IUB1,ISKIPX,IKB,IUB2,ISKIPY ',IUB1,ISKIPX,IKB,IUB2
+! print *,' IIIIMCOUPV XZWORKZ(1:NLMAX,IKB) ',XZWORKZ(1:NLMAX,IKB)
+! print *,' IIIIMCOUPV ZZY(:,1) ',ZZY(:,1)
+! print *,' IIIIMCOUPV XZWORKZ(1:NLMAX,IKB+1) ',XZWORKZ(1:NLMAX,IKB+1)
+! print *,' IIIIMCOUPV ZZY(:,2) ',ZZY(:,2)
+
+! 130101
+ ZX(:,1)=XDSX(1,1)
+ ZZYY(:,1)=XDSY(1,1)
+
+ IF(ALLOCATED(ICOL))THEN
+ DEALLOCATE(ICOL)
+ ENDIF
+ ALLOCATE(ICOL(18))
+
+ DO JKLOOP=1,JTER
+ CALL SM_LATLON_A(XLATORI,XLONORI,ZX,ZZYY,ZLAT,ZLON)
+ ZLA(:,JKLOOP)=ZLAT(:,1)
+ ZLO(:,JKLOOP)=ZLON(:,1)
+ ENDDO
+
+ where(zdiru /= xspval .AND. zdirv /= xspval)
+ ZDIRU=ATAN2(ZDIRV,ZDIRU)*180./ACOS(-1.)
+ endwhere
+
+ if(nverbia > 0)then
+ print *,' ZDIRU AP ATAN2 '
+ print *,ZDIRU
+ print *,' ZDIRU 1,1 ITER/2,1 1,JTER/2 ITER/2,JTER/2 ITER,JTER '
+ print *,ZDIRU(1,1), ZDIRU(ITER/2,1), ZDIRU(1,JTER/2), ZDIRU(ITER/2,JTER/2), &
+ ZDIRU(ITER,JTER)
+ endif
+
+ ZRPK=XRPK
+ ZBETA=XBETA
+ ZLON0=XLON0
+ where(zdiru /= xspval .AND. zdirv /= xspval)
+ ZDIRU=ZDIRU - (ZRPK*(ZLO-ZLON0)-ZBETA) + 90.
+ endwhere
+ WHERE(ZDIRU < 0.)ZDIRU=ZDIRU+360.
+ WHERE(ZDIRU > 360. .AND. ZDIRU /= XSPVAL)ZDIRU=ZDIRU-360.
+
+ if(nverbia > 0)then
+ print *,' ZDIRU AP WHERE(ZDIRU < 0.'
+ print *,ZDIRU
+ print *,' ZDIRU 1,1 ITER/2,1 1,JTER/2 ITER/2,JTER/2 ITER,JTER '
+ print *,ZDIRU(1,1), ZDIRU(ITER/2,1), ZDIRU(1,JTER/2), ZDIRU(ITER/2,JTER/2), &
+ ZDIRU(ITER,JTER)
+ endif
+
+ where(zdiru /= xspval .AND. zdirv /= xspval)
+ ZDIRV=360.-ZDIRU
+ elsewhere
+ ZDIRV=XSPVAL
+ endwhere
+
+ if(nverbia > 0)then
+ print *,' ZDIRV 1,1 ITER/2,1 1,JTER/2 ITER/2,JTER/2 ITER,JTER '
+ print *,ZDIRV(1,1), ZDIRV(ITER/2,1), ZDIRV(1,JTER/2), ZDIRV(ITER/2,JTER/2), &
+ ZDIRV(ITER,JTER)
+ endif
+ if(nverbia > 0)then
+ print *,' AV LPRINT DIRWIND ZDIRU '
+ print *, ZDIRU
+ print *,' AV LPRINT DIRWIND ZDIRV '
+ print *, ZDIRV
+ endif
+
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+
+if(nverbia > 0)then
+ print *,' ** imcoupv ap getset ZWL,ZWR,XDS(1,1),XDS(NLMAX,1),ZX(1,1),ZX(ITER,1) ',ZWL,ZWR,XDS(1,1),XDS(NLMAX,1),ZX(1,1),ZX(ITER,1)
+endif
+!! 30/01/01
+ IF(ITERM > 6)THEN
+! IF(ITER > 6)THEN
+ CALL GSCLIP(1)
+ ELSE
+ CALL GSCLIP(0)
+ ENDIF
+
+ CALL TABCOL_FORDIACHRO
+
+ IJ=1
+ DO J=15,345,30
+ IJ=IJ+1
+ ZCOL(IJ)=J
+ ENDDO
+ ZCOL(1)=0.
+ IJ=IJ+1
+ ZCOL(IJ)=360.
+
+ ICOL(1)=4; ICOL(13)=4; ICOL(2)=88; ICOL(3)=79; ICOL(4)=7
+ ICOL(5)=52; ICOL(6)=25; ICOL(7)=2; ICOL(8)=20; ICOL(9)=24
+ ICOL(10)=3; ICOL(11)=124; ICOL(12)=5; ICOL(13)=4
+
+ IF(LPV)THEN
+ JILOOPD=NPROFILE
+ JILOOPF=NPROFILE
+ ELSE
+ JILOOPD=1
+ JILOOPF=ITER
+ ENDIF
+
+!!!
+!!! DO JKLOOP=1,JTER
+ DO JKLOOP=IKB,JTER,ISKIPY
+!!!
+!! 30/01/01
+ DO JILOOP=JILOOPD,JILOOPF,ISKIPXM
+! DO JILOOP=JILOOPD,JILOOPF
+!! 30/01/01
+ IF(ZDIRV(JILOOP,JKLOOP) == XSPVAL)THEN
+! print *,J,' CYCLE ',ZDIRV(JILOOP,JKLOOP),ZCOL(J),ZCOL(J-1)
+ CYCLE
+ ENDIF
+ DO J=2,IJ
+! print *,J,' ',ZDIRV(JILOOP,JKLOOP),ZCOL(J),ZCOL(J-1)
+
+ IF(ZDIRV(JILOOP,JKLOOP) == 0. .OR. ZDIRV(JILOOP,JKLOOP) == 360.)THEN
+ CALL GSPMCI(ICOL(1))
+! print *,' ZDIRV(JILOOP,JKLOOP) J+2 ',ZDIRV(JILOOP,JKLOOP),ICOL(1)
+ EXIT
+ ELSE IF(ZDIRV(JILOOP,JKLOOP) < ZCOL(J).AND. &
+ ZDIRV(JILOOP,JKLOOP) >= ZCOL(J-1))THEN
+ CALL GSPMCI(ICOL(J-1))
+! print *,' ZDIRV(JILOOP,JKLOOP) J+1 ',ZDIRV(JILOOP,JKLOOP),ICOL(J)
+ EXIT
+ ENDIF
+ ENDDO
+ CALL GSMK(2)
+
+!!! Janvier 2001
+ IF(LPV)THEN
+! ZINTX=(ZWL+ZWR)/2
+ ZINTX=ZZDS(JILOOP)
+ ELSE
+ ZINTX=ZZDS(JILOOP)
+! print *,' **imcoupv ZINTX ',ZINTX
+ ENDIF
+
+ ZINTY=ZZY(JILOOP,JKLOOP)
+ IF(ZINTY < XHMIN .OR. ZINTY > XHMAX)THEN
+ CYCLE
+ ENDIF
+
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(3)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(5)
+ CALL GPM(1,ZINTX,ZINTY)
+ ENDDO
+ CALL SFLUSH
+ ENDDO
+
+ CALL GSCLIP(0)
+
+! Legende couleurs
+
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZVL,ZVR,ZVB,ZVT,1)
+
+ ZVINT=(ZVT-ZVB)/12.
+ ZVY=ZVB
+ YTE=' '
+ WRITE(YTE,'(F4.0)')ZCOL(1)
+ CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
+! print *,'ZVR,ZVY,YTE ',ZVR,ZVY,YTE
+ DO J=1,6
+ CALL GSPMCI(ICOL(1))
+ ZINTX=ZVR+.005*J
+ ZINTY=ZVY+.015
+ CALL GSMK(2)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(3)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(5)
+ CALL GPM(1,ZINTX,ZINTY)
+ ENDDO
+ ZVY=ZVY+ZVINT/2.
+ YTE=' '
+ WRITE(YTE,'(F4.0)')ZCOL(2)
+ CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
+! print *,'ZVR,ZVY,YTE ',ZVR,ZVY,YTE
+ DO J=1,6
+ CALL GSPMCI(ICOL(2))
+ ZINTX=ZVR+.005*J
+ ZINTY=ZVY+.015
+ CALL GSMK(2)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(3)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(5)
+ CALL GPM(1,ZINTX,ZINTY)
+ ENDDO
+ DO J=3,13
+ ZVY=ZVY+ZVINT
+ YTE=' '
+ WRITE(YTE,'(F4.0)')ZCOL(J)
+ CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
+! print *,'ZVR,ZVY,YTE ',ZVR,ZVY,YTE
+ DO JA=1,6
+ CALL GSPMCI(ICOL(J))
+ ZINTX=ZVR+.005*JA
+ ZINTY=ZVY+.015
+ CALL GSMK(2)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(3)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(5)
+ CALL GPM(1,ZINTX,ZINTY)
+ ENDDO
+ ENDDO
+ ZVY=ZVY+ZVINT/2.
+ YTE=' '
+ WRITE(YTE,'(F4.0)')ZCOL(14)
+ CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
+
+
+ IF(LPRINT)THEN
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ DO JLOOPI=1,ILOOP
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=5
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+5
+ ENDIF
+ IF(JLOOPI == ILOOP)THEN
+ IFIN=SIZE(ZZU,1)
+ ENDIF
+
+ if(nverbia > 0)then
+ print *,' ds LPRINT DIRWIND ZDIRU '
+ print *, ZDIRU
+ print *,' ds LPRINT DIRWIND ZDIRV '
+ print *, ZDIRV
+ endif
+ WRITE(INUM,'(1X,79(1H*))')
+ WRITE(INUM,'('' K I-> '',I4,6X,4(6X,I4,6X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'(''.'',79(1H*))')
+ DO JLOOPJ=SIZE(ZZU,2),1,-1
+ WRITE(INUM,'(I4,1X,5(1X,E14.7))')JLOOPJ,(ZDIRV(II,JLOOPJ),II=IDEB,IFIN)
+ ! WRITE(INUM,'(I4,1X,5E15.8)')JLOOPJ,(ZDIRV(II,JLOOPJ),II=IDEB,IFIN)
+ ENDDO
+ WRITE(INUM,'(1X,79(1H*))')
+ ENDDO
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ ENDIF
+
+ IF(LPRINTXY)THEN
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+
+ IF(.NOT.LPVT)THEN
+ WRITE(INUM,'(''PV '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'','' (1-1,1-IKU)'')')CGROUP,&
+ & CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ ELSE
+ WRITE(INUM,'(''PV '',''G:'',A16,'' P:'',A25,'' TD-TF:'',F8.0,''-'',F8.0,''s'')')CGROUP,&
+ CTITRE(NLOOPP)(1:25),XZZDS(1),XZZDS(IUB1)
+ WRITE(INUM,'('' (1-NBTIME,1-IKU)'')')
+ ENDIF
+
+ IF(LMINUS .OR. LPLUS)THEN
+ WRITE(INUM,'(A70)')CTITB3
+ ELSE
+ ! WRITE(INUM,'(A40)')CTITGAL
+ ENDIF
+
+ IF(LUMVMPV)THEN
+ WRITE(INUM,'(''I='',I4,''J='',I4)')&
+ NIL,NJL
+ ELSE
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2)THEN
+ WRITE(INUM,'(''cc(deb)-(fin)=('',F8.0,'','',F8.0,'')-('',F8.0,'','',F8.0,'')'','' nlmax'',i5,&
+ &'' profile='',I4)')&
+ &XIDEBCV,XJDEBCV,XIFINCV,XJFINCV,NLMAX,NPROFILE
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(INUM,'(''ll(deb)-(fin)=('',F8.3,'','',F8.3,'')-('',F8.3,'','',F8.3,'')'','' nlmax'',i5,&
+ &'' profile='',I4)')&
+ &XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL,NLMAX,NPROFILE
+ ELSE IF(LDEFCV2IND)THEN
+ WRITE(INUM,'(''ij(deb)-(fin)=('',I4,'','',I4,'')-('',I4,'','',I4,'')'','' nlmax'',i5,&
+ &'' profile='',i4)')&
+ &NIDEBCV,NJDEBCV,NIFINCV,NJFINCV,NLMAX,NPROFILE
+ ENDIF
+ ELSE
+ IF(XIDEBCOU /= -999.)THEN
+ WRITE(INUM,'(''xidebcou'',F8.0,'' xjdebcou'',F8.0,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' profile='',i4)')&
+ &XIDEBCOU,XJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ELSE
+ WRITE(INUM,'(''nidebcou'',i4,'' njdebcou'',i4,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' profile='',i4)')&
+ &NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ENDIF
+ ENDIF
+ ! WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ENDIF
+
+ WRITE(INUM,'(''NBVAL en I (TIME): '',i4, &
+ & '' NBVAL en K (Z)'',i4,'' iter'',i3)') &
+ & SIZE(ZZU,1),SIZE(ZZU,2),ILOOP
+
+ II=MAX(SIZE(ZZU,1),SIZE(ZZU,2))
+ WRITE(INUM,'(1X,43(1H*))')
+ WRITE(INUM,'(2X,'' I'',7X,''TIME'',10X,''K'',9X,''Z'')')
+ WRITE(INUM,'(1X,43(1H*))')
+ DO JLOOPJ=1,II
+ IF(SIZE(ZZU,1) > SIZE(ZZU,2))THEN
+ IF(JLOOPJ <= SIZE(ZZU,2))THEN
+ WRITE(INUM,'(I5,2X,E15.8,1X,I4,2X,E15.8)')JLOOPJ,XZZDS(JLOOPJ), &
+ JLOOPJ,XZWORKZ(1,JLOOPJ)
+ ELSE
+ WRITE(INUM,'(I5,2X,E15.8)')JLOOPJ,XZZDS(JLOOPJ)
+ ENDIF
+ ELSE IF(SIZE(ZZU,2) > SIZE(ZZU,1))THEN
+ IF(JLOOPJ <= SIZE(ZZU,1))THEN
+ WRITE(INUM,'(I5,2X,E15.8,1X,I4,2X,E15.8)')JLOOPJ,XZZDS(JLOOPJ), &
+ JLOOPJ,XZWORKZ(1,JLOOPJ)
+ ELSE
+ WRITE(INUM,'(23X,I4,2X,E15.8)')JLOOPJ,XZWORKZ(1,JLOOPJ)
+ ENDIF
+ ELSE
+ WRITE(INUM,'(I5,2X,E15.8,1X,I4,2X,E15.8)')JLOOPJ,XZZDS(JLOOPJ), &
+ JLOOPJ,XZWORKZ(1,JLOOPJ)
+ ENDIF
+ ENDDO
+ WRITE(INUM,'(1X,43(1H*))')
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ ENDIF
+
+ CALL GSCLIP(0)
+ DEALLOCATE(ZX,ZZY,ZZYY,ZLAT,ZLON,ZLA,ZLO,ZDIRU,ZDIRV,ICOL,ZZDS)
+
+ELSE
+
+!!!! Janvier 2001 + LDIRWIND
+ IF(LPRINT)THEN
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ DO JLOOPI=1,ILOOP
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=5
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+5
+ ENDIF
+ IF(JLOOPI == ILOOP)THEN
+ IFIN=SIZE(ZZU,1)
+ ENDIF
+
+ IF(INDEX(CGROUP,'UM') /= 0)THEN
+ WRITE(INUM,'(1X,20(1H*),'' UM component '',34(1H*))')
+ ELSE
+ WRITE(INUM,'(1X,20(1H*),'' UT component '',34(1H*))')
+ ENDIF
+ if(nverbia > 0)then
+ print *,' ds LPRINT ZZU'
+ print *, ZZU
+ endif
+! WRITE(INUM,'(1X,79(1H*))')
+ WRITE(INUM,'('' K I-> '',I4,6X,4(6X,I4,6X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'(''.'',79(1H*))')
+ DO JLOOPJ=SIZE(ZZU,2),1,-1
+ WRITE(INUM,'(I4,1X,5(1X,E14.7))')JLOOPJ,(ZZU(II,JLOOPJ),II=IDEB,IFIN)
+ ! WRITE(INUM,'(I4,1X,5E15.8)')JLOOPJ,(ZZU(II,JLOOPJ),II=IDEB,IFIN)
+ ENDDO
+ WRITE(INUM,'(1X,79(1H*))')
+
+ IF(INDEX(CGROUP,'VM') /= 0)THEN
+ WRITE(INUM,'(1X,20(1H*),'' VM component '',34(1H*))')
+ ELSE
+ WRITE(INUM,'(1X,20(1H*),'' VT component '',34(1H*))')
+ ENDIF
+ WRITE(INUM,'('' K I-> '',I4,6X,4(6X,I4,6X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'(''.'',79(1H*))')
+ DO JLOOPJ=SIZE(ZZV,2),1,-1
+ WRITE(INUM,'(I4,1X,5(1X,E14.7))')JLOOPJ,(ZZV(II,JLOOPJ),II=IDEB,IFIN)
+ ENDDO
+ WRITE(INUM,'(1X,79(1H*))')
+ ENDDO
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ ENDIF
+
+ IF(LPRINTXY)THEN
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+
+ IF(.NOT.LPVT)THEN
+ WRITE(INUM,'(''PV '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'','' (1-1,1-IKU)'')')CGROUP,&
+ & CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ ELSE
+ WRITE(INUM,'(''PV '',''G:'',A16,'' P:'',A25,'' TD-TF:'',F8.0,''-'',F8.0,''s'')')CGROUP,&
+ CTITRE(NLOOPP)(1:25),XZZDS(1),XZZDS(IUB1)
+ WRITE(INUM,'('' (1-NBTIME,1-IKU)'')')
+ ENDIF
+
+ IF(LMINUS .OR. LPLUS)THEN
+ WRITE(INUM,'(A70)')CTITB3
+ ELSE
+ ! WRITE(INUM,'(A40)')CTITGAL
+ ENDIF
+
+ IF(LUMVMPV)THEN
+ WRITE(INUM,'(''I='',I4,''J='',I4)')&
+ NIL,NJL
+ ELSE
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2)THEN
+ WRITE(INUM,'(''cc(deb)-(fin)=('',F8.0,'','',F8.0,'')-('',F8.0,'','',F8.0,'')'','' nlmax'',i5,&
+ &'' profile='',I4)')&
+ &XIDEBCV,XJDEBCV,XIFINCV,XJFINCV,NLMAX,NPROFILE
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(INUM,'(''ll(deb)-(fin)=('',F8.3,'','',F8.3,'')-('',F8.3,'','',F8.3,'')'','' nlmax'',i5,&
+ &'' profile='',I4)')&
+ &XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL,NLMAX,NPROFILE
+ ELSE IF(LDEFCV2IND)THEN
+ WRITE(INUM,'(''ij(deb)-(fin)=('',I4,'','',I4,'')-('',I4,'','',I4,'')'','' nlmax'',i5,&
+ &'' profile='',i4)')&
+ &NIDEBCV,NJDEBCV,NIFINCV,NJFINCV,NLMAX,NPROFILE
+ ENDIF
+ ELSE
+ IF(XIDEBCOU /= -999.)THEN
+ WRITE(INUM,'(''xidebcou'',F8.0,'' xjdebcou'',F8.0,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' profile='',i4)')&
+ &XIDEBCOU,XJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ELSE
+ WRITE(INUM,'(''nidebcou'',i4,'' njdebcou'',i4,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' profile='',i4)')&
+ &NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ENDIF
+ ENDIF
+ ! WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ENDIF
+
+ WRITE(INUM,'(''NBVAL en I (TIME): '',i4, &
+ & '' NBVAL en K (Z)'',i4,'' iter'',i3)') &
+ & SIZE(ZZU,1),SIZE(ZZU,2),ILOOP
+
+ II=MAX(SIZE(ZZU,1),SIZE(ZZU,2))
+ WRITE(INUM,'(1X,43(1H*))')
+ WRITE(INUM,'(2X,'' I'',7X,''TIME'',10X,''K'',9X,''Z'')')
+ WRITE(INUM,'(1X,43(1H*))')
+ DO JLOOPJ=1,II
+ IF(SIZE(ZZU,1) > SIZE(ZZU,2))THEN
+ IF(JLOOPJ <= SIZE(ZZU,2))THEN
+ WRITE(INUM,'(I5,2X,E15.8,1X,I4,2X,E15.8)')JLOOPJ,XZZDS(JLOOPJ), &
+ JLOOPJ,XZWORKZ(1,JLOOPJ)
+ ELSE
+ WRITE(INUM,'(I5,2X,E15.8)')JLOOPJ,XZZDS(JLOOPJ)
+ ENDIF
+ ELSE IF(SIZE(ZZU,2) > SIZE(ZZU,1))THEN
+ IF(JLOOPJ <= SIZE(ZZU,1))THEN
+ WRITE(INUM,'(I5,2X,E15.8,1X,I4,2X,E15.8)')JLOOPJ,XZZDS(JLOOPJ), &
+ JLOOPJ,XZWORKZ(1,JLOOPJ)
+ ELSE
+ WRITE(INUM,'(23X,I4,2X,E15.8)')JLOOPJ,XZWORKZ(1,JLOOPJ)
+ ENDIF
+ ELSE
+ WRITE(INUM,'(I5,2X,E15.8,1X,I4,2X,E15.8)')JLOOPJ,XZZDS(JLOOPJ), &
+ JLOOPJ,XZWORKZ(1,JLOOPJ)
+ ENDIF
+ ENDDO
+ WRITE(INUM,'(1X,43(1H*))')
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ ENDIF
+! Janvier 2001
+
+ ZZU=XSPVAL
+ ZZV=XSPVAL
+ IF(.NOT.LUMVMPV)THEN
+ DO JKLOOP=IKB,JLMAX,NISKIPVY
+ DO JILOOP=1,ILMAX,NISKIPVX
+ ZZU(JILOOP,JKLOOP)=PU(JKLOOP,JILOOP)
+ ZZV(JILOOP,JKLOOP)=PW(JKLOOP,JILOOP)
+ ENDDO
+ ENDDO
+
+ ELSE
+
+ DO JKLOOP=1,JLMAX,NISKIPVY
+ DO JILOOP=1,ILMAX,NISKIPVX
+ ZZU(JILOOP,JKLOOP)=PU(JKLOOP,JILOOP)
+ ZZV(JILOOP,JKLOOP)=PW(JKLOOP,JILOOP)
+ ENDDO
+ ENDDO
+
+ ENDIF
+! Janvier 2001
+
+!
+!* 1.4 Collects wind values within the user postprocessing
+!* window with a sampling rate of NISKIP outside values
+!* are kept to default
+!
+
+CALL GSCLIP(0)
+!
+!
+!* 1.5 Routine VVUMXY of provided by TRACE to locate and scale wind
+!* arrows on the display
+!
+CALL VVSETI('MAP',4)
+CALL VVSETI('SET',0)
+CALL VVSETR('VPL',ZVL)
+CALL VVSETR('VPR',ZVR)
+CALL VVSETR('VPB',ZVB)
+CALL VVSETR('VPT',ZVT)
+CALL VVSETR('WDL',ZWL)
+CALL VVSETR('WDR',ZWR)
+CALL VVSETR('WDB',ZWB)
+CALL VVSETR('WDT',ZWT)
+
+
+CALL VVSETR('AMX',XAMX)
+CALL VVSETR('VHC',XVHC)
+CALL VVSETR('VRL',XVRL)
+CALL VVSETR('VLC',XVLC)
+
+IF(XVHC < 0. )THEN
+ CALL VVSETC('MXT',' ')
+ CALL VVSETC('MXT','Scale')
+END IF
+!
+!* 1.6 Masks vectors where wind coponents have XSPVAL values
+!
+CALL VVSETI('SVF',3)
+CALL VVSETR('USV',XSPVAL)
+CALL VVSETR('VSV',XSPVAL)
+!
+!* 1.6 Selects look and feel options for the vector display
+! (Text strings, etc..)
+!
+CALL VVSETI('MNP',-4)
+CALL VVSETI('MXP',-4)
+CALL VVSETR('MNX',.75)
+!CALL VVSETR('MNX',-ZVL)
+!ZY=-1./5.
+!ZY=-MIN(0.12,ZVB+.02)
+IF(ZVB <= .15)THEN
+ ZY=-ZVB-.020
+! ZY=(-.08)/(ZVT-ZVB)
+ELSE
+!!! Octobre 2001
+! ZY=(-.10)/(ZVT-ZVB)
+ ZY=(-.13)/(ZVT-ZVB)
+!!! Octobre 2001
+ENDIF
+!IF(ZVB-(ZVT-ZVB)/5..LT.0.05)ZY=(0.05-ZVB)/(ZVT-ZVB)
+CALL VVSETR('MNY',ZY)
+IF(ZVR-ZVL >= .78)THEN
+ CALL VVSETR('MXX',.75+.16)
+ELSE
+ CALL VVSETR('MXX',.75+.27)
+ENDIF
+CALL VVSETR('MXY',ZY)
+CALL VVSETR('MXS',.008*.9/(ZVR-ZVL))
+CALL VVSETR('MNS',.008*.9/(ZVR-ZVL))
+!
+!* 1.7 Draws the arrows
+!
+IF(XLWV > 0.)THEN
+ CALL VVSETR('LWD',XLWV)
+ELSE
+ CALL VVSETR('LWD',XLWVDEF)
+ENDIF
+
+IF(ILMAX > 6)THEN
+CALL GSCLIP(1) ! Clipping off
+ENDIF
+CALL VVSETI('VPO',1)
+CALL VVINIT(ZZU,ILMAX,ZZV,ILMAX,0.,0,ILMAX,IKU,0.,0) ! Initializes VVECTR
+CALL VVECTR(ZZU,ZZV,0.,0,0,0.) ! Draws arrows
+CALL GSCLIP(0) ! Clipping back on
+!
+CALL VVRSET
+!------------------------------------------------------------------------------
+!
+!* 2. COMPLETING THE PLOT
+! -------------------
+!
+!* 2.1 Page information labels
+!
+
+CALL GSCLIP(0)
+
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+XCURVPTL=ZVL;XCURVPTR=ZVR;XCURVPTB=ZVB;XCURVPTT=ZVT
+!print *,' getset ',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+
+IF(LCOLPVT)THEN
+!print *,' ** imcoupv AP LCOLPVT '
+
+ IF(LCOLUSERUV)THEN
+ INBCOL=NBPARCOLUV
+ IF(ALLOCATED(ICOL))THEN
+ DEALLOCATE(ICOL)
+ ENDIF
+ ALLOCATE(ICOL(NBCOLUV))
+ ALLOCATE(YLBS(NBCOLUV-1))
+ ALLOCATE(ZPARCOLUV(NBCOLUV-1))
+ ICOL(:)=NINDCOLUV(1:NBCOLUV)
+ ZPARCOLUV=XPARCOLUV(1:NBCOLUV-1)
+ ELSE
+ INBCOL=NBPARCOLUVSTD
+ IF(ALLOCATED(ICOL))THEN
+ DEALLOCATE(ICOL)
+ ENDIF
+ ALLOCATE(ICOL(NBCOLUVSTD))
+ ALLOCATE(YLBS(NBCOLUVSTD-1))
+ ALLOCATE(ZPARCOLUV(NBCOLUVSTD-1))
+ ICOL(:)=NCOLUVSTD(1:NBCOLUVSTD)
+ ZPARCOLUV=XPARCOLUVSTD(1:NBCOLUVSTD-1)
+ ENDIF
+
+ YLBS(:)=' '
+!print *,' ** imcoupv AV GENFORMAT '
+
+ DO J=1,INBCOL
+ ZTEM=ZPARCOLUV(J)
+ CALL GENFORMAT_FORDIACHRO(ZTEM,YLBSTEM)
+! CALL GENFORMAT_FORDIACHRO(ZPARCOLUV(J),YLBS(J))
+ YLBS(J)=YLBSTEM
+ ENDDO
+
+!print *,' ** imcoupv AP GENFORMAT '
+ CALL GSFAIS(1)
+ CALL LBLBAR_FORDIACHRO(0,ZVL,ZVR,ZVT+.01,ZVT+.05,INBCOL+1,1.,.15,ICOL,&
+ 1,YLBS,INBCOL,2)
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZVL,ZVR,ZVB,ZVT,ID)
+ YTIT(1:LEN(YTIT))=' '
+ YTIT=CTITRE(NLOOPP)
+
+ YTIT=ADJUSTR(YTIT)
+! print *,' **imcoupv YTIT NLOOPP ',YTIT,NLOOPP
+ CALL PLCHHQ(MIN(ZVR+.1,1.),ZVT+.02,YTIT(1:LEN_TRIM(YTIT)),.007,0.,+1.)
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ DEALLOCATE(ICOL)
+ DEALLOCATE(YLBS)
+ DEALLOCATE(ZPARCOLUV)
+ENDIF
+
+!!! Janvier 2001
+ENDIF
+!print *,' **imcoupv AV SET(0.,1.,0.,1.,0.,1.,0.,1.,1)'
+!!! Janvier 2001
+
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+!
+IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN
+
+!
+! Titres en X
+!
+!-------------------------------------------------------------------
+ YTEM(1:LEN(YTEM))=' '
+ YTEM=ADJUSTL(YTEM)
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(XSZTITXL /= 0.)THEN
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/2.,.05),YTEM,XSZTITXL,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/2.,YTEM,XSZTITXL,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ IF(LHEURX)THEN
+ YTEM='(H)'
+ ELSE
+ YTEM='(sec)'
+ ENDIF
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(XSZTITXM /= 0.)THEN
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),XSZTITXM,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),XSZTITXM,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/2.,ZVB/2.,YTEM,XSZTITXM,0.,-1.)
+ ELSE
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(XSZTITXR /= 0.)THEN
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/2.,.05),YTEM,XSZTITXR,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,XSZTITXR,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+!
+! Titres en Y
+!
+!-------------------------------------------------------------------
+ YTEM(1:LEN(YTEM))=' '
+ YTEM='Altitude;(ms)'
+ CALL RESOLV_TITY('CTITYM',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYT',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYB',ZVL,ZVR,ZVB,ZVT,YTEM)
+
+! Titres Bottom
+!-------------------------------------------------------------------
+CALL RESOLV_TIT('CTITB1',HLEGEND)
+ZXPOSTITB1=.002
+ZXYPOSTITB1=.005
+IF(XPOSTITB1 /= 0.)THEN
+ ZXPOSTITB1=XPOSTITB1
+ENDIF
+IF(XYPOSTITB1 /= 0.)THEN
+ ZXYPOSTITB1=XYPOSTITB1
+ENDIF
+
+IF(HLEGEND /= ' ')THEN
+ IF(XSZTITB1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HLEGEND,XSZTITB1,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,HLEGEND,XSZTITB1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HLEGEND,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,HLEGEND,.007,0.,-1.)
+ ENDIF
+ENDIF
+CALL RESOLV_TIT('CTITB2',CLEGEND2)
+ZXPOSTITB2=.002
+ZXYPOSTITB2=.025
+IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ENDIF
+IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ENDIF
+IF(CLEGEND2 /= ' ')THEN
+ IF(XSZTITB2 /= 0.)THEN
+ CALL PLCHHQ(0.002,0.025,CLEGEND2,XSZTITB2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
+ ENDIF
+ENDIF
+YTEM(1:LEN(YTEM))=' '
+! Octobre 2001
+YTEM=CTIMEC
+YTEM=ADJUSTL(CTIMEC)
+! Octobre 2001
+CALL RESOLV_TIT('CTITB3',YTEM)
+ZXPOSTITB3=.002
+ZXYPOSTITB3=.050
+IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ENDIF
+IF(XYPOSTITB3 /= 0.)THEN
+ ZXYPOSTITB3=XYPOSTITB3
+ENDIF
+IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,XSZTITB3,0.,-1.)
+! CALL PLCHHQ(0.002,0.050,YTEM,XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,.009,0.,-1.)
+! CALL PLCHHQ(0.002,0.050,YTEM,.009,0.,-1.)
+ ENDIF
+ENDIF
+! Titres Top
+!-------------------------------------------------------------------
+! Janv 2001
+ IF(.NOT.LUMVMPV)THEN
+ IF(XIDEBCOU.NE.-999.)THEN
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2IND)THEN
+ WRITE(YCARCOU,1018)NIDEBCV,NJDEBCV,NIFINCV,NJFINCV
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(YCARCOU,1019)XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL
+ ELSE
+ WRITE(YCARCOU,1020)XIDEBCV,XJDEBCV,XIFINCV,XJFINCV
+ ENDIF
+ ELSE
+ IF(XIDEBCOU < 99999.)THEN
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1001)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ ELSE
+ WRITE(YCARCOU,1002)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ END IF
+ ELSE
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1003)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ ELSE
+ WRITE(YCARCOU,1004)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ END IF
+ END IF
+ END IF
+ ELSE
+ WRITE(YCARCOU,1000)NIDEBCOU,NJDEBCOU,NLANGLE,NLMAX
+ END IF
+
+ ELSE
+ WRITE(YCARCOU,1021)NIl,NJL
+ ENDIF
+
+! Janvier 2001
+! Conversion METERS/SECONDE en M/S
+IIBID=INDEX(HTEXT,'METERS/SECONDE')
+ILENHT=LEN_TRIM(HTEXT)
+IF(IIBID /= 0)THEN
+IF(HTEXT(IIBID:ILENHT) == 'METERS/SECONDE')THEN
+ HTEXT(IIBID:ILENHT)=' '
+ HTEXT(IIBID:IIBID+2)='M/S '
+ENDIF
+ENDIF
+
+IF(LUMVMPV)THEN
+! Janvier 2001
+IF(HTEXT/= ' ')THEN
+! print *,' ** imcoupv CUNITGAL ',CUNITGAL
+ ILENYC=LEN_TRIM(YCARCOU)
+ ILENHT=LEN_TRIM(HTEXT)
+ YCARCOU(ILENYC+1:ILENYC+3)=' '
+ YCARCOU(ILENYC+4:ILENYC+ILENHT+4-1)=HTEXT(1:ILENHT)
+! ILENYC=LEN_TRIM(YCARCOU)
+! ILENHT=LEN_TRIM(CUNITGAL)
+! YCARCOU(ILENYC+1:ILENYC+1)=' '
+ENDIF
+! Janvier 2001
+ENDIF
+! Janvier 2001
+
+CALL RESOLV_TIT('CTITT1',YCARCOU)
+ZXPOSTITT1=.002
+ZXYPOSTITT1=.98
+IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ENDIF
+IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ENDIF
+IF(YCARCOU /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,.012,0.,-1.)
+ ENDIF
+ENDIF
+YTEM(1:LEN(YTEM))=' '
+CALL RESOLV_TIT('CTITT2',YTEM)
+ZXPOSTITT2=.002
+ZXYPOSTITT2=.95
+IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ENDIF
+IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ENDIF
+IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
+ ENDIF
+! Janvier 2001
+ELSE
+ IF(.NOT.LUMVMPV)THEN
+ YCAR(1:LEN(YCAR))=' '
+ WRITE(YCAR,1006)NPROFILE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCAR,.008,0.,-1.)
+ ENDIF
+! Janvier 2001
+ENDIF
+YTEM(1:LEN(YTEM))=' '
+CALL RESOLV_TIT('CTITT3',YTEM)
+ZXPOSTITT3=.002
+ZXYPOSTITT3=.93
+IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ENDIF
+IF(XYPOSTITT3 /= 0.)THEN
+ ZXYPOSTITT3=XYPOSTITT3
+ENDIF
+IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,XSZTITT3,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,.008,0.,-1.)
+ ENDIF
+ENDIF
+!-------------------------------------------------------------------
+IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ENDIF
+
+!-------------------------------------------------------------------
+ IF(NSUPERDIA == 1)THEN
+ CALL RESOLV_TIT('CTITVAR1',HTEXT)
+ ELSE IF(NSUPERDIA == 2)THEN
+ CALL RESOLV_TIT('CTITVAR2',HTEXT)
+ ELSE IF(NSUPERDIA == 3)THEN
+ CALL RESOLV_TIT('CTITVAR3',HTEXT)
+ ELSE IF(NSUPERDIA == 4)THEN
+ CALL RESOLV_TIT('CTITVAR4',HTEXT)
+ ELSE IF(NSUPERDIA == 5)THEN
+ CALL RESOLV_TIT('CTITVAR5',HTEXT)
+ ELSE IF(NSUPERDIA == 6)THEN
+ CALL RESOLV_TIT('CTITVAR6',HTEXT)
+ ELSE IF(NSUPERDIA == 7)THEN
+ CALL RESOLV_TIT('CTITVAR7',HTEXT)
+ ELSE IF(NSUPERDIA == 8)THEN
+ CALL RESOLV_TIT('CTITVAR8',HTEXT)
+ ENDIF
+
+
+! Janvier 2001
+ IF(.NOT.LUMVMPV)THEN
+! Janvier 2001
+ IF(HTEXT /= ' ')THEN
+ IF(.NOT.LSUPER)THEN
+ IF(XSZTITVAR1 /= 0.)THEN
+ CALL PLCHHQ(0.1,ZVT+0.03,HTEXT,XSZTITVAR1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.1,ZVT+0.03,HTEXT,.011,0.,-1.)
+ ENDIF
+ ELSE
+ IF(XSZTITVAR1 /= 0. .AND. NSUPER == 1)THEN
+ CALL PLCHHQ(0.1+(NSUPER-1)*.26,ZVT+0.03,HTEXT,XSZTITVAR1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.1+(NSUPER-1)*.26,ZVT+0.03,HTEXT,.011,0.,-1.)
+ ENDIF
+ ENDIF
+ ENDIF
+! Janvier 2001
+ ENDIF
+! Janvier 2001
+!-------------------------------------------------------------------
+IF(LSUPER)THEN
+ LARROVL=.TRUE.
+ELSE
+ LARROVL=.FALSE.
+END IF
+!
+!!!!!!!!!!!!!!!!!!!!!!
+!ENDIF
+!!!!!!!!!!!!!!!!!!!!!!
+!
+!* 2.14 Heading formats
+!
+1000 FORMAT('Vertical section IDEB=',I4,' JDEB=',I4,' ANG.=',I3,' NBPTS=',I4)
+1001 FORMAT('Vertical section XDEB=',F6.0,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I4)
+1002 FORMAT('Vertical section XDEB=',F6.0,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1003 FORMAT('Vertical section XDEB=',E7.2,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I4)
+1004 FORMAT('Vertical section XDEB=',E6.2,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1006 FORMAT('Vertical profile IPRO=',I4)
+1018 FORMAT('Vertical section IND I,J (BEGIN)-(END)=(',I4,',',I4,')-(',I4,',',I4,')')
+1019 FORMAT('Vertical section LAT,LON (BEGIN)-(END)=(',F4.1,',',F5.1,')-(',F4.1,',',F5.1,')')
+1020 FORMAT('Vertical section CONF. COORD.(BEGIN)-(END)=(',F8.0,',',F8.0,')-(',F8.0,',',F8.0,')')
+1021 FORMAT('Vertical profile I=',I4,' J=',I4)
+!
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!print *,'imcoupv ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT ',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+CALL GSCLIP(1)
+!
+!-------------------------------------------------------------------------
+!
+!* 3. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE IMCOUPV_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/imcouv_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/imcouv_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..16fd204ce4a1ac142a51886e55c8c7cbc831a736
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/imcouv_fordiachro.f90
@@ -0,0 +1,1889 @@
+! ######spl
+ SUBROUTINE IMCOUV_FORDIACHRO(PU,PW,HLEGEND,HTEXT)
+! #################################################
+!
+!!**** *IMCOUV_FORDIACHRO* - Draws a vector arrow plot for a vertical cross-section
+!!
+!! PURPOSE
+!! -------
+! Draws an arrow plot of a UW vector field re-colocated at the
+! mass gridpoint for a vertical cross-section
+!
+!!** METHOD
+!! ------
+!!
+!! Assumption is made that wind components were re-colocated onto the mass
+!! gridpoint location prior to calling IMCOUV.
+!! The wind arrows are plotted using the VVECTR NCAR utility.
+!!
+!! Notice that a TRACE-provided VVUMXY routine is used within the NCAR
+!! vector VVECTR utility to map the wind vectors onto the stretched
+!! MESO-NH model space. Wind vectors are given in m/s and scaled by VVUMXY
+!! to obtain arrow sizes in "NCAR fractional coordinate" (NCAR User Guide
+!! "Fundamentals", Appendix A, p345 section 1), notice this is different
+!! from what is required for Conpack... The final result is an automatic
+!! arrow scale selection on the plot.
+!! If a different procedure has to be followed VVUMXY should
+!! be updated accordingly. The parameters of the NCAR VVECTR utility can
+!! be printed online by typing "man vectors_params", these feature are not
+!! really documented elsewhere in NCAR user guide.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! GSCLIP : clips items getting out of the drawing window !
+!! GETSET : retrieves the normalized and user NCAR !
+!! coordinates of a previously used window !
+!! PLCHHQ : prints high-quality character strings !
+!! !
+!! VVSETR ! : gets the value of a NCAR parameter, REEL !
+!! VVSETI ! INTEGER !
+!! VVINIT : initialize a vector plot (arrows) !
+!! VVECTR : draws the arrows for a vector plot !
+!! !
+!! GSLWSC : sets line width !
+!! VVRSET : resets VVECTR parameters to default values !
+!!
+!!
+!! VVUMXY : TRACE provided FORTRAN-77 routine directly called
+!! within the VVECTR NCAR utility to to map the wind
+!! vectors onto the stretched MESO-NH model space.
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_TITLE : Declares heading variables for the plots (TRACE)
+!! CLEGEND: Current plot heading title
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX,XXY : coordinate values for all the MESO-NH grids
+!! XXZS : topography values for all the MESO_NH grids
+!!
+!! Module MODD_CONF : declares configuration variables of all models
+!! LCARTESIAN: Logical for cartesian geometry :
+!! .TRUE. = cartesian geometry
+!! .FALSE. = conformal projection
+!!
+!! Module MODN_PARA : defines NAM_DOMAIN_POS namelist
+!! LHORIZ : must be .FALSE. to perform vertical cross esctions
+!! LVERTI : must be .TRUE. to perform vertical cross sections
+!! Module MODD_DIM1 : Contains dimensions
+!! NIMAX, NJMAX : x, and y array dimensions
+!! NIINF, NISUP : Lower and upper array bounds in x direction
+!! NJINF, NJSUP : Lower bound and upper bound in y direction
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!! XSPVAL : Special value
+!! NISKIP : Sampling rate for drawing velocity vectors
+!!
+!! Module MODD_OUT : Defines a log. unit for printing
+!! NIMAXT : x-size of the displayed section of the model array
+!! NJMAXT : y-size of the displayed section of the model array
+!!
+!! Module MODD_TIME ! To be checked, useless..
+!! Module MODD_TIME1 ! To be checked, useless.
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 19/09/95
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF
+USE MODD_COORD
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODD_GRID
+USE MODD_GRID1
+USE MODD_PARAMETERS
+USE MODD_NMGRID
+USE MODD_FIELD1_CV2D
+USE MODD_SUPER
+USE MODD_TITLE
+USE MODD_OUT
+USE MODN_PARA
+USE MODN_NCAR
+USE MODD_LUNIT1
+USE MODD_CVERT
+USE MODD_CTL_AXES_AND_STYL
+USE MODD_RESOLVCAR
+USE MODD_TIT
+USE MODD_PVT
+USE MODD_MEMCV
+USE MODD_DEFCV
+USE MODE_GRIDPROJ
+USE MODI_RESOLV_TIT
+USE MODI_RESOLV_TITY
+!
+IMPLICIT NONE
+
+INTERFACE
+ SUBROUTINE INTERPOLW(PZZU, PZZW, PSTRU, PSTRW)
+ REAL,DIMENSION(:,:) :: PZZU, PZZW, PSTRU, PSTRW
+ END SUBROUTINE INTERPOLW
+END INTERFACE
+
+!
+!* 0.0 TRACE interface with the "VVUMXY" routine of the NCAR package
+!
+! NOTICE: The TRACE provided VVUMXY routine and the NCAR graphical utilities
+! ------ are NOT written in Fortran 90, but in Fortran 77.. This sub-section
+! of TRACE does not follow the Meso-NH usual rules: it has to be made
+! using a COMMON stack with static memory allocation of XZWORKZ and
+! XZZDS arrays.
+!
+!
+COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+COMMON/TEMV/XZWORKZ,XZZDS,NINX,NINY
+#include "big.h"
+REAL,DIMENSION(N2DVERTX,2500):: XZWORKZ
+!REAL,DIMENSION(1000,400):: XZWORKZ
+!REAL,DIMENSION(200,200) :: XZWORKZ
+REAL,DIMENSION(N2DVERTX):: XZZDS
+!REAL,DIMENSION(1000):: XZZDS
+!REAL,DIMENSION(200) :: XZZDS
+INTEGER :: NINX, NINY
+LOGICAL :: LVERT, LHOR, LPT, LXABS
+!
+!* 0.1 NCAR work arrays
+!
+! See aforementioned notice. The dimensions of these arrays are
+! subject to possible tuning, but have to be prescribed. Add
+! extra size if necessary.
+!
+INTEGER,PARAMETER :: JPRSCR=50000, JPISCR=50000
+
+REAL,DIMENSION(JPRSCR):: ZRSCR
+INTEGER,DIMENSION(JPISCR):: ISCR
+!
+!* 0.2 Dummy arguments and results
+!
+REAL,DIMENSION(:,:) :: PU, PW
+CHARACTER(LEN=*) :: HTEXT ! Plot heading containing field name
+CHARACTER(LEN=*) :: HLEGEND
+!
+!* 0.3 Local variables
+!
+INTEGER :: JILOOP, JKLOOP, ID, IDD
+INTEGER :: IKB, IKE, IKU
+INTEGER,SAVE :: IKL, ISKIPX, ISKIPY, ISKIPXM
+!!! Janvier 2001
+INTEGER :: IUB1, IUB2, ITER, JTER, II,JJ, ITERM
+INTEGER :: IJ, J, JA, JILOOPD, JILOOPF, I
+INTEGER :: JLOOPI, JLOOPJ, III
+INTEGER :: ILMAX
+INTEGER :: INUM, IRESP, ILOOP, IDEB, IFIN
+INTEGER :: IER,ICOL1
+INTEGER,DIMENSION(18) :: ICOL
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: IE
+!
+!! Avec interpol en Z
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZSTRU, ZSTRW
+REAL :: ZT,ZRA
+INTEGER :: IZS, IU1, JU1,JU2, ISEUIL
+!! Avec interpol en Z
+!
+REAL :: ZMI, ZMA, ZMIG, ZMAG, ZLATB, ZLONB
+REAL :: ZRPK, ZBETA, ZLON0, ZVINT, ZVY, ZINTX, ZINTY
+REAL,DIMENSION(18) :: ZCOL
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZX,ZLAT,ZLON,ZZY,ZYY
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZDIRU,ZDIRV,ZLA,ZLO
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZSTR1
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZLAB,ZLOB
+CHARACTER(LEN=4) :: YTE
+!!! Janvier 2001
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZZU, ZZW
+!!REAL,DIMENSION(NLMAX,SIZE(PU,2)) :: ZZU, ZZW
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZZDS
+REAL,DIMENSION(N2DVERTX+20) :: ZDS, ZWZ
+!REAL,DIMENSION(1020) :: ZDS, ZWZ
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZDS2, ZWZ2
+REAL :: ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+REAL ::ZWLL, ZWRR, ZWBB, ZWTT
+REAL :: ZY
+REAL :: ZXB,ZYB
+REAL :: ZDMX, ZVMX
+REAL :: ZRAP
+REAL :: ZXPOSTITT1, ZXYPOSTITT1
+REAL :: ZXPOSTITT2, ZXYPOSTITT2
+REAL :: ZXPOSTITT3, ZXYPOSTITT3
+REAL :: ZXPOSTITB1, ZXYPOSTITB1
+REAL :: ZXPOSTITB2, ZXYPOSTITB2
+REAL :: ZXPOSTITB3, ZXYPOSTITB3
+REAL,DIMENSION(1000) :: ZYYY
+REAL :: ZU,ZW,ZM,ZUMN,ZWMN,ZMN,ZUMX,ZWMX,ZMX
+
+CHARACTER(LEN=82) :: YCARCOU, YTEM
+CHARACTER(LEN=80) :: YCAR
+CHARACTER(LEN=40) :: YLBL
+CHARACTER(LEN=10) :: YLBLMN,YLBLMX
+CHARACTER(LEN=10) :: FORMAX, FORMAY
+
+LOGICAL,SAVE :: GVSUPSCA
+!
+!* 0.4 External for NCAR use
+!
+! SFILL subroutine declared as external provides area control
+! in some parts of the contour plot.
+!
+!EXTERNAL SFILL
+EXTERNAL STUMXY
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DISPLAY ENVIRONMENT SETUP AND ARROWS PLOTTING
+! ---------------------------------------------
+!
+!* 1.1 Array sizes calculation and default field value
+!
+!
+IKU=NKMAX+2*JPVEXT
+IKB=1+JPVEXT
+IKE=IKU-JPVEXT
+!
+!print *,'size ZZU ZZW ZRSCR ISCR ',SIZE(ZZU,1),SIZE(ZZU,2),SIZE(ZZW,1), &
+!SIZE(ZZW,2),SIZE(ZRSCR),SIZE(ISCR)
+IF(ALLOCATED(ZZU))THEN
+ DEALLOCATE(ZZU)
+ENDIF
+IF(ALLOCATED(ZZW))THEN
+ DEALLOCATE(ZZW)
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF(LSTREAM .AND. NISKIP /= 1)THEN
+ILMAX=NLMAX/NISKIP
+IF(ILMAX*NISKIP < NLMAX)ILMAX=ILMAX+1
+ALLOCATE(ZZU(ILMAX,SIZE(PU,2)))
+ALLOCATE(ZZW(ILMAX,SIZE(PU,2)))
+DO JILOOP=1,ILMAX
+ DO JKLOOP=1,IKU
+ ZZU(JILOOP,JKLOOP)=XSPVAL
+ ZZW(JILOOP,JKLOOP)=XSPVAL
+ ENDDO
+ENDDO
+I=0
+DO JILOOP=1,NLMAX,NISKIP
+ I=I+1
+ XZZDS(I)=XDS(JILOOP,NMGRID)
+ENDDO
+IF(I == ILMAX)THEN
+ELSE
+ I=I+1
+ XZZDS(I)=XDS(NLMAX,NMGRID)
+ENDIF
+I=0
+DO JILOOP=1,NLMAX,NISKIP
+ I=I+1
+ XZWORKZ(I,1:IKU)=XWORKZ(JILOOP,1:IKU,NMGRID)
+ENDDO
+IF(I == ILMAX)THEN
+ELSE
+ I=I+1
+ XZWORKZ(I,1:IKU)=XWORKZ(NLMAX,1:IKU,NMGRID)
+ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ELSE
+
+ALLOCATE(ZZU(NLMAX,SIZE(PU,2)))
+ALLOCATE(ZZW(NLMAX,SIZE(PU,2)))
+DO JILOOP=1,NLMAX
+ DO JKLOOP=1,IKU
+ ZZU(JILOOP,JKLOOP)=XSPVAL
+ ZZW(JILOOP,JKLOOP)=XSPVAL
+ ENDDO
+ENDDO
+!
+!* 1.2 Collects X and Z values
+!
+DO JILOOP=1,NLMAX
+ XZZDS(JILOOP)=XDS(JILOOP,NMGRID)
+ENDDO
+DO JILOOP=1,NLMAX
+ DO JKLOOP=1,IKU
+ XZWORKZ(JILOOP,JKLOOP)=XWORKZ(JILOOP,JKLOOP,NMGRID)
+ ENDDO
+ENDDO
+
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!* 1.3 Window definition and plot
+!
+!ZVL=.1
+!ZVR=.9
+!ZVB=.1
+!ZVT=.9
+IF(LVPTVUSER)THEN
+ ZVL=XVPTVL
+ ZVR=XVPTVR
+ ZVB=XVPTVB
+ ZVT=XVPTVT
+ELSE
+ ZVL=.1
+ ZVR=.9
+ ZVB=.1
+ ZVT=.9
+ENDIF
+ZWL=XDS(1,NMGRID)
+ZWR=XDS(NLMAX,NMGRID)
+! 130101
+IF((XHMIN==0..AND.XHMAX==0.).OR.(XHMAX<=XHMIN))THEN
+ XHMIN=XWORKZ(1,IKB,NMGRID)
+ XHMAX=XWORKZ(1,IKE,NMGRID)
+END IF
+ZWB=XHMIN
+ZWT=XHMAX
+
+LVERTI=.TRUE. ; LHORIZ=.FALSE.
+LVERT=LVERTI
+LHOR=LHORIZ
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF(LSTREAM .AND. NISKIP /= 1)THEN
+NINX=ILMAX
+ELSE
+NINX=NLMAX
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+NINY=IKU
+!print *,' **gsclip N1 0 '
+CALL GSCLIP(0)
+
+CALL GSLN(1)
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+IF(LSUPER)THEN
+ NSUPER=NSUPER+1
+! print *,' ***IMCOUV NSUPER*** ',NSUPER
+ IF(NSUPER == 1)THEN
+ NCOLUVG=NCOLUV1
+ ELSEIF(NSUPER == 2)THEN
+ NCOLUVG=NCOLUV2
+ ELSEIF(NSUPER == 3)THEN
+ NCOLUVG=NCOLUV3
+ ELSEIF(NSUPER == 4)THEN
+ NCOLUVG=NCOLUV4
+ ELSEIF(NSUPER == 5)THEN
+ NCOLUVG=NCOLUV5
+ ELSE
+ NCOLUVG=1
+ ENDIF
+ IF(NSUPER == 1)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+ ELSE
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ END IF
+ELSE
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+ NCOLUVG=NCOLUV1
+ENDIF
+
+FORMAX=' '
+IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ELSE
+ FORMAX='(F8.0)'
+ENDIF
+FORMAY=' '
+IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ELSE
+ FORMAY='(F7.0)'
+ENDIF
+
+CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+!CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+CALL GASETI('LTY',1)
+! Janvier 2001
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
+IF(LPV)THEN
+ IF(LFACTAXEY)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
+ ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
+ ELSEIF(LAXEYUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
+ XAXEYUSERD,XAXEYUSERF,IDD)
+ ENDIF
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,0,0,5,0.,0)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,0,1,5,0.,0)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,0,0,5,0.,0)
+ ELSE
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,0,1,5,0.,0)
+ ENDIF
+!Avril 2002
+ CALL FRSTPT((ZWL+ZWR)/2,ZWB)
+ CALL VECTOR((ZWL+ZWR)/2,ZWT)
+ELSE
+! Mars 2001
+ IF(LFACTAXEX)THEN
+ IF(LFACTAXEY)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,&
+ ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
+ ELSE
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,&
+ ZWBB,ZWTT,IDD)
+ ENDIF
+ ELSEIF(LFACTAXEY)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
+ ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
+ ELSEIF(LAXEXUSER)THEN
+ IF(LAXEYUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,XAXEXUSERD,XAXEXUSERF,&
+ XAXEYUSERD,XAXEYUSERF,IDD)
+ ELSE
+ CALL SET(ZVL,ZVR,ZVB,ZVT,XAXEXUSERD,XAXEXUSERF,&
+ ZWBB,ZWTT,IDD)
+ ENDIF
+ ELSEIF(LAXEYUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
+ XAXEYUSERD,XAXEYUSERF,IDD)
+ ENDIF
+! Mars 2001
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,0,0,5,0.,0)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,0,1,5,0.,0)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,1,0,5,0.,0)
+ ELSE
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN,1,1,5,0.,0)
+ ENDIF
+!Avril 2002
+ENDIF
+! Mars 2001
+IF(LFACTAXEX .OR. LFACTAXEY .OR. LAXEXUSER .OR. LAXEYUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
+ENDIF
+! Mars 2001
+!
+!* 1.4 Collects wind values within the user postprocessing
+!* window with a sampling rate of NISKIP outside values
+!* are kept to default
+!
+! Janvier 2001 On prevoit Vecteurs et direction Vent Horizontal en CV!
+! Dans ce cas ZZW contient la composante V passee en argument
+
+! Partie commune de LPRINT
+IF(LPRINT .AND..NOT.LULMWM .AND..NOT.LULTWT)THEN
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ ILOOP=SIZE(PU,1)/5
+ IF(ILOOP * 5 < SIZE(PU,1))ILOOP=ILOOP+1
+ IF(LPV)ILOOP=1
+
+ IF(.NOT.LPVT)THEN
+ IF(LPV)THEN
+ WRITE(INUM,'(''PV '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'','' (NPROFILE,1-IKU)'')')CGROUP,&
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ ELSE
+ WRITE(INUM,'(''CV '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'','' (1-NLMAX,1-IKU)'')')CGROUP,&
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ ENDIF
+ ELSE
+ WRITE(INUM,'(''CV '',''G:'',A16,'' P:'',A25)')CGROUP,&
+& CTITRE(NLOOPP)(1:25)
+ ENDIF
+
+ IF(LMINUS .OR. LPLUS)THEN
+ WRITE(INUM,'(A70)')CTITB3
+ ELSE
+ WRITE(INUM,'(A40)')CTITGAL
+ ENDIF
+
+ IF(.NOT.LPV)THEN
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2)THEN
+ WRITE(INUM,'(''cc(deb)-(fin)=('',F8.0,'','',F8.0,'')-('',F8.0,'','',F8.0,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCV,XJDEBCV,XIFINCV,XJFINCV,NLMAX,SIZE(PU,2),ILOOP
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(INUM,'(''ll(deb)-(fin)=('',F8.3,'','',F8.3,'')-('',F8.3,'','',F8.3,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL,NLMAX,SIZE(PU,2),ILOOP
+ ELSE IF(LDEFCV2IND)THEN
+ WRITE(INUM,'(''ij(deb)-(fin)=('',I4,'','',I4,'')-('',I4,'','',I4,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &NIDEBCV,NJDEBCV,NIFINCV,NJFINCV,NLMAX,SIZE(PU,2),ILOOP
+ ENDIF
+ ELSE
+ IF(XIDEBCOU /= -999.)THEN
+ WRITE(INUM,'(''xidebcou'',F8.0,'' xjdebcou'',F8.0,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCOU,XJDEBCOU,NLMAX,NLANGLE,SIZE(PU,2),ILOOP
+ ELSE
+ WRITE(INUM,'(''nidebcou'',i4,'' njdebcou'',i4,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,SIZE(PU,2),ILOOP
+ ENDIF
+ ENDIF
+ ELSE
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2)THEN
+ WRITE(INUM,'(''cc(deb)-(fin)=('',F8.0,'','',F8.0,'')-('',F8.0,'','',F8.0,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCV,XJDEBCV,XIFINCV,XJFINCV,NLMAX,SIZE(PU,2),ILOOP
+ WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(INUM,'(''ll(deb)-(fin)=('',F8.3,'','',F8.3,'')-('',F8.3,'','',F8.3,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL,NLMAX,SIZE(PU,2),ILOOP
+ WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ELSE IF(LDEFCV2IND)THEN
+ WRITE(INUM,'(''ij(deb)-(fin)=('',I4,'','',I4,'')-('',I4,'','',I4,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &NIDEBCV,NJDEBCV,NIFINCV,NJFINCV,NLMAX,SIZE(PU,2),ILOOP
+ WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ENDIF
+ ELSE
+ IF(XIDEBCOU /= -999.)THEN
+ WRITE(INUM,'(''xidebcou'',F8.0,'' xjdebcou'',F8.0,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCOU,XJDEBCOU,NLMAX,NLANGLE,SIZE(PU,2),ILOOP
+ WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ELSE
+ WRITE(INUM,'(''nidebcou'',i4,'' njdebcou'',i4,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,SIZE(PU,2),ILOOP
+ WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ENDIF
+ ENDIF
+ ENDIF
+! JUin 2001 Ecriture des dates (Demande G.Jaubert ) si LPRDAT=T
+ IF(LPRDAT)THEN
+ IF(.NOT.ALLOCATED(XPRDAT))THEN
+ print *,'**IMCOUV XPRDAT NON ALLOUE.Dates non ecrites ds FICVAL .Prevenir J.Duron'
+ ELSE
+ WRITE(INUM,'(1X,75(1H*))')
+ WRITE(INUM,'(1X,'' Dates courante * modele * experience * segment'')')
+ WRITE(INUM,'(1X,'' J An M J Sec. * An M J Sec. * An M J Sec. * An M J Sec.'')')
+ WRITE(INUM,'(1X,75(1H*))')
+ DO J=1,SIZE(XPRDAT,2)
+ WRITE(INUM,'(1X,I3,1X,3(I4,I3,I3,I6,'' *''),I4,I3,I3,I6)')J,INT(XPRDAT(:,J))
+ ENDDO
+ ENDIF
+ ENDIF
+! JUin 2001 Ecriture des dates
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(.NOT.LDIRWIND)THEN
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ DO JLOOPI=1,ILOOP
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=5
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+5
+ ENDIF
+ IF(JLOOPI == ILOOP)THEN
+ IFIN=SIZE(PU,1)
+ ENDIF
+ IF(LPV)THEN
+ IDEB=NPROFILE;IFIN=NPROFILE
+ ENDIF
+
+ WRITE(INUM,'(1X,25(1H*),'' U Component '',41(1H*))')
+! WRITE(INUM,'(1X,79(1H*))')
+ WRITE(INUM,'('' K I-> '',I4,6X,4(6X,I4,6X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'(''.'',79(1H*))')
+ DO JLOOPJ=SIZE(PU,2),1,-1
+ WRITE(INUM,'(I4,1X,5(1X,E14.7))')JLOOPJ,(PU(II,JLOOPJ),II=IDEB,IFIN)
+! WRITE(INUM,'(I4,1X,5E15.8)')JLOOPJ,(PU(II,JLOOPJ),II=IDEB,IFIN)
+ ENDDO
+ WRITE(INUM,'(1X,79(1H*))')
+ ENDDO
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ DO JLOOPI=1,ILOOP
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=5
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+5
+ ENDIF
+ IF(JLOOPI == ILOOP)THEN
+ IFIN=SIZE(PU,1)
+ ENDIF
+ IF(LPV)THEN
+ IDEB=NPROFILE;IFIN=NPROFILE
+ ENDIF
+
+ WRITE(INUM,'(1X,25(1H*),'' V Component '',41(1H*))')
+! WRITE(INUM,'(1X,79(1H*))')
+ WRITE(INUM,'('' K I-> '',I4,6X,4(6X,I4,6X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'(''.'',79(1H*))')
+ DO JLOOPJ=SIZE(PW,2),1,-1
+ WRITE(INUM,'(I4,1X,5(1X,E14.7))')JLOOPJ,(PW(II,JLOOPJ),II=IDEB,IFIN)
+! WRITE(INUM,'(I4,1X,5E15.8)')JLOOPJ,(PW(II,JLOOPJ),II=IDEB,IFIN)
+ ENDDO
+ WRITE(INUM,'(1X,79(1H*))')
+ ENDDO
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ ENDIF
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF(LDIRWIND .OR. LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT)THEN
+ ZRAP=1
+ ISKIPX=NISKIPVX
+ ISKIPY=NISKIPVY
+ IF(LPV)THEN
+ ISKIPX=1
+ ENDIF
+ELSE
+! Dilatation de la composante W par ZRAP
+ IF(LDILW)THEN
+ ZRAP=((ZWR-ZWL)/(ZVR-ZVL))/((ZWT-ZWB)/(ZVT-ZVB))
+ ELSE
+ ZRAP=1
+ ENDIF
+ !ISKIPX=NISKIPVX
+ !ISKIPY=NISKIPVY
+ ISKIPX=NISKIP
+ ISKIPY=NISKIP
+ IF(LSTREAM)ISKIPY=1
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+if(nverbia <0)then
+ print *,' ***IMCOUV ZWR,ZWL,ZVR,ZVL,ZWT,ZWB,ZVT,ZVB,ZRAP '
+ print *,ZWR,ZWL,ZVR,ZVL,ZWT,ZWB,ZVT,ZVB,ZRAP
+endif
+! Determination egalement du min et max reels
+ZUMN=999.;ZUMX=-999.;ZWMN=999.;ZWMX=-999.;ZMN=999.;ZMX=-999.
+!print *,' IMCOUV NLMAX ',NLMAX,NISKIP
+
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+! Janvier 2001
+DO JKLOOP=IKB,IKE,ISKIPY
+
+ IF(LPV)THEN
+ JILOOPD=NPROFILE
+ JILOOPF=NPROFILE
+ ELSE
+ JILOOPD=1
+ JILOOPF=NLMAX
+ ENDIF
+ I=0
+
+ DO JILOOP=JILOOPD,JILOOPF,ISKIPX
+
+ IF(.NOT.LSTREAM)THEN
+ IF(XZWORKZ(JILOOP,JKLOOP) > XHMAX .OR. XZWORKZ(JILOOP,JKLOOP) < XHMIN)CYCLE
+ ENDIF
+ ZU=PU(JILOOP,JKLOOP)
+ ZW=PW(JILOOP,JKLOOP)
+ IF(ZU /= XSPVAL .AND. ZW /= XSPVAL)THEN
+ ZM=SQRT(ZU*ZU+ZW*ZW)
+!
+ IF(ZM.LT.ZMN)THEN
+ ZMN=ZM;ZUMN=ZU;ZWMN=ZW
+ ENDIF
+ IF(ZM.GT.ZMX)THEN
+ ZMX=ZM;ZUMX=ZU;ZWMX=ZW
+ ENDIF
+!
+
+ IF(LSTREAM .AND. NISKIP /= 1)THEN
+ I=I+1
+ if(nverbia <0)then
+ print *,' **JILOOP,NISKIP,I,ILMAX ',JILOOP,NISKIP,I,ILMAX
+ endif
+ ZZU(I,JKLOOP)=PU(JILOOP,JKLOOP)
+ ZZW(I,JKLOOP)=PW(JILOOP,JKLOOP)
+ IF((JILOOP == JILOOPF .OR. JILOOP > JILOOPF-ISKIPX)&
+ .AND. I /= ILMAX)THEN
+ I=I+1
+ if(nverbia <0)then
+ print *,' **JILOOP,JILOOPF,NISKIP,I,ILMAX ',JILOOP,JILOOPF,&
+ NISKIP,I,ILMAX
+ endif
+ ZZU(I,JKLOOP)=PU(JILOOP,JKLOOP)
+ ZZW(I,JKLOOP)=PW(JILOOP,JKLOOP)
+ EXIT
+ ENDIF
+
+ ELSE
+
+ ZZU(JILOOP,JKLOOP)=PU(JILOOP,JKLOOP)
+ if(nverbia <0)then
+ if(JKloop == IKB)THEN
+ print *,' ***IMCOUV PW ',PW(JILOOP,JKLOOP)
+ ENDIF
+ ENDIF
+
+ IF(.NOT.LSTREAM)THEN
+ ZZW(JILOOP,JKLOOP)=PW(JILOOP,JKLOOP)*ZRAP
+ ELSE
+ ZZW(JILOOP,JKLOOP)=PW(JILOOP,JKLOOP)
+ ENDIF
+
+ ENDIF
+ if(nverbia <0)then
+ if(JKloop == IKB)THEN
+ print *,' ***IMCOUV ZW ',ZZW(JILOOP,JKLOOP)
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+
+ENDDO
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!print *,' JILOOP,JKLOOP ',JILOOP,JKLOOP
+!print *,' ZRAP,ZMN,ZMX,ZUMN,ZWMN,ZUMX,ZWMX ',ZRAP,ZMN,ZMX,ZUMN,ZWMN,ZUMX,ZWMX
+!
+! 1.41 Topography
+!
+
+!print *,' **gsclip N2 1 '
+CALL GSCLIP(1)
+
+! Janvier 2001
+IF(.NOT. LPV)THEN
+! Janvier 2001
+IF(.NOT.LSUPER .OR. NSUPER == 1)THEN
+ ZDS(1)=XDS(1,NMGRID)
+ ZWZ(1)=XHMIN
+ DO JILOOP=2,NLMAX+1
+ ZDS(JILOOP)=XDS(JILOOP-1,NMGRID)
+ ZWZ(JILOOP)=XWZ(JILOOP-1,NMGRID)
+ ENDDO
+ ZDS(NLMAX+2)=ZDS(NLMAX+1)
+ ZWZ(NLMAX+2)=XHMIN
+ IF(ALLOCATED(ZDS2))THEN
+ DEALLOCATE(ZDS2)
+ ENDIF
+ IF(ALLOCATED(ZWZ2))THEN
+ DEALLOCATE(ZWZ2)
+ ENDIF
+ ALLOCATE(ZWZ2(NLMAX+2))
+ ALLOCATE(ZDS2(NLMAX+2))
+ ZDS2=ZDS(1:NLMAX+2)
+ ZWZ2=ZWZ(1:NLMAX+2)
+
+ CALL CURVE(ZDS2,ZWZ2,NLMAX+2)
+ CALL SFSETR('SP',.008)
+ CALL SFSETR('AN',45.)
+ CALL SFSETI('DO',0)
+ CALL SFWRLD(ZDS2,ZWZ2,NLMAX+2,ZRSCR,JPRSCR,ISCR,JPISCR)
+ENDIF
+! Janvier 2001
+ENDIF
+! Janvier 2001
+
+!print *,' **gsclip N3 0 '
+CALL GSCLIP(0)
+
+!
+! If required draw a model-level background
+!
+!
+IF(LXZ)THEN
+ DO JKLOOP=IKU,1,-1
+ IF(ZZU(1,JKLOOP) /= XSPVAL)EXIT
+ ENDDO
+ IKL=JKLOOP
+ CALL GSLN(3)
+ DO JKLOOP=1,IKL
+ ZYYY(1:NLMAX)=XZWORKZ(1:NLMAX,JKLOOP)
+ CALL GPL(NLMAX,XZZDS,ZYYY)
+ ENDDO
+ CALL GSLN(1)
+ENDIF
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!! Janvier 2001 + LDIRWIND
+IF(LDIRWIND)THEN
+ print *,' imcouv LDIRWIND ',LDIRWIND
+ IUB1=SIZE(PU,1)
+ ITERM=IUB1/ISKIPX+1
+ IF(1+(ITERM-1)*ISKIPX > IUB1)ITERM=ITERM-1
+ ITER=IUB1
+ ISKIPXM=ISKIPX
+ ISKIPX=1
+ IUB2=SIZE(PU,2)
+! 130101
+!!! Essai de conservation de 1 a IKU en Y (Pour LPRINT) mais
+!!! de 1 a NLMAX par pas de NISKIPX en X
+!!! JTER=(IUB2-IKB)/ISKIPY+1
+!!! IF(IKB+(JTER-1)*ISKIPY > IUB2)JTER=JTER-1
+ JTER=IUB2
+!!!
+ ALLOCATE(ZX(ITER,1),ZZY(ITER,JTER),ZYY(ITER,1),ZLAT(ITER,1),ZLON(ITER,1))
+ ALLOCATE(ZLA(ITER,JTER),ZLO(ITER,JTER),ZDIRU(ITER,JTER),ZDIRV(ITER,JTER))
+ ALLOCATE(ZZDS(ITER))
+! 130101
+! print *,' IIIIIMCOUV IUB1, ISKIPX, ITER, IUB2, ISKIPY, JTER,LPV ',IUB1,ISKIPX,ITER,IUB2,ISKIPY,JTER,LPV
+!!!
+!!! ZDIRU=PU(1:IUB1:ISKIPX,IKB:IUB2:ISKIPY)
+!!! ZDIRV=PW(1:IUB1:ISKIPX,IKB:IUB2:ISKIPY)
+ ZDIRU=XSPVAL
+ ZDIRV=XSPVAL
+ ZDIRU=PU(1:IUB1:ISKIPX,1:IUB2:1)
+ ZDIRV=PW(1:IUB1:ISKIPX,1:IUB2:1)
+!!!
+
+ ZZDS=XDS(1:IUB1:ISKIPX,1)
+
+! print *,' IIIIIMCOUV XDSX(1:IUB1) ',XDSX(1:IUB1,1)
+! print *,' IIIIIMCOUV ZX(:,1) ',ZX(:,1)
+
+! 130101
+ JJ=0
+
+!!!
+!!! DO JKLOOP=IKB,IUB2,ISKIPY
+ DO JKLOOP=1,IUB2
+!!!
+ JJ=JJ+1
+ II=0
+ DO JILOOP=1,IUB1,ISKIPX
+ II=II+1
+ ZZY(II,JJ)=XZWORKZ(JILOOP,JKLOOP)
+ ENDDO
+ ENDDO
+
+! 130101
+! print *,' IIIIMCOUV IUB1,ISKIPX,IKB,IUB2,ISKIPY ',IUB1,ISKIPX,IKB,IUB2
+! print *,' IIIIMCOUV XZWORKZ(1:NLMAX,IKB) ',XZWORKZ(1:NLMAX,IKB)
+! print *,' IIIIMCOUV ZZY(:,1) ',ZZY(:,1)
+! print *,' IIIIMCOUV XZWORKZ(1:NLMAX,IKB+1) ',XZWORKZ(1:NLMAX,IKB+1)
+! print *,' IIIIMCOUV ZZY(:,2) ',ZZY(:,2)
+
+! 130101
+ ZX(:,1)=XDSX(1:IUB1:ISKIPX,1)
+ ZYY(:,1)=XDSY(1:IUB1:ISKIPX,1)
+
+ DO JKLOOP=1,JTER
+ CALL SM_LATLON_A(XLATORI,XLONORI,ZX,ZYY,ZLAT,ZLON)
+ ZLA(:,JKLOOP)=ZLAT(:,1)
+ ZLO(:,JKLOOP)=ZLON(:,1)
+ ENDDO
+
+ where(zdiru /= xspval .AND. zdirv /= xspval)
+ ZDIRU=ATAN2(ZDIRV,ZDIRU)*180./ACOS(-1.)
+ endwhere
+
+ if(nverbia > 0)then
+ print *,' ZDIRU 1,1 ITER/2,1 1,JTER/2 ITER/2,JTER/2 ITER,JTER '
+ print *,ZDIRU(1,1), ZDIRU(ITER/2,1), ZDIRU(1,JTER/2), ZDIRU(ITER/2,JTER/2), &
+ ZDIRU(ITER,JTER)
+ endif
+
+ ZRPK=XRPK
+ ZBETA=XBETA
+ ZLON0=XLON0
+ where(zdiru /= xspval .AND. zdirv /= xspval)
+ ZDIRU=ZDIRU - (ZRPK*(ZLO-ZLON0)-ZBETA) + 90.
+ endwhere
+ WHERE(ZDIRU < 0.)ZDIRU=ZDIRU+360.
+ WHERE(ZDIRU > 360. .AND. ZDIRU /= XSPVAL)ZDIRU=ZDIRU-360.
+
+ if(nverbia > 0)then
+ print *,' ZDIRU 1,1 ITER/2,1 1,JTER/2 ITER/2,JTER/2 ITER,JTER '
+ print *,ZDIRU(1,1), ZDIRU(ITER/2,1), ZDIRU(1,JTER/2), ZDIRU(ITER/2,JTER/2), &
+ ZDIRU(ITER,JTER)
+ endif
+
+ where(zdiru /= xspval .AND. zdirv /= xspval)
+ ZDIRV=360.-ZDIRU
+ elsewhere
+ ZDIRV=XSPVAL
+ endwhere
+
+ if(nverbia > 0)then
+ print *,' ZDIRV 1,1 ITER/2,1 1,JTER/2 ITER/2,JTER/2 ITER,JTER '
+ print *,ZDIRV(1,1), ZDIRV(ITER/2,1), ZDIRV(1,JTER/2), ZDIRV(ITER/2,JTER/2), &
+ ZDIRV(ITER,JTER)
+ endif
+
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+
+ if(nverbia <0)then
+ print *,' ** imcouv ap getset ZWL,ZWR,XDS(1,1),XDS(NLMAX,1),ZX(1,1),ZX(ITER,1) ',ZWL,ZWR,XDS(1,1),XDS(NLMAX,1),ZX(1,1),ZX(ITER,1)
+ endif
+ IF(ITERM > 6)THEN
+ CALL GSCLIP(1)
+ ELSE
+ CALL GSCLIP(0)
+ ENDIF
+
+ CALL TABCOL_FORDIACHRO
+
+ IJ=1
+ DO J=15,345,30
+ IJ=IJ+1
+ ZCOL(IJ)=J
+ ENDDO
+ ZCOL(1)=0.
+ IJ=IJ+1
+ ZCOL(IJ)=360.
+
+ ICOL(1)=4; ICOL(13)=4; ICOL(2)=88; ICOL(3)=79; ICOL(4)=7
+ ICOL(5)=52; ICOL(6)=25; ICOL(7)=2; ICOL(8)=20; ICOL(9)=24
+ ICOL(10)=3; ICOL(11)=124; ICOL(12)=5; ICOL(13)=4
+
+ IF(LPV)THEN
+ JILOOPD=NPROFILE
+ JILOOPF=NPROFILE
+ ELSE
+ JILOOPD=1
+ JILOOPF=ITER
+ ENDIF
+
+!!!
+!!! DO JKLOOP=1,JTER
+ DO JKLOOP=IKB,JTER,ISKIPY
+!!!
+
+ DO JILOOP=JILOOPD,JILOOPF,ISKIPXM
+! DO JILOOP=JILOOPD,JILOOPF
+
+ IF(ZDIRV(JILOOP,JKLOOP) == XSPVAL)THEN
+! print *,J,' CYCLE ',ZDIRV(JILOOP,JKLOOP),ZCOL(J),ZCOL(J-1)
+ CYCLE
+ ENDIF
+
+ DO J=2,IJ
+! print *,J,' ',ZDIRV(JILOOP,JKLOOP),ZCOL(J),ZCOL(J-1)
+
+ IF(ZDIRV(JILOOP,JKLOOP) == 0. .OR. ZDIRV(JILOOP,JKLOOP) == 360.)THEN
+ CALL GSPMCI(ICOL(1))
+! print *,' ZDIRV(JILOOP,JKLOOP) J+2 ',ZDIRV(JILOOP,JKLOOP),ICOL(1)
+ EXIT
+ ELSE IF(ZDIRV(JILOOP,JKLOOP) < ZCOL(J).AND. &
+ ZDIRV(JILOOP,JKLOOP) >= ZCOL(J-1))THEN
+ CALL GSPMCI(ICOL(J-1))
+! print *,' ZDIRV(JILOOP,JKLOOP) J+1 ',ZDIRV(JILOOP,JKLOOP),ICOL(J)
+ EXIT
+ ENDIF
+ ENDDO
+
+ CALL GSMK(2)
+
+!!! Janvier 2001
+ IF(LPV)THEN
+ ZINTX=(ZWL+ZWR)/2
+ ELSE
+ ZINTX=ZZDS(JILOOP)
+ ENDIF
+
+ ZINTY=ZZY(JILOOP,JKLOOP)
+ IF(ZINTY > XHMAX .OR. ZINTY <XHMIN)THEN
+ CYCLE
+ ENDIF
+
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(3)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(5)
+ CALL GPM(1,ZINTX,ZINTY)
+
+ ENDDO
+ CALL SFLUSH
+
+ ENDDO
+
+!print *,' **gsclip N4 0 '
+ CALL GSCLIP(0)
+
+! Legende couleurs
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZVL,ZVR,ZVB,ZVT,1)
+ ZVINT=(ZVT-ZVB)/12.
+ ZVY=ZVB
+ YTE=' '
+ WRITE(YTE,'(F4.0)')ZCOL(1)
+ CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
+! print *,'ZVR,ZVY,YTE ',ZVR,ZVY,YTE
+ DO J=1,6
+ CALL GSPMCI(ICOL(1))
+ ZINTX=ZVR+.005*J
+ ZINTY=ZVY+.015
+ CALL GSMK(2)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(3)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(5)
+ CALL GPM(1,ZINTX,ZINTY)
+ ENDDO
+ ZVY=ZVY+ZVINT/2.
+ YTE=' '
+ WRITE(YTE,'(F4.0)')ZCOL(2)
+ CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
+! print *,'ZVR,ZVY,YTE ',ZVR,ZVY,YTE
+ DO J=1,6
+ CALL GSPMCI(ICOL(2))
+ ZINTX=ZVR+.005*J
+ ZINTY=ZVY+.015
+ CALL GSMK(2)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(3)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(5)
+ CALL GPM(1,ZINTX,ZINTY)
+ ENDDO
+ DO J=3,13
+ ZVY=ZVY+ZVINT
+ YTE=' '
+ WRITE(YTE,'(F4.0)')ZCOL(J)
+ CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
+! print *,'ZVR,ZVY,YTE ',ZVR,ZVY,YTE
+ DO JA=1,6
+ CALL GSPMCI(ICOL(J))
+ ZINTX=ZVR+.005*JA
+ ZINTY=ZVY+.015
+ CALL GSMK(2)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(3)
+ CALL GPM(1,ZINTX,ZINTY)
+ CALL GSMK(5)
+ CALL GPM(1,ZINTX,ZINTY)
+ ENDDO
+ ENDDO
+ ZVY=ZVY+ZVINT/2.
+ YTE=' '
+ WRITE(YTE,'(F4.0)')ZCOL(14)
+ CALL PLCHHQ(ZVR+.0002,ZVY,YTE,.012,0.,-1.)
+
+ IF(LPRINT)THEN
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ DO JLOOPI=1,ILOOP
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=5
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+5
+ ENDIF
+ IF(JLOOPI == ILOOP)THEN
+ IFIN=SIZE(PU,1)
+ ENDIF
+ IF(LPV)THEN
+ IDEB=NPROFILE;IFIN=NPROFILE
+ ENDIF
+
+ WRITE(INUM,'(1X,79(1H*))')
+ WRITE(INUM,'('' K I-> '',I4,6X,4(6X,I4,6X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'(''.'',79(1H*))')
+ DO JLOOPJ=SIZE(ZDIRV,2),1,-1
+ WRITE(INUM,'(I4,1X,5(1X,E14.7))')JLOOPJ,(ZDIRV(II,JLOOPJ),II=IDEB,IFIN)
+ ! WRITE(INUM,'(I4,1X,5E15.8)')JLOOPJ,(ZDIRV(II,JLOOPJ),II=IDEB,IFIN)
+ ENDDO
+ WRITE(INUM,'(1X,79(1H*))')
+ ENDDO
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ ENDIF
+
+!print *,' **gsclip N5 0 '
+ CALL GSCLIP(0)
+ DEALLOCATE(ZX,ZZY,ZYY,ZLAT,ZLON,ZLA,ZLO,ZDIRU,ZDIRV,ZZDS)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ELSE
+!!!! Janvier 2001 + LDIRWIND
+
+IF (.NOT.LSTREAM)THEN
+!
+!
+!* 1.5 Routine VVUMXY of provided by TRACE to locate and scale wind
+!* arrows on the display
+!
+CALL VVSETI('MAP',4)
+CALL VVSETI('SET',0)
+CALL VVSETR('VPL',ZVL)
+CALL VVSETR('VPR',ZVR)
+CALL VVSETR('VPB',ZVB)
+CALL VVSETR('VPT',ZVT)
+CALL VVSETR('WDL',ZWL)
+CALL VVSETR('WDR',ZWR)
+CALL VVSETR('WDB',ZWB)
+CALL VVSETR('WDT',ZWT)
+
+! Sortie de statistiques si LVST=T
+IF(LVST)THEN
+ CALL VVSETI('VST',1)
+ELSE
+ CALL VVSETI('VST',0)
+ENDIF
+
+CALL VVSETR('AMX',XAMX)
+CALL VVSETR('VHC',XVHC)
+CALL VVSETR('VRL',XVRL)
+CALL VVSETR('VLC',XVLC)
+
+IF(XVHC < 0. )THEN
+ CALL VVSETC('MXT',' ')
+ CALL VVSETC('MXT','Scale')
+END IF
+
+! Elimination de la legende des fleches si LEGVECT=F
+IF(.NOT.LEGVECT)THEN
+ CALL VVSETC('MXT',' ')
+ CALL VVSETC('MNT',' ')
+ENDIF
+
+! Janv 2001 Si XVHC <0 (Scale) conservation tout de meme des valeurs > xvhc
+! Intervention ds vvectr rajoute a frame (12/1/2001 je n'ai pas fait gd chose
+! Besoin peut-etre de reintervenir)
+IF(XVHC >= 0.)THEN
+ GVSUPSCA=LVSUPSCA
+ LVSUPSCA=.FALSE.
+ENDIF
+!
+!* 1.6 Masks vectors where wind coponents have XSPVAL values
+!
+CALL VVSETI('SVF',3)
+CALL VVSETR('USV',XSPVAL)
+CALL VVSETR('VSV',XSPVAL)
+!
+!* 1.6 Selects look and feel options for the vector display
+! (Text strings, etc..)
+!
+CALL VVSETI('MNP',-4)
+CALL VVSETI('MXP',-4)
+CALL VVSETR('MNX',.75)
+!CALL VVSETR('MNX',-ZVL)
+
+IF(ZVB <= .15)THEN
+ ZY=(-.08)/(ZVT-ZVB)
+ELSE
+ ZY=(-.13)/(ZVT-ZVB)
+ENDIF
+
+CALL VVSETR('MNY',ZY)
+
+IF(ZVR-ZVL >= .78)THEN
+ CALL VVSETR('MXX',.75+.16)
+ELSE
+ CALL VVSETR('MXX',.75+.27)
+ENDIF
+
+CALL VVSETR('MXY',ZY)
+CALL VVSETR('MXS',.008*.9/(ZVR-ZVL))
+CALL VVSETR('MNS',.008*.9/(ZVR-ZVL))
+!
+!* 1.7 Draws the arrows
+!
+IF(XLWV > 0.)THEN
+ CALL VVSETR('LWD',XLWV)
+ELSE
+ CALL VVSETR('LWD',XLWVDEF)
+ENDIF
+
+!print *,' **gsclip N6 0 '
+CALL GSCLIP(0) ! Clipping off
+CALL VVSETI('VPO',1)
+CALL VVINIT(ZZU,NLMAX,ZZW,NLMAX,0.,0,NLMAX,IKU,0.,0) ! Initializes VVECTR
+CALL VVECTR(ZZU,ZZW,0.,0,0,0.) ! Draws arrows
+!print *,' **gsclip N7 1 '
+CALL GSCLIP(1) ! Clipping back on
+!
+CALL VVRSET
+
+!!!! Janvier 2001 + LDIRWIND
+IF(XVHC >= 0.)THEN
+ LVSUPSCA=GVSUPSCA
+ENDIF
+
+!!!!!!!!!!!!!!!!!!!!STREAM
+ELSE
+
+ NSGD=1
+ IF(LINTERPOLSTR)THEN
+!! Avec interpol en Z
+ IF(NISKIP /= 1)THEN
+ ALLOCATE(ZSTR1(4*ILMAX*NZSTR))
+ ALLOCATE(ZSTRU(ILMAX,NZSTR))
+ ALLOCATE(ZSTRW(ILMAX,NZSTR))
+ ELSE
+ ALLOCATE(ZSTR1(4*NLMAX*NZSTR))
+ ALLOCATE(ZSTRU(NLMAX,NZSTR))
+ ALLOCATE(ZSTRW(NLMAX,NZSTR))
+ ENDIF
+ ZSTR1=0.
+if(nverbia >0)then
+ print *,' Appel interpolw '
+ endif
+
+ CALL INTERPOLW(ZZU,ZZW,ZSTRU,ZSTRW)
+ if(nverbia >0)then
+ print *,' Apres Appel interpolw '
+ endif
+!! Avec interpol en Z
+
+ ELSE
+
+ IF(NISKIP /= 1)THEN
+ ALLOCATE(ZSTR1(4*ILMAX*IKU))
+ ELSE
+ ALLOCATE(ZSTR1(4*NLMAX*IKU))
+ ENDIF
+ ZSTR1=0.
+!! Recherche d'un seuil pour choisir la frequence de depart
+!! d'1 streamline
+ IU1=MAX(JPHEXT+1,2); JU1=MAX(JPVEXT+1,2)
+ JU2=(NINY-JPVEXT)
+ ZT=XZWORKZ(IU1,JU2)-XZWORKZ(IU1,JU1)
+ DO J=1+JPVEXT+1,NINY-JPVEXT
+
+ ZRA= (XZWORKZ(IU1,J)-XZWORKZ(IU1,J-1))/(ZT)
+ IF(ZRA >= .05)THEN
+ NSGD=2
+ NSEUIL=J
+ ISEUIL=NSEUIL
+ if(nverbia <0)then
+ print *, '** imcouv RAP NSEUIL ',ZRA,NSEUIL
+ endif
+ EXIT
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+ CALL STSETI('MAP',4)
+! CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ if(nverbia > 0)then
+ print *,' **imcouv ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT,NINX,NINY
+ print *,' **imcouv ap getset ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT,NINX,NINY
+ endif
+ CALL STSETI('SET',0)
+ CALL STSETR('VPL',ZVL)
+ CALL STSETR('VPR',ZVR)
+ CALL STSETR('VPB',ZVB)
+ CALL STSETR('VPT',ZVT)
+ CALL STSETR('WDL',ZWL)
+ CALL STSETR('WDR',ZWR)
+ CALL STSETR('WDB',ZWB)
+ CALL STSETR('WDT',ZWT)
+ if(nverbia > 0)then
+ print *,' **imcouv ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT
+ endif
+
+ CALL STSETR('GBS',0.)
+! CALL STSETI('AGD',2)
+! pour suppression de la fleche de depart d'1 streamline
+! CALL STSETR('AMD',.005)
+ CALL STSETI('AGD',NARSTR)
+! defaut AGD=4
+ CALL STSETI('SGD',2)
+ CALL STSETI('CPM',0)
+ CALL STSETI('TRT',0)
+ CALL STSETI('TRP',0)
+ CALL STSETI('CKX',1)
+! CALL STSETI('CKP',30)
+ CALL STSETR('ARL',XARLSTR)
+! defaut ARL=.009
+ CALL STSETR('DFM',.02)
+ CALL STSETR('CDS',2.)
+ CALL STSETR('LWD',XLWSTR)
+! defaut LWD=1
+ IF(LVERT)THEN
+ CALL STSETR('SSP',XSSP)
+! defaut SSP=.004
+ ELSE
+ CALL STSETR('SSP',XSSP)
+ ENDIF
+ CALL STSETI('MSK',0)
+ CALL STSETI('SVF',3)
+ CALL STSETR('USV',XSPVAL)
+ CALL STSETR('VSV',XSPVAL)
+
+ IF(LINTERPOLSTR)THEN
+!! Avec interpol en Z
+ ZSTRW=ZSTRW*ZRAP
+ IF(NISKIP /= 1)THEN
+ IZS=4*NZSTR*ILMAX
+ CALL STINIT(ZSTRU,ILMAX,ZSTRW,ILMAX,0.,0,ILMAX,NZSTR,ZSTR1,IZS) !
+ ELSE
+ IZS=4*NZSTR*NLMAX
+ CALL STINIT(ZSTRU,NLMAX,ZSTRW,NLMAX,0.,0,NLMAX,NZSTR,ZSTR1,IZS) !
+ ENDIF
+ CALL GQPLCI(IER,ICOL1)
+ CALL GSPLCI(NCOLUVG)
+ CALL STREAM(ZSTRU,ZSTRW,0.,0,0.,ZSTR1) ! Draws arrows
+! print *,' **incouv AP STREAM '
+
+ ELSE
+
+!print *,' **gsclip N8 0 '
+ CALL GSCLIP(0) ! NO Clipping
+ IF(NISKIP /= 1)THEN
+ IZS=4*IKU*ILMAX
+ ELSE
+ IZS=4*IKU*NLMAX
+ ENDIF
+ ZZW=ZZW*ZRAP
+ IF(NSGD == 2)THEN
+ IF(NISKIP /= 1)THEN
+ CALL STINIT(ZZU,ILMAX,ZZW,ILMAX,0.,0,ILMAX,IKU,ZSTR1,IZS) ! Initializes VVECTR
+ ELSE
+ CALL STINIT(ZZU,NLMAX,ZZW,NLMAX,0.,0,NLMAX,IKU,ZSTR1,IZS) ! Initializes VVECTR
+ ENDIF
+ CALL GQPLCI(IER,ICOL1)
+ CALL GSPLCI(NCOLUVG)
+ CALL STREAM(ZZU,ZZW,0.,0,0.,ZSTR1) ! Draws arrows
+! CALL STREAM(ZZU,ZZW,0.,0,STUMXY,ZSTR1) ! Draws arrows
+ ELSE
+ IF(NISKIP /= 1)THEN
+ CALL STINIT(ZZU,ILMAX,ZZW,ILMAX,0.,0,ILMAX,IKU,ZSTR1,IZS) ! Initializes VVECTR
+ ELSE
+ CALL STINIT(ZZU,NLMAX,ZZW,NLMAX,0.,0,NLMAX,IKU,ZSTR1,IZS) ! Initializes VVECTR
+ ENDIF
+ CALL GQPLCI(IER,ICOL1)
+ CALL GSPLCI(NCOLUVG)
+ CALL STREAM(ZZU,ZZW,0.,0,0.,ZSTR1) ! Draws arrows
+! CALL STREAM(ZZU,ZZW,0.,0,STUMXY,ZSTR1) ! Draws arrows
+ ENDIF
+ IF(NSGD == 2)THEN
+! ZSTR1=0.
+ CALL STSETI('SGD',1)
+ NSEUIL=ISEUIL
+! ZSTR1=0.
+ IF(NISKIP /= 1)THEN
+ CALL STINIT(ZZU,ILMAX,ZZW,ILMAX,0.,0,ILMAX,IKU,ZSTR1,IZS) ! Initializes VVECTR
+ ELSE
+ CALL STINIT(ZZU,NLMAX,ZZW,NLMAX,0.,0,NLMAX,IKU,ZSTR1,IZS) ! Initializes VVECTR
+ ENDIF
+ CALL GQPLCI(IER,ICOL1)
+ CALL GSPLCI(NCOLUVG)
+ CALL STREAM(ZZU,ZZW,0.,0,0.,ZSTR1) ! Draws arrows
+! CALL STREAM(ZZU,ZZW,0.,0,STUMXY,ZSTR1) ! Draws arrows
+ ENDIF
+
+ ENDIF
+
+ DEALLOCATE(ZSTR1)
+ IF(LINTERPOLSTR)THEN
+ DEALLOCATE(ZSTRU)
+ DEALLOCATE(ZSTRW)
+ ENDIF
+!print *,' **gsclip N9 1 '
+CALL GSCLIP(1) ! Clipping back on
+ CALL STRSET
+ CALL GSPLCI(ICOL1)
+ENDIF
+!!!!!!!!!!!!!!!!!!!!STREAM
+
+ENDIF
+!!!! Janvier 2001 + LDIRWIND
+IF(LPRINTXY .AND..NOT.LULMWM .AND..NOT.LULTWT)THEN
+ !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ ILOOP=SIZE(PU,1)/5
+ IF(ILOOP * 5 < SIZE(PU,1))ILOOP=ILOOP+1
+ IF(LPV)ILOOP=1
+
+ IF(.NOT. LPVT)THEN
+
+ IF(.NOT.LPV)THEN
+ WRITE(INUM,'(''CV XZ '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'','' (1-NLMAX,1-IKU)'')')CGROUP, &
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ ELSE
+ WRITE(INUM,'(''PV XZ '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'','' (NPROFILE,1-IKU)'')')CGROUP, &
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ ENDIF
+ ELSE
+ WRITE(INUM,'(''CV TIMEZ '','' G:'',A16,'' P:'',A40)')CGROUP, &
+!& CTITGAL
+& CTITRE(NLOOPP)(1:40)
+ ENDIF
+ IF(LMINUS .OR. LPLUS)THEN
+ WRITE(INUM,'(A70)')CTITB3
+ ELSE
+ WRITE(INUM,'(A40)')CTITGAL
+ ENDIF
+ IF(.NOT. LPVT)THEN
+ IF(.NOT.LCARTESIAN)THEN
+ ALLOCATE(ZLAB(NLMAX),ZLOB(NLMAX))
+ DO J=1,NLMAX
+ ZXB=XDSX(J,NMGRID)
+ ZYB=XDSY(J,NMGRID)
+ CALL SM_LATLON_S(XLATORI,XLONORI,ZXB,ZYB,ZLATB,ZLONB)
+ ZLAB(J)=ZLATB
+ ZLOB(J)=ZLONB
+ ENDDO
+ IF(LDEFCV2LL)THEN
+ ZLAB(1)=XIDEBCVLL
+ ZLOB(1)=XJDEBCVLL
+ ENDIF
+ if(nverbia > 0)then
+! print *,' ZLA'
+! print *,ZLA
+! print *,' ZLO'
+! print *,ZLO
+ endif
+ ENDIF
+
+ IF(.NOT.LPV)THEN
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2)THEN
+ WRITE(INUM,'(''cc(deb)-(fin)=('',F8.0,'','',F8.0,'')-('',F8.0,'','',F8.0,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCV,XJDEBCV,XIFINCV,XJFINCV,NLMAX,SIZE(PU,2),ILOOP
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(INUM,'(''ll(deb)-(fin)=('',F8.3,'','',F8.3,'')-('',F8.3,'','',F8.3,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL,NLMAX,SIZE(PU,2),ILOOP
+ ELSE IF(LDEFCV2IND)THEN
+ WRITE(INUM,'(''ij(deb)-(fin)=('',I4,'','',I4,'')-('',I4,'','',I4,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &NIDEBCV,NJDEBCV,NIFINCV,NJFINCV,NLMAX,SIZE(PU,2),ILOOP
+ ENDIF
+ ELSE
+ IF(XIDEBCOU /= -999.)THEN
+ WRITE(INUM,'(''xidebcou'',F8.0,'' xjdebcou'',F8.0,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCOU,XJDEBCOU,NLMAX,NLANGLE,SIZE(PU,2),ILOOP
+ ELSE
+ WRITE(INUM,'(''nidebcou'',i4,'' njdebcou'',i4,'' nlmax'',i5,'' nlangle'',i4, &
+ & '' iku'',i4,'' iter'',i3)') &
+ & NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,SIZE(PU,2),ILOOP
+ ENDIF
+ ENDIF
+ ELSE
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2)THEN
+ WRITE(INUM,'(''cc(deb)-(fin)=('',F8.0,'','',F8.0,'')-('',F8.0,'','',F8.0,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCV,XJDEBCV,XIFINCV,XJFINCV,NLMAX,SIZE(PU,2),ILOOP
+ WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(INUM,'(''ll(deb)-(fin)=('',F8.3,'','',F8.3,'')-('',F8.3,'','',F8.3,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL,NLMAX,SIZE(PU,2),ILOOP
+ WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ELSE IF(LDEFCV2IND)THEN
+ WRITE(INUM,'(''ij(deb)-(fin)=('',I4,'','',I4,'')-('',I4,'','',I4,'')'','' nlmax'',i5,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &NIDEBCV,NJDEBCV,NIFINCV,NJFINCV,NLMAX,SIZE(PU,2),ILOOP
+ WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ENDIF
+ ELSE
+ IF(XIDEBCOU /= -999.)THEN
+ WRITE(INUM,'(''xidebcou'',F8.0,'' xjdebcou'',F8.0,'' nlmax'',i5,'' nlangle'',i4,&
+ &'' iku'',i4,'' iter'',i3)')&
+ &XIDEBCOU,XJDEBCOU,NLMAX,NLANGLE,SIZE(PU,2),ILOOP
+ WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ELSE
+ WRITE(INUM,'(''nidebcou'',i4,'' njdebcou'',i4,'' nlmax'',i5,'' nlangle'',i4, &
+ & '' iku'',i4,'' iter'',i3)') &
+ & NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,SIZE(PU,2),ILOOP
+ WRITE(INUM,'(''nprofile='',I4)')NPROFILE
+ ENDIF
+ ENDIF
+ ENDIF
+
+ IF(LCARTESIAN)THEN
+ WRITE(INUM,'(1X,41(1H*))')
+ WRITE(INUM,'(18X,''X'',12X,''RELIEF'')')
+ WRITE(INUM,'(1X,41(1H*))')
+ DO JLOOPI=1,NLMAX
+ IF(JLOOPI == 1)THEN
+ WRITE(INUM,'('' 1 '',I5,2(1X,E15.8))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ XWZ(JLOOPI,NMGRID)
+ ELSE IF(JLOOPI == NLMAX)THEN
+ WRITE(INUM,'(''NLMAX'',I5,2(1X,E15.8))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ XWZ(JLOOPI,NMGRID)
+ ELSE
+ WRITE(INUM,'('' '',I5,2(1X,E15.8))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ XWZ(JLOOPI,NMGRID)
+ ENDIF
+ ENDDO
+ WRITE(INUM,'(1X,41(1H*))')
+ ELSE
+ WRITE(INUM,'(1X,66(1H*))')
+ WRITE(INUM,'(18X,''X'',12X,''RELIEF'',11X,''LAT'',10X,''LONG'')')
+ WRITE(INUM,'(1X,66(1H*))')
+ DO JLOOPI=1,NLMAX
+ IF(JLOOPI == 1)THEN
+ WRITE(INUM,'('' 1 '',I5,2(1X,E15.8),2(2X,F10.5))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ XWZ(JLOOPI,NMGRID),ZLAB(JLOOPI),ZLOB(JLOOPI)
+ ELSE IF(JLOOPI == NLMAX)THEN
+ WRITE(INUM,'(''NLMAX'',I5,2(1X,E15.8),2(2X,F10.5))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ XWZ(JLOOPI,NMGRID),ZLAB(JLOOPI),ZLOB(JLOOPI)
+ ELSE
+ WRITE(INUM,'('' '',I5,2(1X,E15.8),2(2X,F10.5))')JLOOPI,XDS(JLOOPI,NMGRID), &
+ XWZ(JLOOPI,NMGRID),ZLAB(JLOOPI),ZLOB(JLOOPI)
+ ENDIF
+ ENDDO
+ WRITE(INUM,'(1X,66(1H*))')
+ DEALLOCATE(ZLAB,ZLOB)
+ ENDIF
+
+ DO JLOOPI=1,ILOOP
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=5
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+5
+ ENDIF
+ IF(JLOOPI == ILOOP)THEN
+ IFIN=SIZE(PU,1)
+ ENDIF
+ IF(LPV)THEN
+ IDEB=NPROFILE; IFIN=NPROFILE
+ ENDIF
+
+ IF(LPV)THEN
+ WRITE(INUM,'(''ALTITUDES (NPROFILE,1-IKU)'')')
+ ELSE
+ WRITE(INUM,'(''ALTITUDES (1-NLMAX,1-IKU)'')')
+ ENDIF
+ WRITE(INUM,'(1X,79(1H*))')
+ WRITE(INUM,'('' K X-> '',I4,6X,4(6X,I4,6X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'(''.'',79(1H*))')
+ DO JLOOPJ=SIZE(PU,2),1,-1
+ WRITE(INUM,'(I4,1X,5(1X,E14.7))')JLOOPJ,(XZWORKZ(II,JLOOPJ),II=IDEB,IFIN)
+! WRITE(INUM,'(I4,1X,5(1X,E14.7))')JLOOPJ,(XWORKZ(II,JLOOPJ,NMGRID),II=IDEB,IFIN)
+! WRITE(INUM,'(I4,1X,5E15.8)')JLOOPJ,(XWORKZ(II,JLOOPJ,NMGRID),II=IDEB,IFIN)
+ ENDDO
+ WRITE(INUM,'(1X,79(1H*))')
+ ENDDO
+
+ ENDIF
+
+! ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ENDIF
+!!!! Janvier 2001 + LDIRWIND
+!------------------------------------------------------------------------------
+!
+!* 2. COMPLETING THE PLOT
+! -------------------
+!
+!* 2.1 Page information labels
+!
+
+!print *,' **gsclip N10 0 '
+CALL GSCLIP(0)
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+XCURVPTL=ZVL;XCURVPTR=ZVR;XCURVPTB=ZVB;XCURVPTT=ZVT
+!print *,' getset ',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+!
+IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN
+
+!
+! Titres en X
+!
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(XSZTITXL /= 0.)THEN
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/2.,.05),YTEM,XSZTITXL,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/2.,YTEM,XSZTITXL,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(XSZTITXM /= 0.)THEN
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),XSZTITXM,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),XSZTITXM,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/2.,ZVB/2.,YTEM,XSZTITXM,0.,-1.)
+ ELSE
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(XSZTITXR /= 0.)THEN
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/2.,.05),YTEM,XSZTITXR,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,XSZTITXR,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+!
+! Titres en Y
+!
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYM',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYT',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYB',ZVL,ZVR,ZVB,ZVT,YTEM)
+
+CALL RESOLV_TIT('CTITB1',HLEGEND)
+ZXPOSTITB1=.002
+ZXYPOSTITB1=.005
+IF(XPOSTITB1 /= 0.)THEN
+ ZXPOSTITB1=XPOSTITB1
+ENDIF
+IF(XYPOSTITB1 /= 0.)THEN
+ ZXYPOSTITB1=XYPOSTITB1
+ENDIF
+
+IF(HLEGEND /= ' ')THEN
+ IF(XSZTITB1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HLEGEND,XSZTITB1,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,HLEGEND,XSZTITB1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HLEGEND,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,HLEGEND,.007,0.,-1.)
+ ENDIF
+ENDIF
+CALL RESOLV_TIT('CTITB2',CLEGEND2)
+ZXPOSTITB2=.002
+ZXYPOSTITB2=.025
+IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ENDIF
+IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ENDIF
+IF(CLEGEND2 /= ' ')THEN
+ IF(XSZTITB2 /= 0.)THEN
+ CALL PLCHHQ(0.002,0.025,CLEGEND2,XSZTITB2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
+ ENDIF
+ENDIF
+YTEM(1:LEN(YTEM))=' '
+CALL RESOLV_TIT('CTITB3',YTEM)
+ZXPOSTITB3=.002
+ZXYPOSTITB3=.0450
+IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ENDIF
+IF(XYPOSTITB3 /= 0.)THEN
+ ZXYPOSTITB3=XYPOSTITB3
+ENDIF
+IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,XSZTITB3,0.,-1.)
+! CALL PLCHHQ(0.002,0.050,YTEM,XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,.009,0.,-1.)
+! CALL PLCHHQ(0.002,0.050,YTEM,.009,0.,-1.)
+ ENDIF
+ENDIF
+ IF(XIDEBCOU.NE.-999.)THEN
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2IND)THEN
+ WRITE(YCARCOU,1018)NIDEBCV,NJDEBCV,NIFINCV,NJFINCV
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(YCARCOU,1019)XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL
+ ELSE
+ WRITE(YCARCOU,1020)XIDEBCV,XJDEBCV,XIFINCV,XJFINCV
+ ENDIF
+ ELSE
+ IF(XIDEBCOU < 99999.)THEN
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1001)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ ELSE
+ WRITE(YCARCOU,1002)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ END IF
+ ELSE
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1003)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ ELSE
+ WRITE(YCARCOU,1004)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ END IF
+ END IF
+ END IF
+ ELSE
+ WRITE(YCARCOU,1000)NIDEBCOU,NJDEBCOU,NLANGLE,NLMAX
+ END IF
+! Janvier 2001
+ IF(LPV)THEN
+ YCAR(1:LEN(YCAR))=' '
+ WRITE(YCAR,1006)NPROFILE
+ ENDIF
+! Janvier 2001
+CALL RESOLV_TIT('CTITT1',YCARCOU)
+ZXPOSTITT1=.002
+ZXYPOSTITT1=.98
+IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ENDIF
+IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ENDIF
+IF(YCARCOU /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,.012,0.,-1.)
+ ENDIF
+ENDIF
+YTEM(1:LEN(YTEM))=' '
+CALL RESOLV_TIT('CTITT2',YTEM)
+ZXPOSTITT2=.002
+ZXYPOSTITT2=.95
+IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ENDIF
+IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ENDIF
+IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
+ ENDIF
+! Janvier 2001
+ELSE
+ IF(LPV)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCAR,.008,0.,-1.)
+ ENDIF
+ENDIF
+YTEM(1:LEN(YTEM))=' '
+CALL RESOLV_TIT('CTITT3',YTEM)
+ZXPOSTITT3=.002
+ZXYPOSTITT3=.93
+IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ENDIF
+IF(XYPOSTITT3 /= 0.)THEN
+ ZXYPOSTITT3=XYPOSTITT3
+ENDIF
+IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,XSZTITT3,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,.008,0.,-1.)
+ ENDIF
+ENDIF
+IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ENDIF
+
+! 15 SEPT 2000 Je mets NSUPER a la place de NSUPER
+ IF(NSUPER == 1)THEN
+ CALL RESOLV_TIT('CTITVAR1',HTEXT)
+ ELSE IF(NSUPER == 2)THEN
+ CALL RESOLV_TIT('CTITVAR2',HTEXT)
+ ELSE IF(NSUPER == 3)THEN
+ CALL RESOLV_TIT('CTITVAR3',HTEXT)
+ ELSE IF(NSUPER == 4)THEN
+ CALL RESOLV_TIT('CTITVAR4',HTEXT)
+ ELSE IF(NSUPER == 5)THEN
+ CALL RESOLV_TIT('CTITVAR5',HTEXT)
+ ELSE IF(NSUPER == 6)THEN
+ CALL RESOLV_TIT('CTITVAR6',HTEXT)
+ ELSE IF(NSUPER == 7)THEN
+ CALL RESOLV_TIT('CTITVAR7',HTEXT)
+ ELSE IF(NSUPER == 8)THEN
+ CALL RESOLV_TIT('CTITVAR8',HTEXT)
+ ENDIF
+
+
+IF(HTEXT /= ' ')THEN
+
+IF(.NOT.LSUPER)THEN
+ CALL PLCHHQ(0.1,ZVT+0.03,HTEXT,.011,0.,-1.)
+ELSE
+ CALL PLCHHQ(0.1+(NSUPER-1)*.26,ZVT+0.03,HTEXT,.011,0.,-1.)
+ENDIF
+
+ENDIF
+
+!CALL PLCHHQ(0.1,ZVT+0.03,HTEXT,.011,0.,-1.)
+IF(LVECTMNMX)THEN
+ IF(.NOT.LDIRWIND .AND..NOT.LUMVM .AND..NOT.LUTVT .AND..NOT.LSUMVM &
+ .AND..NOT.LSUTVT .AND.LDILW)THEN
+ CALL PLCHHQ(.1,ZVT+0.010,'(Vertical component upscaled by domain aspect ratio)',.009,0.,-1.)
+ ENDIF
+ IF(.NOT.LDIRWIND)THEN
+ YLBLMN=' '
+ YLBLMX=' '
+ WRITE(YLBLMN,'(E10.3)')ZMN
+ WRITE(YLBLMX,'(E10.3)')ZMX
+ IF(LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. .NOT.LDILW)THEN
+ YLBL(1:4)='Min:'
+ YLBL(5:14)=YLBLMN
+ YLBL(15:20)=', max:'
+ YLBL(21:30)=YLBLMX
+ YLBL(31:40)=' '
+ ELSE
+ YLBL(1:13)='Unscaled min:'
+ YLBL(14:23)=YLBLMN
+ YLBL(24:29)=', max:'
+ YLBL(30:39)=YLBLMX
+ YLBL(40:40)=' '
+ ENDIF
+ CALL PCSETC('FC','/')
+ CALL PLCHHQ(.99,ZVT+.010,YLBL,.007,0.,+1.)
+! CALL PLCHHQ(.69,.047,YLBL,.007,0.,-1.)
+ CALL PCSETC('FC',':')
+ ENDIF
+ENDIF
+IF(LSUPER)THEN
+ LARROVL=.TRUE.
+ELSE
+ LARROVL=.FALSE.
+END IF
+!
+!
+!* 2.14 Heading formats
+!
+1000 FORMAT('Vertical section IDEB=',I4,' JDEB=',I4,' ANG.=',I3,' NBPTS=',I4)
+1001 FORMAT('Vertical section XDEB=',F6.0,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I4)
+1002 FORMAT('Vertical section XDEB=',F6.0,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1003 FORMAT('Vertical section XDEB=',E7.2,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I4)
+1004 FORMAT('Vertical section XDEB=',E6.2,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1006 FORMAT('Vertical profile IPRO=',I4)
+1018 FORMAT('Vertical section IND I,J (BEGIN)-(END)=(',I4,',',I4,')-(',I4,',',I4,')')
+1019 FORMAT('Vertical section LAT,LON (BEGIN)-(END)=(',F4.1,',',F5.1,')-(',F4.1,',',F5.1,')')
+1020 FORMAT('Vertical section CONF. COORD.(BEGIN)-(END)=(',F8.0,',',F8.0,')-(',F8.0,',',F8.0,')')
+!
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!print *,'imcouv ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT ',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+CALL GSCLIP(1)
+!
+!-------------------------------------------------------------------------
+!
+!* 3. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE IMCOUV_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/inidef.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/inidef.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d004e2568a7edb3a83b27a55c56508cd8cec2e78
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/inidef.f90
@@ -0,0 +1,202 @@
+! ######spl
+ SUBROUTINE INIDEF
+! #################
+!
+!!**** *INIDEF* - Sets defaults values of TRACE namelists variables
+!!
+!! PURPOSE
+!! -------
+! Sets defaults values of TRACE namelists variables
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST : declares model physical constants
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!!
+!! NIOFFD : Label normalisation (=0 none, =/=0 active)
+!! NULBLL : Nb of contours between 2 labelled contours
+!! NIOFFM : =0 --> message at picture bottom
+!! =/= 0 --> no message
+!! NIOFFP : Special point value detection
+!! (=0 none, =/=0 active)
+!! NHI : Extrema detection
+!! (=0 --> H+L, <0 nothing)
+!! NINITA : For streamlimes
+!! NINITB : Not yet implemented
+!! NIGRNC : Not yet implemented
+!! NDOT : Line style
+!! (=0|1|1023|65535 --> solid lines;
+!! <0 --> solid lines for positive values and
+!! dotted lines(ABS(NDOT))for negative values;
+!! >0 --> dotted lines(ABS(NDOT)) )
+!! NIFDC : Coastline data style (0 none, 1 NCAR, 2 IGN)
+!! NLPCAR : Number of land-mark points to be plotted
+!! NIMNMX : Contour selection option
+!! (=-1 Min, max and inc. automatically set;
+!! =0 Min, max automatically set; inc. given;
+!! >0 Min, max, inc. given by user)
+!! NISKIP : Rate for drawing velocity vectors
+!! CTYPHOR : Horizontal cross-section type
+!! (='K' --> model level section;
+!! ='Z' --> constant-altitude section;
+!! ='P' --> isobar section (planned)
+!! ='T' --> isentrope section (planned)
+!! XSPVAL : Special value
+!! XUINT : Increment contour value for UM, UT
+!! XVINT : Increment contour value for VM, VT
+!! XWINT : Increment contour value for WM, WT
+!! XTHINT : Increment contour value for THM,THT
+!! XPABSINT : Increment contour value for PABSM, PABST
+!! XSIZEL : Label size
+!! XLATCAR, XLONCAR : Lat. and Long. of land-mark points
+!! LXY : If =.TRUE., plots a grid-mesh stencil background
+!! LXZ : If =.TRUE., plots a model-level stencil background
+!!
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist
+!! (former PARA common)
+!!
+!! XIDEBCOU, XJDEBCOU : Origin of a vertical cross-section
+!! in cartesian (or conformal) real values
+!! XHMIN : Altitude of the vert. cross-section
+!! bottom (in meters above sea-level)
+!! XHMAX : Altitude of the vert. cross-section
+!! top (in meters above sea-level)
+!!
+!! Module MODD_ALLVAR
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODN_NCAR
+USE MODN_PARA
+USE MODD_CST
+USE MODD_ALLVAR
+USE MODD_RESOLVCAR, ONLY : XISOLEV, XLW1, XLW2, XLW3, XLW4
+
+IMPLICIT NONE
+!
+!* 0.1 Local variables
+! ---------------
+
+LOGICAL :: LSUPER ! TO BE COMPLETED <<<<<<<<<<<<<<<<<<<<<<<<<<<
+!
+!------------------------------------------------------------------------------
+!
+!* 1. SETS DEFAULTS FOR THE NAMELISTS VARIABLES
+! -----------------------------------------
+!
+NIINF=0; NJINF=0; NISUP=0; NJSUP=0
+XISOLEV(:)=9999.; XLATCAR(:)=9999.; XLONCAR(:)=9999.; XICAR(:)=9999.;
+XJCAR(:)=9999.
+!
+NIOFFD=0
+NULBLL=1
+NIOFFM=1
+XSIZEL=0.02
+NIOFFP=1
+XSPVAL=999.
+XHMIN=0.
+XHMAX=0.
+NHI=-1
+NDOT=-21845
+NIFDC=1
+NIGRNC=1
+NLPCAR=0
+XLATCAR(1)=44.52
+XLONCAR(1)=.3
+NINITA=2
+NINITB=2
+NIMNMX=0
+CTYPHOR='Z'
+LSUPER=.FALSE.
+LCOLAREA=.FALSE.
+LSPOT=.FALSE.
+LCOLBR=.TRUE.
+LTABCOLDEF=.TRUE.
+LCOLAREASEL=.FALSE.
+LCOLINESEL=.FALSE.
+LISOWHI=.FALSE.
+LCOLINE=.FALSE.
+LSPOT=.FALSE.
+NISKIP=1
+XIDEBCOU=-999.
+XJDEBCOU=-999.
+LXY=.FALSE.
+LXZ=.FALSE.
+NVAR3D=0
+NVAR2D=0
+X3DINT(:)=0.
+X2DINT(:)=0.
+XAMX=.2
+XVHC=0.
+XVRL=0.
+LARROVL=.FALSE.
+LISO=.TRUE.
+LVECTMNMX=.FALSE.
+LVPTUSER=.FALSE.
+XVPTL=.1
+XVPTR=.9
+XVPTB=.1
+XVPTT=.9
+LVPTVUSER=.FALSE.
+XVPTVL=.1
+XVPTVR=.9
+XVPTVB=.1
+XVPTVT=.9
+LVPTPVUSER=.FALSE.
+XVPTPVL=.13
+XVPTPVR=.9
+XVPTPVB=.1
+XVPTPVT=.9
+LMINMAX=.FALSE.
+LDATFILE=.TRUE.
+XLWDEF=1.
+XLWVDEF=0.5
+!
+XLW=-1.; XLW1=-1.; XLW2=-1.; XLW3=-1.; XLW4=-1.; XLWV=-1.
+NIMNMX=-1
+
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE INIDEF
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/interp_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/interp_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..95a0ed75c1f1821edeb5792dad3f218a2d1575c4
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/interp_fordiachro.f90
@@ -0,0 +1,662 @@
+! ######spl
+ MODULE MODI_INTERP_FORDIACHRO
+! #############################
+!
+INTERFACE
+!
+SUBROUTINE INTERP_FORDIACHRO(KLREF,KD,KF,PTAB,PTABREF)
+REAL,DIMENSION(:,:,:), INTENT(IN) :: PTAB
+REAL,DIMENSION(SIZE(PTAB,1),SIZE(PTAB,2)) :: PTABREF
+INTEGER :: KLREF
+INTEGER :: KD, KF
+END SUBROUTINE INTERP_FORDIACHRO
+!
+END INTERFACE
+!
+END MODULE MODI_INTERP_FORDIACHRO
+! ######spl
+ SUBROUTINE INTERP_FORDIACHRO(KLREF,KD,KF,PTAB,PTABREF)
+! ######################################################
+!
+!!**** *INTERP_FORDIACHRO* - Horizontal cross-section interpolation
+!!
+!! PURPOSE
+!! -------
+! Interpolates 2D horizontal cross-sections within the Meso-NH 3D
+! arrays. These horizontal sections can be:
+! -> constant model-level sections (no interpolation, only sampling
+! of a particular level);
+! -> constant Z (sea-level altitude) sections;
+! -> constant P (hydrostatic pressure) sections
+! -> isentropic (constant potential temperature)
+! sections
+!
+!!** METHOD
+!! ------
+!!
+!! Linear interpolation of the model field with
+!! respect to "height" when required
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist (former NCAR common)
+!! CTYPHOR : Horizontal cross-section type
+!! (='K' --> model level section;
+!! ='Z' --> constant-altitude section;
+!! ='P' --> isobar section (planned)
+!! ='T' --> isentrope section (planned))
+!! XSPVAL : Special value
+!!
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist (former PARA common)
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NKMAX : z array dimension
+!! NIINF, NISUP: lower and upper bounds of arrays
+!! to be plotted in x direction
+!! NJINF, NJSUP: lower and upper bounds of arrays
+!! to be plotted in y direction
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!! Module MODD_GRID1 : declares grid variables (Model module)
+!! XZZ : true gridpoint z altitude
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODN_NCAR
+USE MODN_PARA !NOTICE: MODN_PARA includes MODD_DIM1
+USE MODD_PARAMETERS
+USE MODD_MASK3D
+USE MODD_GRID1
+USE MODD_TYPE_AND_LH
+! 07/08/96 !
+USE MODD_NMGRID
+USE MODD_PT_FOR_CH_FORDIACHRO
+! 07/08/96 !
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+INTERFACE
+ SUBROUTINE COMPLAT(PLAT)
+ REAL,DIMENSION(:,:) :: PLAT
+ END SUBROUTINE
+END INTERFACE
+!
+!* 0.1 Declaration of arguments and results
+!
+REAL,DIMENSION(:,:,:), INTENT(IN) :: PTAB !Input arrays where the
+ !horizontal section is cut
+REAL,DIMENSION(SIZE(PTAB,1),SIZE(PTAB,2)) :: PTABREF !Output array containing !the sampled plane
+INTEGER :: KLREF !Sampled level location:
+ !If CTYPHOR='K'-> model level index given,
+ !If CTYPHOR='Z'-> sea-level altitude given in meters,
+ !If CTYPHOR='P'-> pressure level given in hPa,
+ !If CTYPHOR='T'-> potential temperature level given in K.
+INTEGER :: KD, KF ! K Bounds
+!
+!* 0.2 Local Variables
+!
+INTEGER :: IID,IJD
+INTEGER :: II, IJ, IK
+INTEGER :: JILOOP, JJLOOP, JKLOOP, IKB, IKE
+REAL :: ZREF, ZDIXEPS, ZXM, ZXP
+! 07/08/96 !
+INTEGER :: IIUP,IJUP,IKU
+INTEGER :: IND1, IND2
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: ZPTH, ZPTHPROV
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZLAT
+! 07/08/96 !
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Preliminary calculations
+! ------------------------
+!
+IKB=1+JPVEXT
+ZDIXEPS=10.*EPSILON(1.)
+! 07/08/96 !
+IKU=NKMAX+2*JPVEXT
+!IKU=SIZE(PTAB,3)
+IKE=IKU-JPVEXT
+IIUP=NIMAX+2*JPHEXT
+!IIUP=SIZE(PTAB,1)
+!IJUP=SIZE(PTAB,2)
+IJUP=NJMAX+2*JPHEXT
+!print *,' IIUP,IJUP,IKU ',IIUP,IJUP,IKU
+!print *,' INTERP_FORDIACHRO SIZE(XPRES,1),SIZE(XPRES,2),SIZE(XPRES,3) ',SIZE(XPRES,1),SIZE(XPRES,2),SIZE(XPRES,3)
+! 07/08/96 !
+IF(LPR)THEN
+ IF(ALLOCATED(ZPTH)) DEALLOCATE(ZPTH)
+ ALLOCATE(ZPTH(SIZE(XPRES,1),SIZE(XPRES,2),SIZE(XPRES,3)))
+ENDIF
+IF(LTK .OR. LEV .OR. LSV3)THEN
+ IF(ALLOCATED(ZPTH)) DEALLOCATE(ZPTH)
+ ALLOCATE(ZPTH(SIZE(XTH,1),SIZE(XTH,2),SIZE(XTH,3)))
+ENDIF
+if(nverbia > 0)then
+print *,' INTERP_FORDIACHRO LPR,LTK,LEV,LSV3 ',LPR,LTK,LEV,LSV3
+endif
+!
+! If not a model level request, convert KLREF to
+! the appropriate variable for interpolation
+!
+print *,' *** Interp KLREF, XLOOPZ ',KLREF,XLOOPZ
+IF(CTYPHOR.EQ.'P')THEN ! 'P' requested
+!>>>>>>>>>>>>>YET TO BE COMPLETED
+!Mars 2000
+ IF(LCHREEL)THEN
+ ZREF=ALOG10(XLOOPZ*100.)
+ ELSE
+!Mars 2000
+! 07/08/96 !
+ ZREF=ALOG10(FLOAT(KLREF)*100.)
+! 07/08/96 !
+!Mars 2000
+ ENDIF
+!Mars 2000
+ELSE ! 'Z' requested
+!Mars 2000
+ IF(LCHREEL)THEN
+ ZREF=XLOOPZ
+ ELSE
+!Mars 2000
+ ZREF=FLOAT(KLREF)
+!Mars 2000
+ ENDIF
+!Mars 2000
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. Sampling of the requested horizontal section
+! --------------------------------------------
+!
+!* 2.1 Sampling of a model level: no interpolation necessary
+!
+CALL CPSETC('CFT','CONSTANT FIELD - VALUE IS $ZDV$')
+IF(CTYPHOR.EQ.'K')THEN
+ if(nverbia >0)then
+ print *, ' ** INTERP CTYPHOR.EQ. K, KLREF,KD,KF ', KLREF,KD,KF
+ endif
+ IF(LMSKTOP)THEN
+ if(nverbia >0)then
+ print *,' INTERP MSKTOP NLOOPT ',NLOOPT
+ endif
+ DO JILOOP=NIINF,NISUP
+ DO JJLOOP=NJINF,NJSUP
+ DO JKLOOP=KF,KD,-1
+ IID=JILOOP-NIINF+1
+ IJD=JJLOOP-NJINF+1
+ PTABREF(IID,IJD)=XSPVAL
+ IF(LMASK3(JILOOP,JJLOOP,JKLOOP,NLOOPT))THEN
+ PTABREF(IID,IJD)=PTAB(IID,IJD,JKLOOP-KD+1)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ if(nverbia >0)then
+ print *,' ** interp CTYPHOR=K AV RETURN DANS LMSKTOP, LPR=',LPR
+ endif
+ RETURN
+ ELSE
+ if(nverbia >0)then
+ print *, ' ** INTERP AV IF(KLREF < KD)THEN KLREF,KD,KF ', KLREF,KD,KF
+ endif
+ IF(KLREF < KD)THEN
+! Ajout LKCP Avril 2001 -> prise en compte bilans compresses en K
+ IF(LKCP)THEN
+ PTABREF(:,:)=PTAB(:,:,1)
+ ELSE
+ CALL CPSETC('CFT','UNDER IKB or 1st recorded LEVEL')
+ PTABREF(:,:)=XSPVAL
+ ENDIF
+ RETURN
+ ELSE IF(KLREF > KF)THEN
+ CALL CPSETC('CFT','OVER IKE or last recorded LEVEL')
+ PTABREF(:,:)=XSPVAL
+ RETURN
+ ELSE
+ PTABREF(:,:)=PTAB(:,:,KLREF-KD+1)
+ IND1=0
+ DO JILOOP=1,SIZE(PTABREF,1)
+ DO JJLOOP=1,SIZE(PTABREF,2)
+ IF(PTABREF(JILOOP,JJLOOP) /= XSPVAL)THEN
+ IND1=1
+ EXIT
+ ENDIF
+ ENDDO
+ ENDDO
+ IF(IND1 == 0)THEN
+ CALL CPSETC('CFT','No Value')
+ IND1=0
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+END IF
+! 07/08/96 !
+IF(CTYPHOR.EQ.'P')THEN
+ ZPTH=XPRES(:,:,:,NLOOPT,1,1)
+ENDIF
+IF(CTYPHOR.EQ.'T' .OR. CTYPHOR.EQ.'E' .OR. CTYPHOR.EQ.'V')THEN
+ IF(CTYPHOR.EQ.'E')THEN
+ II=SIZE(XTH,1)
+ IJ=SIZE(XTH,2)
+ ALLOCATE(ZLAT(II,IJ))
+ CALL COMPLAT(ZLAT)
+ IK=SIZE(XTH,3)
+! 7 Mars 2000
+ print *,' interpol *** NLOOPT ',NLOOPT
+ ZPTH=XTH(:,:,:,NLOOPT,1,1)
+ DO JKLOOP=1,IK
+ WHERE(ZPTH(:,:,JKLOOP) /= XSPVAL)
+ ZPTH(:,:,JKLOOP)=ZPTH(:,:,JKLOOP)* &
+ SIGN(1.,ZLAT(:,:))
+ ENDWHERE
+! WHERE(XTH(:,:,JKLOOP,NLOOPT,1,1) /= XSPVAL)
+! XTH(:,:,JKLOOP,NLOOPT,1,1)=XTH(:,:,JKLOOP,NLOOPT,1,1)* &
+! SIGN(1.,ZLAT(:,:))
+! ENDWHERE
+ ENDDO
+ DEALLOCATE(ZLAT)
+ ELSE
+ ZPTH=XTH(:,:,:,NLOOPT,1,1)
+ ENDIF
+! ZPTH=XTH(:,:,:,NLOOPT,1,1)
+ENDIF
+IF(CTYPHOR == 'T' .OR. CTYPHOR == 'P' .OR. CTYPHOR == 'E' .OR. CTYPHOR.EQ.'V')THEN
+!Mars 2000
+IF(LSV3 .OR. LXYZ)THEN
+ IF(ALLOCATED(ZPTHPROV))THEN
+ DEALLOCATE(ZPTHPROV)
+ ENDIF
+ ALLOCATE(ZPTHPROV(SIZE(ZPTH,1),SIZE(ZPTH,2),SIZE(ZPTH,3)))
+ ZPTHPROV=XSPVAL
+SELECT CASE (NMGRID)
+ CASE(1)
+ CASE(2)
+ WHERE(ZPTH(2:IIUP,:,:) /= XSPVAL .AND. ZPTH(1:IIUP-1,:,:) /= XSPVAL)
+ ZPTHPROV(2:IIUP,:,:)=.5*(ZPTH(2:IIUP,:,:) + ZPTH(1:IIUP-1,:,:))
+ ENDWHERE
+ WHERE(ZPTHPROV(2,:,:) /= XSPVAL .AND. ZPTHPROV(3,:,:) /= XSPVAL)
+ ZPTHPROV(1,:,:)=2.*ZPTHPROV(2,:,:)-ZPTHPROV(3,:,:)
+ ENDWHERE
+ ZPTH=ZPTHPROV
+ CASE(3)
+ WHERE(ZPTH(:,2:IJUP,:) /= XSPVAL .AND. ZPTH(:,1:IJUP-1,:) /= XSPVAL)
+ ZPTHPROV(:,2:IJUP,:)=.5*(ZPTH(:,2:IJUP,:) + ZPTH(:,1:IJUP-1,:))
+ ENDWHERE
+ WHERE(ZPTHPROV(:,2,:) /= XSPVAL .AND. ZPTHPROV(:,3,:) /= XSPVAL)
+ ZPTHPROV(:,1,:)=2.*ZPTHPROV(:,2,:)-ZPTHPROV(:,3,:)
+ ENDWHERE
+ ZPTH=ZPTHPROV
+ CASE(4)
+ WHERE(ZPTH(:,:,2:IKU) /= XSPVAL .AND. ZPTH(:,:,1:IKU-1) /= XSPVAL)
+ ZPTHPROV(:,:,2:IKU)=.5*(ZPTH(:,:,2:IKU) + ZPTH(:,:,1:IKU-1))
+ ENDWHERE
+ WHERE(ZPTHPROV(:,:,2) /= XSPVAL .AND. ZPTHPROV(:,:,3) /= XSPVAL)
+ ZPTHPROV(:,:,1)=2.*ZPTHPROV(:,:,2)-ZPTHPROV(:,:,3)
+ ENDWHERE
+ ZPTH=ZPTHPROV
+ CASE(5)
+ WHERE(ZPTH(2:IIUP,:,:) /= XSPVAL .AND. ZPTH(1:IIUP-1,:,:) /= XSPVAL)
+ ZPTHPROV(2:IIUP,:,:)=.5*(ZPTH(2:IIUP,:,:) + ZPTH(1:IIUP-1,:,:))
+ ENDWHERE
+ WHERE(ZPTHPROV(2,:,:) /= XSPVAL .AND. ZPTHPROV(3,:,:) /= XSPVAL)
+ ZPTHPROV(1,:,:)=2.*ZPTHPROV(2,:,:)-ZPTHPROV(3,:,:)
+ ENDWHERE
+ ZPTH=ZPTHPROV
+ ZPTHPROV=XSPVAL
+ WHERE(ZPTH(:,2:IJUP,:) /= XSPVAL .AND. ZPTH(:,1:IJUP-1,:) /= XSPVAL)
+ ZPTHPROV(:,2:IJUP,:)=.5*(ZPTH(:,2:IJUP,:) + ZPTH(:,1:IJUP-1,:))
+ ENDWHERE
+ WHERE(ZPTHPROV(:,2,:) /= XSPVAL .AND. ZPTHPROV(:,3,:) /= XSPVAL)
+ ZPTHPROV(:,1,:)=2.*ZPTHPROV(:,2,:)-ZPTHPROV(:,3,:)
+ ENDWHERE
+ ZPTH=ZPTHPROV
+ CASE(6)
+ WHERE(ZPTH(:,:,2:IKU) /= XSPVAL .AND. ZPTH(:,:,1:IKU-1) /= XSPVAL)
+ ZPTHPROV(:,:,2:IKU)=.5*(ZPTH(:,:,2:IKU) + ZPTH(:,:,1:IKU-1))
+ ENDWHERE
+ WHERE(ZPTHPROV(:,:,2) /= XSPVAL .AND. ZPTHPROV(:,:,3) /= XSPVAL)
+ ZPTHPROV(:,:,1)=2.*ZPTHPROV(:,:,2)-ZPTHPROV(:,:,3)
+ ENDWHERE
+ ZPTH=ZPTHPROV
+ ZPTHPROV=XSPVAL
+ WHERE(ZPTH(2:IIUP,:,:) /= XSPVAL .AND. ZPTH(1:IIUP-1,:,:) /= XSPVAL)
+ ZPTHPROV(2:IIUP,:,:)=.5*(ZPTH(2:IIUP,:,:) + ZPTH(1:IIUP-1,:,:))
+ ENDWHERE
+ WHERE(ZPTHPROV(2,:,:) /= XSPVAL .AND. ZPTHPROV(3,:,:) /= XSPVAL)
+ ZPTHPROV(1,:,:)=2.*ZPTHPROV(2,:,:)-ZPTHPROV(3,:,:)
+ ENDWHERE
+ ZPTH=ZPTHPROV
+ CASE(7)
+ WHERE(ZPTH(:,:,2:IKU) /= XSPVAL .AND. ZPTH(:,:,1:IKU-1) /= XSPVAL)
+ ZPTHPROV(:,:,2:IKU)=.5*(ZPTH(:,:,2:IKU) + ZPTH(:,:,1:IKU-1))
+ ENDWHERE
+ WHERE(ZPTHPROV(:,:,2) /= XSPVAL .AND. ZPTHPROV(:,:,3) /= XSPVAL)
+ ZPTHPROV(:,:,1)=2.*ZPTHPROV(:,:,2)-ZPTHPROV(:,:,3)
+ ENDWHERE
+ ZPTH=ZPTHPROV
+ ZPTHPROV=XSPVAL
+ WHERE(ZPTH(:,2:IJUP,:) /= XSPVAL .AND. ZPTH(:,1:IJUP-1,:) /= XSPVAL)
+ ZPTHPROV(:,2:IJUP,:)=.5*(ZPTH(:,2:IJUP,:) + ZPTH(:,1:IJUP-1,:))
+ ENDWHERE
+ WHERE(ZPTHPROV(:,2,:) /= XSPVAL .AND. ZPTHPROV(:,3,:) /= XSPVAL)
+ ZPTHPROV(:,1,:)=2.*ZPTHPROV(:,2,:)-ZPTHPROV(:,3,:)
+ ENDWHERE
+ ZPTH=ZPTHPROV
+END SELECT
+DEALLOCATE(ZPTHPROV)
+
+ELSE
+!Mars 2000
+
+SELECT CASE (NMGRID)
+ CASE(1)
+ CASE(2)
+ ZPTH(2:IIUP,:,:)=.5*(ZPTH(2:IIUP,:,:) + ZPTH(1:IIUP-1,:,:))
+ ZPTH(1,:,:)=2.*ZPTH(2,:,:)-ZPTH(3,:,:)
+ CASE(3)
+ ZPTH(:,2:IJUP,:)=.5*(ZPTH(:,2:IJUP,:) + ZPTH(:,1:IJUP-1,:))
+ ZPTH(:,1,:)=2.*ZPTH(:,2,:)-ZPTH(:,3,:)
+ CASE(4)
+ ZPTH(:,:,2:IKU)=.5*(ZPTH(:,:,2:IKU) + ZPTH(:,:,1:IKU-1))
+ ZPTH(:,:,1)=2.*ZPTH(:,:,2)-ZPTH(:,:,3)
+ CASE(5)
+ ZPTH(2:IIUP,:,:)=.5*(ZPTH(2:IIUP,:,:) + ZPTH(1:IIUP-1,:,:))
+ ZPTH(1,:,:)=2.*ZPTH(2,:,:)-ZPTH(3,:,:)
+ ZPTH(:,2:IJUP,:)=.5*(ZPTH(:,2:IJUP,:) + ZPTH(:,1:IJUP-1,:))
+ ZPTH(:,1,:)=2.*ZPTH(:,2,:)-ZPTH(:,3,:)
+ CASE(6)
+ ZPTH(:,:,2:IKU)=.5*(ZPTH(:,:,2:IKU) + ZPTH(:,:,1:IKU-1))
+ ZPTH(:,:,1)=2.*ZPTH(:,:,2)-ZPTH(:,:,3)
+ ZPTH(2:IIUP,:,:)=.5*(ZPTH(2:IIUP,:,:) + ZPTH(1:IIUP-1,:,:))
+ ZPTH(1,:,:)=2.*ZPTH(2,:,:)-ZPTH(3,:,:)
+ CASE(7)
+ ZPTH(:,:,2:IKU)=.5*(ZPTH(:,:,2:IKU) + ZPTH(:,:,1:IKU-1))
+ ZPTH(:,:,1)=2.*ZPTH(:,:,2)-ZPTH(:,:,3)
+ ZPTH(:,2:IJUP,:)=.5*(ZPTH(:,2:IJUP,:) + ZPTH(:,1:IJUP-1,:))
+ ZPTH(:,1,:)=2.*ZPTH(:,2,:)-ZPTH(:,3,:)
+END SELECT
+
+!Mars 2000
+ENDIF
+!Mars 2000
+!IF(CTYPHOR == 'P')print *,' ZPTH AP MISE SUR GRILLE '
+ENDIF
+! 07/08/96 !
+!
+!* 2.2 Not a model level request: interpolation necessary
+!
+DO JILOOP=NIINF,NISUP
+ DO JJLOOP=NJINF,NJSUP
+
+ IF((CTYPHOR.EQ.'E' .OR. CTYPHOR.EQ.'V') .AND. LINTERPTOP)THEN
+ DO JKLOOP=KF,KD,-1
+!
+ IID=JILOOP-NIINF+1
+ IJD=JJLOOP-NJINF+1
+!
+!* 2.2.3 Potential vorticity request: prepares PV interpolation
+!
+! 07/08/96 !
+ ZXM=ZPTH(JILOOP,JJLOOP,JKLOOP)
+ ZXP=ZPTH(JILOOP,JJLOOP,MIN(KF,JKLOOP+1))
+! 07/08/96 !
+!
+!* 2.3 Selects points within the TRACE display window
+!
+!
+! 07/08/96 !
+ PTABREF(IID,IJD)=XSPVAL
+! 18/02/2000 Essai pour prise en compte des valeurs speciales
+ IF(LSV3 .AND. LXYZ00)THEN
+ IF(ZXP == XSPVAL .OR. ZXM == XSPVAL .OR. (ZXP == XSPVAL .AND. &
+ ZXM == XSPVAL))THEN
+ if(nverbia == 20)then
+ print *,' ***interp JILOOP JJLOOP JKLOOP ZXP ZXM ',JILOOP,&
+ JJLOOP,JKLOOP,ZXP,ZXM
+ endif
+ CYCLE
+ ENDIF
+ ENDIF
+! 18/02/2000 Essai pour prise en compte des valeurs speciales
+ IF((ZXP-ZREF)*(ZREF-ZXM).GE.0.)THEN
+ IF(JKLOOP+1 <= IKB .OR. JKLOOP+1 > IKE)THEN
+ CYCLE
+ ELSE
+ GO TO 4
+ ENDIF
+ ELSE IF(ZXP.GE.ZXM-ZDIXEPS.AND.ZXP.LE.ZXM+ZDIXEPS.AND. &
+ ZREF.GE.ZXM-ZDIXEPS.AND.ZREF.LE.ZXM+ZDIXEPS)THEN
+ IF(JKLOOP+1 <= IKB .OR. JKLOOP+1 > IKE)THEN
+ CYCLE
+ ELSE
+ GO TO 4
+ ENDIF
+ ENDIF
+! 07/08/96 !
+!
+ ENDDO
+
+ ELSE
+
+ DO JKLOOP=KD,KF
+!
+ IID=JILOOP-NIINF+1
+ IJD=JJLOOP-NJINF+1
+!
+!* 2.2.1 Pressure level request: prepares Log(P) interpolation
+!
+ IF(CTYPHOR.EQ.'P')THEN
+!>>>>>>>>>>>>YET TO BE DEVELOPED
+ ZXM=ALOG10(ZPTH(JILOOP,JJLOOP,JKLOOP))
+ ZXP=ALOG10(ZPTH(JILOOP,JJLOOP,MIN(KF,JKLOOP+1)))
+!
+!* 2.2.2 Altitude level request: prepares Z interpolation
+!
+ ELSE IF (CTYPHOR.EQ.'Z')THEN
+ ZXM=XZZ(JILOOP,JJLOOP,JKLOOP)
+ ZXP=XZZ(JILOOP,JJLOOP,MIN(KF,JKLOOP+1))
+!
+!* 2.2.3 Potential temperature request: prepares Theta interpolation
+!
+ ELSE IF(CTYPHOR.EQ.'T')THEN
+!>>>>>>>>>>>>YET TO BE DEVELOPED
+! 07/08/96 !
+ ZXM=ZPTH(JILOOP,JJLOOP,JKLOOP)
+ ZXP=ZPTH(JILOOP,JJLOOP,MIN(KF,JKLOOP+1))
+! 07/08/96 !
+! Mars 2000 Ajout possibilite de faire interpolation a partir du bas
+! pour la vorticite potentielle et SV3
+ ELSE IF(CTYPHOR.EQ.'E' .AND. .NOT.LINTERPTOP)THEN
+ ZXM=ZPTH(JILOOP,JJLOOP,JKLOOP)
+ ZXP=ZPTH(JILOOP,JJLOOP,MIN(KF,JKLOOP+1))
+ ELSE IF(CTYPHOR.EQ.'V' .AND. .NOT.LINTERPTOP)THEN
+ ZXM=ZPTH(JILOOP,JJLOOP,JKLOOP)
+ ZXP=ZPTH(JILOOP,JJLOOP,MIN(KF,JKLOOP+1))
+! Mars 2000
+ END IF
+!
+!* 2.3 Selects points within the TRACE display window
+!
+!
+! 07/08/96 !
+ PTABREF(IID,IJD)=XSPVAL
+! 23/03/2000 Essai pour prise en compte des valeurs speciales
+ IF(LSV3 .AND. LXYZ00)THEN
+ IF(ZXP == XSPVAL .OR. ZXM == XSPVAL .OR. (ZXP == XSPVAL .AND. &
+ ZXM == XSPVAL))THEN
+ if(nverbia == 20)then
+ print *,' ***interp JILOOP JJLOOP JKLOOP ZXP ZXM ',JILOOP,&
+ JJLOOP,JKLOOP,ZXP,ZXM
+ endif
+ CYCLE
+ ENDIF
+ ENDIF
+! 23/03/2000 Essai pour prise en compte des valeurs speciales
+ IF((ZXP-ZREF)*(ZREF-ZXM).GE.0.)THEN
+ IF(JKLOOP+1 <= IKB .OR. JKLOOP+1 > IKE)THEN
+ CYCLE
+ ELSE
+ GO TO 4
+ ENDIF
+ ELSE IF(ZXP.GE.ZXM-ZDIXEPS.AND.ZXP.LE.ZXM+ZDIXEPS.AND. &
+ ZREF.GE.ZXM-ZDIXEPS.AND.ZREF.LE.ZXM+ZDIXEPS)THEN
+ IF(JKLOOP+1 <= IKB .OR. JKLOOP+1 > IKE)THEN
+ CYCLE
+ ELSE
+ GO TO 4
+ ENDIF
+ ENDIF
+! 07/08/96 !
+!
+ ENDDO
+ ENDIF
+!
+!* 2.4 Out of display window: inserts a NCAR special value
+! to suppress display
+!
+ PTABREF(IID,IJD)=XSPVAL
+ GO TO 5
+!
+4 CONTINUE
+!
+!* 2.5 Requested level colocated with a model level: no interpolation
+!
+ IF(ZXP==ZXM)THEN
+ PTABREF(IID,IJD)=PTAB(IID,IJD,JKLOOP-KD+1)
+! print *,' INTERP_FORDIACHRO ZXM ZXP ',ZXM,ZXP
+! IF(CTYPHOR == 'P')THEN
+! print *,' CAS ZXM=ZXP '
+! ENDIF
+!
+!* 2.6 Requested level located between model levels: linear interpolation
+!
+ ELSE
+ SELECT CASE(CTYPHOR)
+ CASE('Z')
+! print *,' ZXP - ZXM ',ZXP-ZXM
+ PTABREF(IID,IJD)=(PTAB(IID,IJD,JKLOOP-KD+1)*(ZXP-ZREF)+ &
+ PTAB(IID,IJD,MIN(KF-KD+1,JKLOOP+1-KD+1))* &
+ (ZREF-ZXM))/MAX(1.E-8,(ZXP-ZXM))
+ CASE('T','E','V')
+! print *,' ZXP - ZXM ',ZXP-ZXM
+ LTHSTAB=.TRUE.
+ IF(JKLOOP+1 > IKB)THEN
+ IF(ZXP-ZXM >= 0.)THEN
+ LTHSTAB=.TRUE.
+ ELSE
+ LTHSTAB=.FALSE.
+! print *,' JKLOOP, ZXP, ZXM ',JKLOOP,ZXP,ZXM
+ ENDIF
+ ENDIF
+ PTABREF(IID,IJD)=(PTAB(IID,IJD,JKLOOP-KD+1)*(ZXP-ZREF)+ &
+ PTAB(IID,IJD,MIN(KF-KD+1,JKLOOP+1-KD+1))* &
+ (ZREF-ZXM))/(ZXP-ZXM)
+ CASE('P')
+ PTABREF(IID,IJD)=(PTAB(IID,IJD,JKLOOP-KD+1)*(ZXP-ZREF)+ &
+ PTAB(IID,IJD,MIN(KF-KD+1,JKLOOP+1-KD+1))* &
+ (ZREF-ZXM))/MIN(-1.E-8,(ZXP-ZXM))
+ END SELECT
+! IF(CTYPHOR == 'P' .AND. IID == 4 .AND. IJD == 8)THEN
+! print *,' IID,IJD,JKLOOP-KD+1,PTAB,ZXP-ZREF ',IID,IJD,JKLOOP-KD+1,PTAB(IID,IJD,JKLOOP-KD+1),ZXP-ZREF
+! print *,' IID,IJD,JKLOOP-KD+1,PTAB,ZXP-ZREF ZXP-ZXM',IID,IJD,JKLOOP-KD+1,PTAB(IID,IJD,MIN(KF-KD+1,JKLOOP-KD+1+1)),ZREF-ZXM,ZXP-ZXM
+! ENDIF
+ END IF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Sept 2000 test suivant supprime
+! IF(LXYZ .OR. LSV3)THEN
+ IF(PTAB(IID,IJD,JKLOOP-KD+1) == XSPVAL .AND. &
+ PTAB(IID,IJD,MIN(KF-KD+1,JKLOOP+1-KD+1)) == XSPVAL)THEN
+ PTABREF(IID,IJD)=XSPVAL
+ ELSE IF(PTAB(IID,IJD,JKLOOP-KD+1) /= XSPVAL .AND. &
+ PTAB(IID,IJD,MIN(KF-KD+1,JKLOOP+1-KD+1)) == XSPVAL)THEN
+ PTABREF(IID,IJD)=XSPVAL
+! PTABREF(IID,IJD)=PTAB(IID,IJD,JKLOOP-KD+1)
+ ELSE IF(PTAB(IID,IJD,JKLOOP-KD+1) == XSPVAL .AND. &
+ PTAB(IID,IJD,MIN(KF-KD+1,JKLOOP+1-KD+1)) /= XSPVAL)THEN
+! PTABREF(IID,IJD)=PTAB(IID,IJD,MIN(KF-KD+1,JKLOOP+1-KD+1))
+ PTABREF(IID,IJD)=XSPVAL
+ ENDIF
+! ENDIF
+! Sept 2000
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+5 CONTINUE
+!
+ ENDDO
+ENDDO
+!
+IND1=0
+IND2=0
+DO JILOOP=1,SIZE(PTABREF,1)
+ DO JJLOOP=1,SIZE(PTABREF,2)
+ IF(PTABREF(JILOOP,JJLOOP) /= XSPVAL)THEN
+ IND1=1
+ EXIT
+ ELSE
+ IND2=1
+ ENDIF
+ ENDDO
+ENDDO
+!print *,' PTABREF 1-8 '
+!DO JJLOOP=1,SIZE(PTABREF,2)
+! print *,(PTABREF(JILOOP,JJLOOP),JILOOP=1,8)
+!ENDDO
+!print *,' PTABREF 9-16 '
+!DO JJLOOP=1,SIZE(PTABREF,2)
+! print *,(PTABREF(JILOOP,JJLOOP),JILOOP=9,16)
+!ENDDO
+!print *,' PTABREF 17-24 '
+!DO JJLOOP=1,SIZE(PTABREF,2)
+! print *,(PTABREF(JILOOP,JJLOOP),JILOOP=17,24)
+!ENDDO
+IF(IND1 == 0 .AND. IND2 /= 0)THEN
+ CALL CPSETC('CFT','<IKB or 1st recorded LEVEL or >IKE LEVEL')
+ IF(LSV3 .OR. LXYZ)THEN
+ CALL CPSETC('CFT','No value')
+ ENDIF
+ELSE
+ CALL CPSETC('CFT','CONSTANT FIELD - VALUE IS $ZDV$')
+ENDIF
+if(nverbia > 0)then
+ print *,' INTERP_FORDIACHRO end: LPR,LTK,LEV,LSV3 ',LPR,LTK,LEV,LSV3
+endif
+
+!
+!----------------------------------------------------------------------------
+!
+!* 3. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE INTERP_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/interp_grids.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/interp_grids.f90
new file mode 100644
index 0000000000000000000000000000000000000000..461163edb2855eb0b02ddd03b2b3bad1d2f30e56
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/interp_grids.f90
@@ -0,0 +1,321 @@
+! ######spl
+ SUBROUTINE INTERP_GRIDS(K)
+! ##########################
+!
+!!**** *INTERP_GRIDS* -
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist (former NCAR common)
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 25/10/99
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_RESOLVCAR
+USE MODD_PVT
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODD_NMGRID
+
+IMPLICIT NONE
+!
+!* 0.1 Declaration of arguments and results
+!
+INTEGER :: K
+!
+!* 0.2 Local Variables
+!
+INTEGER :: IG, IP, IN, II, IJ, IK, IT
+INTEGER :: IGRIDIA
+REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: ZTEM
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Preliminary calculations
+! ------------------------
+!
+IF(LPRESYT)THEN
+ IG=1
+ IN=1
+ IP=1
+ II=SIZE(XPRES,1)
+ IJ=SIZE(XPRES,2)
+ IK=SIZE(XPRES,3)
+ IT=1
+ ALLOCATE(ZTEM(SIZE(XPRES,1),SIZE(XPRES,2),SIZE(XPRES,3),1))
+ IGRIDIA=NMGRID
+ELSE
+ IG=NGRIDIA(NPROCDIA(NBPROCDIA(K),K))
+ IN=NNDIA(1,K)
+ IP=NPROCDIA(NBPROCDIA(K),K)
+ II=SIZE(XVAR,1)
+ IJ=SIZE(XVAR,2)
+ IK=SIZE(XVAR,3)
+ IT=SIZE(XVAR,4)
+ ALLOCATE(ZTEM(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4)))
+ IGRIDIA=NGRIDIAM
+ENDIF
+!
+! Mars 20000 Cas ou pas de decalage horizontal mais vertical peut-etre
+!
+IF(LPRESYT)THEN
+ ZTEM(:,:,:,1)=XPRES(:,:,:,NLOOPT,IN,IP)
+ELSE
+ ZTEM(:,:,:,:)=XVAR(:,:,:,:,IN,IP)
+ENDIF
+!
+! Decalages horizontaux
+!
+!SELECT CASE(NGRIDIAM)
+IF(II /=1 .AND. IJ /=1)THEN
+SELECT CASE(IGRIDIA)
+ CASE(1)
+ SELECT CASE(IG)
+ CASE(2,6)
+ IF(LPRESYT)THEN
+ ZTEM(1:II-1,:,:,1)=.5*(XPRES(1:II-1,:,:,NLOOPT,IN,IP)+XPRES(2:II,:,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(1:II-1,:,:,:)=.5*(XVAR(1:II-1,:,:,:,IN,IP)+XVAR(2:II,:,:,:,IN,IP))
+ ENDIF
+ ZTEM(II,:,:,:)=2.*ZTEM(II-1,:,:,:)-ZTEM(II-2,:,:,:)
+ CASE(3,7)
+ IF(LPRESYT)THEN
+ ZTEM(:,1:IJ-1,:,1)=.5*(XPRES(:,1:IJ-1,:,NLOOPT,IN,IP)+XPRES(:,2:IJ,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(:,1:IJ-1,:,:)=.5*(XVAR(:,1:IJ-1,:,:,IN,IP)+XVAR(:,2:IJ,:,:,IN,IP))
+ ENDIF
+ ZTEM(:,IJ,:,:)=2.*ZTEM(:,IJ-1,:,:)-ZTEM(:,IJ-2,:,:)
+ CASE(5)
+ IF(LPRESYT)THEN
+ ZTEM(1:II-1,:,:,1)=.5*(XPRES(1:II-1,:,:,NLOOPT,IN,IP)+XPRES(2:II,:,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(1:II-1,:,:,:)=.5*(XVAR(1:II-1,:,:,:,IN,IP)+XVAR(2:II,:,:,:,IN,IP))
+ ENDIF
+ ZTEM(II,:,:,:)=2.*ZTEM(II-1,:,:,:)-ZTEM(II-2,:,:,:)
+ ZTEM(:,1:IJ-1,:,:)=.5*(ZTEM(:,1:IJ-1,:,:)+ZTEM(:,2:IJ,:,:))
+ ZTEM(:,IJ,:,:)=2.*ZTEM(:,IJ-1,:,:)-ZTEM(:,IJ-2,:,:)
+ END SELECT
+ CASE(2)
+ SELECT CASE(IG)
+ CASE(1,4)
+ IF(LPRESYT)THEN
+ ZTEM(2:II,:,:,1)=.5*(XPRES(1:II-1,:,:,NLOOPT,IN,IP)+XPRES(2:II,:,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(2:II,:,:,:)=.5*(XVAR(1:II-1,:,:,:,IN,IP)+XVAR(2:II,:,:,:,IN,IP))
+ ENDIF
+ ZTEM(1,:,:,:)=2.*ZTEM(2,:,:,:)-ZTEM(3,:,:,:)
+ CASE(3,7)
+ IF(LPRESYT)THEN
+ ZTEM(:,1:IJ-1,:,1)=.5*(XPRES(:,1:IJ-1,:,NLOOPT,IN,IP)+XPRES(:,2:IJ,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(:,1:IJ-1,:,:)=.5*(XVAR(:,1:IJ-1,:,:,IN,IP)+XVAR(:,2:IJ,:,:,IN,IP))
+ ENDIF
+ ZTEM(:,IJ,:,:)=2.*ZTEM(:,IJ-1,:,:)-ZTEM(:,IJ-2,:,:)
+ ZTEM(2:II,:,:,:)=.5*(ZTEM(1:II-1,:,:,:)+ZTEM(2:II,:,:,:))
+ ZTEM(1,:,:,:)=2.*ZTEM(2,:,:,:)-ZTEM(3,:,:,:)
+ CASE(5)
+ IF(LPRESYT)THEN
+ ZTEM(:,1:IJ-1,:,1)=.5*(XPRES(:,1:IJ-1,:,NLOOPT,IN,IP)+XPRES(:,2:IJ,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(:,1:IJ-1,:,:)=.5*(XVAR(:,1:IJ-1,:,:,IN,IP)+XVAR(:,2:IJ,:,:,IN,IP))
+ ENDIF
+ ZTEM(:,IJ,:,:)=2.*ZTEM(:,IJ-1,:,:)-ZTEM(:,IJ-2,:,:)
+ END SELECT
+ CASE(3)
+ SELECT CASE(IG)
+ CASE(1,4)
+ IF(LPRESYT)THEN
+ ZTEM(:,2:IJ,:,1)=.5*(XPRES(:,1:IJ-1,:,NLOOPT,IN,IP)+XPRES(:,2:IJ,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(:,2:IJ,:,:)=.5*(XVAR(:,1:IJ-1,:,:,IN,IP)+XVAR(:,2:IJ,:,:,IN,IP))
+ ENDIF
+ ZTEM(:,1,:,:)=2.*ZTEM(:,2,:,:)-ZTEM(:,3,:,:)
+ CASE(2,6)
+ IF(LPRESYT)THEN
+ ZTEM(2:II,:,:,1)=.5*(XPRES(1:II-1,:,:,NLOOPT,IN,IP)+XPRES(2:II,:,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(2:II,:,:,:)=.5*(XVAR(1:II-1,:,:,:,IN,IP)+XVAR(2:II,:,:,:,IN,IP))
+ ENDIF
+ ZTEM(1,:,:,:)=2.*ZTEM(2,:,:,:)-ZTEM(3,:,:,:)
+ ZTEM(:,2:IJ,:,:)=.5*(ZTEM(:,1:IJ-1,:,:)+ZTEM(:,2:IJ,:,:))
+ ZTEM(:,1,:,:)=2.*ZTEM(:,2,:,:)-ZTEM(:,3,:,:)
+ CASE(5)
+ IF(LPRESYT)THEN
+ ZTEM(1:II-1,:,:,1)=.5*(XPRES(1:II-1,:,:,NLOOPT,IN,IP)+XPRES(2:II,:,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(1:II-1,:,:,:)=.5*(XVAR(1:II-1,:,:,:,IN,IP)+XVAR(2:II,:,:,:,IN,IP))
+ ENDIF
+ ZTEM(II,:,:,:)=2.*ZTEM(II-1,:,:,:)-ZTEM(II-2,:,:,:)
+ END SELECT
+ CASE(4)
+ SELECT CASE(IG)
+ CASE(3,7)
+ IF(LPRESYT)THEN
+ ZTEM(:,1:IJ-1,:,1)=.5*(XPRES(:,1:IJ-1,:,NLOOPT,IN,IP)+XPRES(:,2:IJ,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(:,1:IJ-1,:,:)=.5*(XVAR(:,1:IJ-1,:,:,IN,IP)+XVAR(:,2:IJ,:,:,IN,IP))
+ ENDIF
+ ZTEM(:,IJ,:,:)=2.*ZTEM(:,IJ-1,:,:)-ZTEM(:,IJ-2,:,:)
+ CASE(2,6)
+ IF(LPRESYT)THEN
+ ZTEM(1:II-1,:,:,1)=.5*(XPRES(1:II-1,:,:,NLOOPT,IN,IP)+XPRES(2:II,:,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(1:II-1,:,:,:)=.5*(XVAR(1:II-1,:,:,:,IN,IP)+XVAR(2:II,:,:,:,IN,IP))
+ ENDIF
+ ZTEM(II,:,:,:)=2.*ZTEM(II-1,:,:,:)-ZTEM(II-2,:,:,:)
+ CASE(5)
+ IF(LPRESYT)THEN
+ ZTEM(1:II-1,:,:,1)=.5*(XPRES(1:II-1,:,:,NLOOPT,IN,IP)+XPRES(2:II,:,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(1:II-1,:,:,:)=.5*(XVAR(1:II-1,:,:,:,IN,IP)+XVAR(2:II,:,:,:,IN,IP))
+ ENDIF
+ ZTEM(II,:,:,:)=2.*ZTEM(II-1,:,:,:)-ZTEM(II-2,:,:,:)
+ ZTEM(:,1:IJ-1,:,:)=.5*(ZTEM(:,1:IJ-1,:,:)+ZTEM(:,2:IJ,:,:))
+ ZTEM(:,IJ,:,:)=2.*ZTEM(:,IJ-1,:,:)-ZTEM(:,IJ-2,:,:)
+ END SELECT
+ CASE(5)
+ SELECT CASE(IG)
+ CASE(1,4)
+ IF(LPRESYT)THEN
+ ZTEM(2:II,:,:,1)=.5*(XPRES(1:II-1,:,:,NLOOPT,IN,IP)+XPRES(2:II,:,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(2:II,:,:,:)=.5*(XVAR(1:II-1,:,:,:,IN,IP)+XVAR(2:II,:,:,:,IN,IP))
+ ENDIF
+ ZTEM(1,:,:,:)=2.*ZTEM(2,:,:,:)-ZTEM(3,:,:,:)
+ ZTEM(:,2:IJ,:,:)=.5*(ZTEM(:,1:IJ-1,:,:)+ZTEM(:,2:IJ,:,:))
+ ZTEM(:,1,:,:)=2.*ZTEM(:,2,:,:)-ZTEM(:,3,:,:)
+ CASE(2,6)
+ IF(LPRESYT)THEN
+ ZTEM(:,2:IJ,:,1)=.5*(XPRES(:,1:IJ-1,:,NLOOPT,IN,IP)+XPRES(:,2:IJ,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(:,2:IJ,:,:)=.5*(XVAR(:,1:IJ-1,:,:,IN,IP)+XVAR(:,2:IJ,:,:,IN,IP))
+ ENDIF
+ ZTEM(:,1,:,:)=2.*ZTEM(:,2,:,:)-ZTEM(:,3,:,:)
+ CASE(3,7)
+ IF(LPRESYT)THEN
+ ZTEM(2:II,:,:,1)=.5*(XPRES(1:II-1,:,:,NLOOPT,IN,IP)+XPRES(2:II,:,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(2:II,:,:,:)=.5*(XVAR(1:II-1,:,:,:,IN,IP)+XVAR(2:II,:,:,:,IN,IP))
+ ENDIF
+ ZTEM(1,:,:,:)=2.*ZTEM(2,:,:,:)-ZTEM(3,:,:,:)
+ END SELECT
+ CASE(6)
+ SELECT CASE(IG)
+ CASE(1,4)
+ IF(LPRESYT)THEN
+ ZTEM(2:II,:,:,1)=.5*(XPRES(1:II-1,:,:,NLOOPT,IN,IP)+XPRES(2:II,:,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(2:II,:,:,:)=.5*(XVAR(1:II-1,:,:,:,IN,IP)+XVAR(2:II,:,:,:,IN,IP))
+ ENDIF
+ ZTEM(1,:,:,:)=2.*ZTEM(2,:,:,:)-ZTEM(3,:,:,:)
+ CASE(3,7)
+ IF(LPRESYT)THEN
+ ZTEM(:,1:IJ-1,:,1)=.5*(XPRES(:,1:IJ-1,:,NLOOPT,IN,IP)+XPRES(:,2:IJ,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(:,1:IJ-1,:,:)=.5*(XVAR(:,1:IJ-1,:,:,IN,IP)+XVAR(:,2:IJ,:,:,IN,IP))
+ ENDIF
+ ZTEM(:,IJ,:,:)=2.*ZTEM(:,IJ-1,:,:)-ZTEM(:,IJ-2,:,:)
+ ZTEM(2:II,:,:,:)=.5*(ZTEM(1:II-1,:,:,:)+ZTEM(2:II,:,:,:))
+ ZTEM(1,:,:,:)=2.*ZTEM(2,:,:,:)-ZTEM(3,:,:,:)
+ CASE(5)
+ IF(LPRESYT)THEN
+ ZTEM(:,1:IJ-1,:,1)=.5*(XPRES(:,1:IJ-1,:,NLOOPT,IN,IP)+XPRES(:,2:IJ,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(:,1:IJ-1,:,:)=.5*(XVAR(:,1:IJ-1,:,:,IN,IP)+XVAR(:,2:IJ,:,:,IN,IP))
+ ENDIF
+ ZTEM(:,IJ,:,:)=2.*ZTEM(:,IJ-1,:,:)-ZTEM(:,IJ-2,:,:)
+ END SELECT
+ CASE(7)
+ SELECT CASE(IG)
+ CASE(1,4)
+ IF(LPRESYT)THEN
+ ZTEM(:,2:IJ,:,1)=.5*(XVAR(:,1:IJ-1,:,NLOOPT,IN,IP)+XVAR(:,2:IJ,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(:,2:IJ,:,:)=.5*(XVAR(:,1:IJ-1,:,:,IN,IP)+XVAR(:,2:IJ,:,:,IN,IP))
+ ENDIF
+ ZTEM(:,1,:,:)=2.*ZTEM(:,2,:,:)-ZTEM(:,3,:,:)
+ CASE(2,6)
+ IF(LPRESYT)THEN
+ ZTEM(1:II-1,:,:,1)=.5*(XPRES(1:II-1,:,:,NLOOPT,IN,IP)+XPRES(2:II,:,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(1:II-1,:,:,:)=.5*(XVAR(1:II-1,:,:,:,IN,IP)+XVAR(2:II,:,:,:,IN,IP))
+ ENDIF
+ ZTEM(II,:,:,:)=2.*ZTEM(II-1,:,:,:)-ZTEM(II-2,:,:,:)
+ ZTEM(:,2:IJ,:,:)=.5*(ZTEM(:,1:IJ-1,:,:)+ZTEM(:,2:IJ,:,:))
+ ZTEM(:,1,:,:)=2.*ZTEM(:,2,:,:)-ZTEM(:,3,:,:)
+ CASE(5)
+ IF(LPRESYT)THEN
+ ZTEM(1:II-1,:,:,1)=.5*(XPRES(1:II-1,:,:,NLOOPT,IN,IP)+XPRES(2:II,:,:,NLOOPT,IN,IP))
+ ELSE
+ ZTEM(1:II-1,:,:,:)=.5*(XVAR(1:II-1,:,:,:,IN,IP)+XVAR(2:II,:,:,:,IN,IP))
+ ENDIF
+ ZTEM(II,:,:,:)=2.*ZTEM(II-1,:,:,:)-ZTEM(II-2,:,:,:)
+ END SELECT
+END SELECT
+ENDIF
+!
+! Decalages VERTICAUX
+!
+IF(IK /= 1)THEN
+SELECT CASE(NGRIDIAM)
+ CASE(1,2,3,5)
+ SELECT CASE(IG)
+ CASE(4,6,7)
+ ZTEM(:,:,1:IK-1,:)=.5*(ZTEM(:,:,1:IK-1,:)+ZTEM(:,:,2:IK,:))
+ ZTEM(:,:,IK,:)=2.*ZTEM(:,:,IK-1,:)-ZTEM(:,:,IK-2,:)
+ END SELECT
+ CASE(4,6,7)
+ SELECT CASE(IG)
+ CASE(1,2,3,5)
+ ZTEM(:,:,2:IK,:)=.5*(ZTEM(:,:,1:IK-1,:)+ZTEM(:,:,2:IK,:))
+ ZTEM(:,:,1,:)=2.*ZTEM(:,:,2,:)-ZTEM(:,:,3,:)
+ END SELECT
+END SELECT
+ENDIF
+
+IF(LPRESYT)THEN
+ XPRES(:,:,:,NLOOPT,IN,IP)=ZTEM(:,:,:,1)
+ELSE
+ XVAR(:,:,:,:,IN,IP)=ZTEM(:,:,:,:)
+ENDIF
+
+DEALLOCATE(ZTEM)
+!
+!----------------------------------------------------------------------------
+!
+!* 3. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE INTERP_GRIDS
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/interpolw.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/interpolw.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f8b2fc959963f0fa59f306f19876cf30f3869aad
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/interpolw.f90
@@ -0,0 +1,193 @@
+! ######spl
+ SUBROUTINE INTERPOLW(PZZU, PZZW, PSTRU, PSTRW)
+! ####################
+!
+!!**** *INTERPOLW* - Defines the display window for a cartesian model
+!!
+!! PURPOSE
+!! -------
+! Interpolation des composantes du vent pour les streamlines en CV
+!
+!
+!!** METHOD
+!! ------
+!!
+!
+!!
+!! EXTERNAL
+!! --------
+!! SET : defines NCAR window and viewport in normalized and user
+!! coordinates
+!! LABMOD : defines axis label format
+!! GRIDAL : draws axis divisions and ticks
+!! PERIM : draws a perimeter box for the current plot
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 10/04/02
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODD_DIM1
+USE MODD_GRID1
+USE MODN_NCAR
+!
+IMPLICIT NONE
+!
+!
+!* 0.1 Commons
+!
+COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+COMMON/TEMV/XZWORKZ,XZZDS,NINX,NINY
+#include "big.h"
+REAL,DIMENSION(N2DVERTX,2500):: XZWORKZ
+!REAL,DIMENSION(1000,400):: XZWORKZ
+REAL,DIMENSION(N2DVERTX):: XZZDS
+!REAL,DIMENSION(1000):: XZZDS
+INTEGER :: NINX, NINY
+LOGICAL :: LVERT, LHOR, LPT, LXABS
+!
+!* 0.2 Dummy arguments and results
+!
+REAL,DIMENSION(:,:) :: PZZU, PZZW, PSTRU, PSTRW
+!
+!* 0.3 Local variables
+!
+
+REAL :: ZZ, ZPASZ, ZR, ZT, ZMX
+!REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZW
+INTEGER :: I, J, K, IPASZ
+INTEGER :: ISZ, ITER,ID,IE
+!
+!-------------------------------------------------------------------------------
+IPASZ=NZSTR
+ZMX=0.
+DO K=1,NINY
+DO I=1,NINX
+ IF(XZWORKZ(I,K) /= XSPVAL)ZMX=MAX(ZMX,XZWORKZ(I,K))
+ENDDO
+ENDDO
+ZPASZ=ZMX /(IPASZ-1)
+if (nverbia >0)then
+print *,' IPASZ ZPASZ MAXVAL(XZWORKZ) ',IPASZ,ZPASZ,ZMX
+endif
+IF(ALLOCATED(XZSTR))DEALLOCATE(XZSTR)
+ALLOCATE(XZSTR(IPASZ))
+XZSTR(1)=0.
+DO J=2,IPASZ
+XZSTR(J)=XZSTR(J-1)+ZPASZ
+ENDDO
+if (nverbia >0)then
+print *,' **interpolw IPASZ XZSTR ',IPASZ
+print *,XZSTR
+endif
+!!!!!PROVI
+!IF(IPASZ == 100)THEN
+! J=NINY-1
+! ZT=XZWORKZ(20,J)-XZWORKZ(20,2)
+! print *,' I=20 XZWORKZ(20,I) DIFF rap '
+! print 102
+! DO I=J,2,-1
+! print 103,I,XZWORKZ(20,I),(XZWORKZ(20,I)-XZWORKZ(20,I-1)),(XZWORKZ(20,I)-XZWORKZ(20,I-1))/ZT,(XZWORKZ(1,I)-XZWORKZ(1,I-1))
+! 103 format(1X,I3,4(E15.8,5X))
+! ENDDO
+!ENDIF
+!!!!!PROVI
+
+PSTRU=XSPVAL
+PSTRW=XSPVAL
+DO J=1,IPASZ
+ ZZ=XZSTR(J)
+DO I=1,NINX
+DO K=1,NINY-1
+ IF(ZZ < XZWORKZ(I,2) .OR. ZZ > XZWORKZ(I,NINY-1))THEN
+ EXIT
+ ELSEIF(ZZ == XZWORKZ(I,K))THEN
+ IF(PZZU(I,K) == XSPVAL .OR. (PZZW(I,K) == XSPVAL))THEN
+ EXIT
+ ELSE
+ IF(PZZU(I,K) /= XSPVAL)THEN
+ PSTRU(I,J)=PZZU(I,K)
+ ENDIF
+ IF(PZZW(I,K) /= XSPVAL)THEN
+ PSTRW(I,J)=PZZW(I,K)
+ ENDIF
+ EXIT
+ ENDIF
+ ELSEIF(ZZ > XZWORKZ(I,K) .AND. ZZ < XZWORKZ(I,K+1))THEN
+ IF(XZWORKZ(I,K+1)-XZWORKZ(I,K) /= 0.)THEN
+ IF(PZZU(I,K) == XSPVAL .OR. PZZW(I,K) == XSPVAL .OR. &
+ PZZU(I,K+1) == XSPVAL .OR. PZZW(I,K+1) == XSPVAL )THEN
+if (nverbia >0)then
+ print *,'**interpolw I K PZZU(I,K),PZZU(I,K+1),PZZW(I,K), PZZW(I,K+1) ',&
+ I,K,PZZU(I,K),PZZU(I,K+1),PZZW(I,K), PZZW(I,K+1)
+endif
+ EXIT
+ ELSE
+
+ ZR=(ZZ-XZWORKZ(I,K))/(XZWORKZ(I,K+1)-XZWORKZ(I,K))
+ PSTRU(I,J)=PZZU(I,K) + ZR*(PZZU(I,K+1)-PZZU(I,K))
+ PSTRW(I,J)=PZZW(I,K) + ZR*(PZZW(I,K+1)-PZZW(I,K))
+ EXIT
+ ENDIF
+ ELSE
+ IF(PZZU(I,K) == XSPVAL .OR. (PZZW(I,K) == XSPVAL))THEN
+ EXIT
+ ELSE
+ IF(PZZU(I,K) /= XSPVAL)THEN
+ PSTRU(I,J)=PZZU(I,K)
+ ENDIF
+ IF(PZZW(I,K) /= XSPVAL)THEN
+ PSTRW(I,J)=PZZW(I,K)
+ ENDIF
+ EXIT
+ ENDIF
+ ENDIF
+ ENDIF
+ENDDO
+ENDDO
+ENDDO
+if (nverbia >0)then
+print *,' **interpolw sortie PSTRU,PSTRW '
+ISZ=SIZE(PSTRU,1)
+ITER=ISZ/5
+IF(ITER*5 > ISZ)ITER=ITER+1
+DO I=1,ITER
+ID=(I-1)*5 +1
+IE=ID+4
+print 101,ID,ID+1,ID+2,ID+3,ID+4
+print 102
+DO J=IPASZ,1,-1
+print 100,J,PSTRW(ID:IE,J),XZSTR(J)
+!print 100,J,PSTRU(ID:IE,J),XZSTR(J)
+ENDDO
+print 102
+ENDDO
+endif
+100 FORMAT(I3,5E13.6,E12.5)
+101 FORMAT(8X,I3,4(10X,I3),10X,'XZSTR')
+102 FORMAT(78('*'))
+!-----------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE INTERPOLW
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/interpxyz.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/interpxyz.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2c34f3cc82443a1587dc90d55f62326aff3b22e0
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/interpxyz.f90
@@ -0,0 +1,187 @@
+! ######spl
+MODULE MODI_INTERPXYZ
+INTERFACE
+! #####################################################################
+ SUBROUTINE INTERPXYZ(PAX,PAY,PAZ,PCHAMP, &
+ PX,PY,PZ, &
+ PXOR,PYOR,PDX,PDY, &
+ PZL,OTRAJ_GROUP, &
+ PRESX,PRESY,PRESZ,PRESCHAMP)
+! #####################################################################
+!
+!
+! entrees
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAX,PAY,PAZ,PCHAMP
+ !
+ !
+ !
+REAL, INTENT(INOUT) :: PX,PY,PZ !
+REAL, INTENT(IN) :: PXOR,PYOR,PDX,PDY !
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZL !
+LOGICAL, INTENT(IN) :: OTRAJ_GROUP
+!
+! sorties
+!
+REAL, INTENT(OUT) :: PRESX,PRESY,PRESZ,PRESCHAMP
+!
+!
+END SUBROUTINE INTERPXYZ
+!
+END INTERFACE
+!
+END MODULE MODI_INTERPXYZ
+! ######spl
+ SUBROUTINE INTERPXYZ(PAX,PAY,PAZ,PCHAMP, &
+ PX,PY,PZ, &
+ PXOR,PYOR,PDX,PDY, &
+ PZL,OTRAJ_GROUP, &
+ PRESX,PRESY,PRESZ,PRESCHAMP)
+! #####################################################################
+!
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! BUT DE LA ROUTINE : interpoler les trois champs (3D) LG?M
+! (ou trois champs 3D quelconques ecrits sur les points de masse)
+! en un point M, de coordonnees cartesiennes (x,y,z)
+! a priori non-situe sur un point de grille.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!
+!
+!!!!!!!!!!!!!!!!!!!!!!
+! Declarations
+!!!!!!!!!!!!!!!!!!!!!!
+!
+IMPLICIT NONE
+!
+! entrees
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PAX,PAY,PAZ,PCHAMP
+ !
+ !
+ !
+REAL, INTENT(INOUT) :: PX,PY,PZ !
+REAL, INTENT(IN) :: PXOR,PYOR,PDX,PDY !
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PZL !
+LOGICAL, INTENT(IN) :: OTRAJ_GROUP
+!
+! sorties
+!
+REAL, INTENT(OUT) :: PRESX,PRESY,PRESZ,PRESCHAMP
+!
+! locales
+!
+INTEGER :: II,IJ,IK,JK !
+INTEGER :: IKU !
+REAL :: ZEPS1,ZEPS2,ZEPS3 !
+REAL :: ZXREL,ZYREL !
+REAL, DIMENSION(SIZE(PZL,3)) :: ZZLXY !
+!
+!
+! initialisations des variables locales
+!
+IKU=SIZE(PZL,3)
+!
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! 1. Recherche de la maille contenant le point M(PX,PY,PZ) -> II,IJ,IK
+! Position de M au sein de la maille -> ZEPS1,ZEPS2,ZEPS3
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!
+! 1.a partie horizontale
+!
+ZXREL=(PX-PXOR)/PDX+2
+ZYREL=(PY-PYOR)/PDY+2
+!
+II=FLOOR(ZXREL)
+IJ=FLOOR(ZYREL)
+!
+ZEPS1=ZXREL-REAL(II)
+ZEPS2=ZYREL-REAL(IJ)
+!
+!
+! 1.b partie verticale
+!
+! 1.b.1 altitude des niveaux du modele sur la verticale (PX,PY)
+!
+DO JK=1,IKU
+ ZZLXY(JK)=ZEPS2*(ZEPS1*(PZL(II+1,IJ+1,JK))+(1-ZEPS1)*(PZL(II,IJ+1,JK))) &
+ + (1-ZEPS2)*(ZEPS1*(PZL(II+1,IJ,JK))+(1-ZEPS1)*(PZL(II,IJ,JK)))
+ENDDO
+!
+IK=999
+DO JK=2,IKU
+ IF (ZZLXY(JK).GE.PZ) THEN
+ IK=JK-1
+ EXIT
+ ENDIF
+ENDDO
+!
+IF (IK==1) THEN
+ print *,'la particule est sous le sol'
+ print *,' on la remonte a zs + dz/2 = ', ZZLXY(2)
+ PZ=ZZLXY(2)
+ENDIF
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!Emergency exit!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF (IK==999) THEN
+ PRINT*,'PROBLEME AU POINT',II,IJ
+ PRINT*,'XREL, YREL, Z =',ZXREL,ZYREL,PZ
+ PRINT*,'ZZLXY(IKU)',ZZLXY(IKU)
+ STOP
+END IF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+ZEPS3=(PZ-ZZLXY(IK))/(ZZLXY(IK+1)-ZZLXY(IK))
+!
+!------------------------------------------------------------------------------
+!
+!* 2. INTERPOLATION DES CHAMPS
+!
+PRESX= ZEPS3 * &
+ ( ZEPS2*(ZEPS1*(PAX(II+1,IJ+1,IK+1))+(1-ZEPS1)*(PAX(II,IJ+1,IK+1))) &
+ + (1-ZEPS2)*(ZEPS1*(PAX(II+1,IJ,IK+1))+(1-ZEPS1)*(PAX(II,IJ,IK+1))) &
+ ) &
+ + (1-ZEPS3) * &
+ ( ZEPS2*(ZEPS1*(PAX(II+1,IJ+1,IK))+(1-ZEPS1)*(PAX(II,IJ+1,IK))) &
+ + (1-ZEPS2)*(ZEPS1*(PAX(II+1,IJ,IK))+(1-ZEPS1)*(PAX(II,IJ,IK))) &
+ )
+!
+PRESY= ZEPS3 * &
+ ( ZEPS2*(ZEPS1*(PAY(II+1,IJ+1,IK+1))+(1-ZEPS1)*(PAY(II,IJ+1,IK+1))) &
+ + (1-ZEPS2)*(ZEPS1*(PAY(II+1,IJ,IK+1))+(1-ZEPS1)*(PAY(II,IJ,IK+1))) &
+ ) &
+ + (1-ZEPS3) * &
+ ( ZEPS2*(ZEPS1*(PAY(II+1,IJ+1,IK))+(1-ZEPS1)*(PAY(II,IJ+1,IK))) &
+ + (1-ZEPS2)*(ZEPS1*(PAY(II+1,IJ,IK))+(1-ZEPS1)*(PAY(II,IJ,IK))) &
+ )
+!
+PRESZ= ZEPS3 * &
+ ( ZEPS2*(ZEPS1*(PAZ(II+1,IJ+1,IK+1))+(1-ZEPS1)*(PAZ(II,IJ+1,IK+1))) &
+ + (1-ZEPS2)*(ZEPS1*(PAZ(II+1,IJ,IK+1))+(1-ZEPS1)*(PAZ(II,IJ,IK+1))) &
+ ) &
+ + (1-ZEPS3) * &
+ ( ZEPS2*(ZEPS1*(PAZ(II+1,IJ+1,IK))+(1-ZEPS1)*(PAZ(II,IJ+1,IK))) &
+ + (1-ZEPS2)*(ZEPS1*(PAZ(II+1,IJ,IK))+(1-ZEPS1)*(PAZ(II,IJ,IK))) &
+ )
+IF (OTRAJ_GROUP) THEN
+ PRESCHAMP= ZEPS3 * &
+ ( ZEPS2*(ZEPS1*(PCHAMP(II+1,IJ+1,IK+1))+(1-ZEPS1)*(PCHAMP(II,IJ+1,IK+1))) &
+ + (1-ZEPS2)*(ZEPS1*(PCHAMP(II+1,IJ,IK+1))+(1-ZEPS1)*(PCHAMP(II,IJ,IK+1))) &
+ ) &
+ + (1-ZEPS3) * &
+ ( ZEPS2*(ZEPS1*(PCHAMP(II+1,IJ+1,IK))+(1-ZEPS1)*(PCHAMP(II,IJ+1,IK))) &
+ + (1-ZEPS2)*(ZEPS1*(PCHAMP(II+1,IJ,IK))+(1-ZEPS1)*(PCHAMP(II,IJ,IK))) &
+ )
+ENDIF
+!
+!------------------------------------------------------------------------------
+!
+!
+END SUBROUTINE INTERPXYZ
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/kztnp.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/kztnp.f90
new file mode 100644
index 0000000000000000000000000000000000000000..833e51bffe370280f216fffa967a056cdc3e7def
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/kztnp.f90
@@ -0,0 +1,501 @@
+! ######spl
+ SUBROUTINE KZTNP(K)
+! ###################
+!
+!!**** *KZTNP* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!!
+!! NIOFFD : Label normalisation (=0 none, =/=0 active)
+!! NULBLL : Nb of contours between 2 labelled contours
+!! NIOFFM : =0 --> message at picture bottom
+!! =/= 0 --> no message
+!! NIOFFP : Special point value detection
+!! (=0 none, =/=0 active)
+!! NHI : Extrema detection
+!! (=0 --> H+L, <0 nothing)
+!! NINITA : For streamlimes
+!! NINITB : Not yet implemented
+!! NIGRNC : Not yet implemented
+!! NDOT : Line style
+!! (=0|1|1023|65535 --> solid lines;
+!! <0 --> solid lines for positive values and
+!! dotted lines(ABS(NDOT))for negative values;
+!! >0 --> dotted lines(ABS(NDOT)) )
+!! NIFDC : Coastline data style (0 none, 1 NCAR, 2 IGN)
+!! NLPCAR : Number of land-mark points to be plotted
+!! NIMNMX : Contour selection option
+!! (=-1 Min, max and inc. automatically set;
+!! =0 Min, max automatically set; inc. given;
+!! >0 Min, max, inc. given by user)
+!! NISKIP : Rate for drawing velocity vectors
+!! CTYPHOR : Horizontal cross-section type
+!! (='K' --> model level section;
+!! ='Z' --> constant-altitude section;
+!! ='P' --> isobar section (planned)
+!! ='T' --> isentrope section (planned)
+!! XSPVAL : Special value
+!! XSIZEL : Label size
+!! XLATCAR, XLONCAR : Lat. and Long. of land-mark points
+!! LXY : If =.TRUE., plots a grid-mesh stencil background
+!! LXZ : If =.TRUE., plots a model-level stencil background
+!!
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist
+!! (former PARA common)
+!!
+!! XIDEBCOU, XJDEBCOU : Origin of a vertical cross-section
+!! in cartesian (or conformal) real values
+!! XHMIN : Altitude of the vert. cross-section
+!! bottom (in meters above sea-level)
+!! XHMAX : Altitude of the vert. cross-section
+!! top (in meters above sea-level)
+!!
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODD_MASK3D
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_TYPE_AND_LH
+USE MODN_NCAR
+USE MODN_PARA
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+INTEGER :: K
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+INTEGER :: J, JJ, JE
+INTEGER :: IP1, IP2, IP3, IT
+INTEGER :: JLOOPN, INDN, JF, JLOOPNF
+INTEGER :: ILEN, INBGRA
+
+REAL :: ZDIF
+CHARACTER(LEN=8) :: YREP
+!------------------------------------------------------------------------------
+!
+! Traitement des processus
+!
+IF(LPROCDIALL(K))THEN
+
+ NBPROCDIA(K)=SIZE(XVAR,6)
+ DO J=1,NBPROCDIA(K)
+ NPROCDIA(J,K)=J
+ ENDDO
+
+ELSE
+
+ IF(LPINCRDIA(K))THEN
+
+ NPROCDIA(2,K)=MIN(NPROCDIA(2,K),SIZE(XVAR,6))
+
+ IF(NBPROCDIA(K) == 2)THEN
+
+ IP1=NPROCDIA(1,K)
+ IP2=NPROCDIA(2,K)
+ NBPROCDIA(K)=IP2-IP1+1
+ JJ=0
+ DO J=IP1,IP2
+ JJ=JJ+1
+ NPROCDIA(JJ,K)=J
+ ENDDO
+
+ ELSE IF(NBPROCDIA(K) == 3)THEN
+
+ IP1=NPROCDIA(1,K)
+ IP2=NPROCDIA(2,K)
+ IP3=NPROCDIA(3,K)
+ NBPROCDIA(K)=1
+ DO J=2,100
+ IP1=IP1+IP3
+ IF(IP1 > IP2)EXIT
+ NBPROCDIA(K)=NBPROCDIA(K)+1
+ NPROCDIA(J,K)=IP1
+ ENDDO
+
+ ENDIF
+
+ ENDIF
+
+ENDIF
+
+LPINCRDIA(K)=.FALSE.
+
+IF(NBPROCDIA(K) == 0)THEN
+ NPROCDIA(:,K)=0
+ENDIF
+
+!
+! Traitement des numeros de masques et trajectoires
+!
+IF(LNDIALL(K))THEN
+
+ NBNDIA(K)=SIZE(XVAR,5)
+ DO J=1,NBNDIA(K)
+ NNDIA(J,K)=J
+ ENDDO
+
+ELSE
+
+ IF(LNINCRDIA(K))THEN
+
+ NNDIA(2,K)=MIN(NNDIA(2,K),SIZE(XVAR,5))
+
+ IF(NBNDIA(K) == 2)THEN
+
+ IP1=NNDIA(1,K)
+ IP2=NNDIA(2,K)
+ NBNDIA(K)=IP2-IP1+1
+ JJ=0
+ DO J=IP1,IP2
+ JJ=JJ+1
+ NNDIA(JJ,K)=J
+ ENDDO
+
+ ELSE IF(NBNDIA(K) == 3)THEN
+
+ IP1=NNDIA(1,K)
+ IP2=NNDIA(2,K)
+ IP3=NNDIA(3,K)
+ NBNDIA(K)=1
+ DO J=2,100
+ IP1=IP1+IP3
+ IF(IP1 > IP2)EXIT
+ NBNDIA(K)=NBNDIA(K)+1
+ NNDIA(J,K)=IP1
+ ENDDO
+
+ ENDIF
+
+ ENDIF
+
+ENDIF
+
+LNINCRDIA(K)=.FALSE.
+
+IF(NBNDIA(K) == 0)THEN
+ NNDIA(:,K)=0
+ENDIF
+!
+! Traitement des temps
+!
+SELECT CASE(CTYPE)
+ CASE('MASK','SSOL','SPXY')
+ JLOOPNF=1
+ CASE DEFAULT
+ JLOOPNF=NBNDIA(K)
+END SELECT
+
+DO JLOOPN=1,JLOOPNF ! Boucle sur les Num traj ou stations
+
+SELECT CASE(CTYPE)
+ CASE('MASK','SSOL','SPXY')
+ INDN=1
+ CASE DEFAULT
+ INDN=NNDIA(JLOOPN,K)
+END SELECT
+
+SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY','SSOL')
+ JF=SIZE(XVAR,4)
+ CASE DEFAULT
+ DO JE=SIZE(XTRAJT,1),1,-1
+ IF(XTRAJT(JE,INDN) /= -1.E-15)THEN
+ JF=JE
+ EXIT
+ ENDIF
+ ENDDO
+END SELECT
+
+IF(LTIMEDIALL(K,INDN))THEN
+
+ LTINCRDIA(K,INDN)=.TRUE.
+ NBTIMEDIA(K,INDN)=3
+ NTIMEDIA(1,K,INDN)=1
+ NTIMEDIA(2,K,INDN)=JF
+ NTIMEDIA(3,K,INDN)=1
+
+ XTIMEDIA(1,K,INDN)=XTRAJT(NTIMEDIA(1,K,INDN),INDN)
+ XTIMEDIA(2,K,INDN)=XTRAJT(NTIMEDIA(2,K,INDN),INDN)
+
+ELSE
+
+ IF(LTINCRDIA(K,INDN))THEN
+! Incremental
+
+ IF(NTIMEDIA(2,K,INDN) /= 0)THEN
+ NTIMEDIA(2,K,INDN)=MIN(NTIMEDIA(2,K,INDN),JF)
+ ENDIF
+
+ IF(NBTIMEDIA(K,INDN) == 2)THEN
+
+ IP1=NTIMEDIA(1,K,INDN)
+ IP2=NTIMEDIA(2,K,INDN)
+ IF(IP1 /=0 .AND. IP2 /=0)THEN
+ NBTIMEDIA(K,INDN)=3
+ NTIMEDIA(3,K,INDN)=1
+ XTIMEDIA(1,K,INDN)=XTRAJT(NTIMEDIA(1,K,INDN),INDN)
+ XTIMEDIA(2,K,INDN)=XTRAJT(NTIMEDIA(2,K,INDN),INDN)
+! CONTROLER LA VALIDITE DES VALEURS
+
+ ELSE
+
+ DO J=1,JF
+ IF(XTIMEDIA(1,K,INDN) <= XTRAJT(J,INDN))EXIT
+ ENDDO
+ NTIMEDIA(1,K,INDN)=J
+ DO J=1,JF
+ IF(XTIMEDIA(2,K,INDN) <= XTRAJT(J,INDN))EXIT
+ ENDDO
+ NTIMEDIA(2,K,INDN)=J
+ NTIMEDIA(2,K,INDN)=MIN(NTIMEDIA(2,K,INDN),JF)
+ NBTIMEDIA(K,INDN)=3
+ NTIMEDIA(3,K,INDN)=1
+ ENDIF
+
+ ELSE IF(NBTIMEDIA(K,INDN) == 3)THEN
+
+ IP1=NTIMEDIA(1,K,INDN)
+ IP2=NTIMEDIA(2,K,INDN)
+ IP3=NTIMEDIA(3,K,INDN)
+ IF(IP1 /=0 .AND. IP2 /=0 .AND. IP3 /=0)THEN
+ XTIMEDIA(1,K,INDN)=XTRAJT(NTIMEDIA(1,K,INDN),INDN)
+ XTIMEDIA(2,K,INDN)=XTRAJT(NTIMEDIA(2,K,INDN),INDN)
+
+ ELSE
+
+
+ DO J=1,JF
+ IF(XTIMEDIA(1,K,INDN) <= XTRAJT(J,INDN))EXIT
+ ENDDO
+ NTIMEDIA(1,K,INDN)=J
+ DO J=1,JF
+ IF(XTIMEDIA(2,K,INDN) <= XTRAJT(J,INDN))EXIT
+ ENDDO
+ NTIMEDIA(2,K,INDN)=J
+ NTIMEDIA(2,K,INDN)=MIN(NTIMEDIA(2,K,INDN),JF)
+ ZDIF=ABS(XTRAJT(2,INDN)-XTRAJT(3,INDN))
+ IT=ANINT(XTIMEDIA(3,K,INDN)/ZDIF)
+ NTIMEDIA(3,K,INDN)=IT
+ ENDIF
+
+ ENDIF
+
+! Non incremental
+ ELSE
+ DO J=1,NBTIMEDIA(K,INDN)
+ IF(NTIMEDIA(J,K,INDN) /= 0)THEN
+ NTIMEDIA(J,K,INDN)=MIN(NTIMEDIA(J,K,INDN),JF)
+ XTIMEDIA(J,K,INDN)=XTRAJT(NTIMEDIA(J,K,INDN),INDN)
+
+ ELSE
+
+ DO JJ=1,JF
+ IF(XTIMEDIA(J,K,INDN) <= XTRAJT(JJ,INDN))EXIT
+ ENDDO
+ NTIMEDIA(J,K,INDN)=JJ
+ NTIMEDIA(J,K,INDN)=MIN(NTIMEDIA(J,K,INDN),JF)
+
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ENDIF
+ENDDO ! Fin boucle Num traj ou stations
+!
+! Traitement des niveaux de modele K
+!
+SELECT CASE(CTYPE)
+ CASE('MASK')
+! CASE('MASK','SSOL')
+ JLOOPNF=1
+ CASE DEFAULT
+ JLOOPNF=NBNDIA(K)
+END SELECT
+
+DO JLOOPN=1,JLOOPNF ! Boucle sur les Num traj ou stations
+
+SELECT CASE(CTYPE)
+ CASE('MASK')
+! CASE('MASK','SSOL')
+ INDN=1
+ CASE DEFAULT
+ INDN=NNDIA(JLOOPN,K)
+END SELECT
+
+SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ JF=SIZE(XVAR,3)
+ CASE('SSOL','DRST','RSPL','RAPL')
+ DO JE=SIZE(XTRAJZ,1),1,-1
+! Le 2eme indice (temps) est mis arbitrairement a 1 parce que la
+! dimension en K pour le temps indice 1 est la meme que pour le
+! temps indice n.
+ IF(XTRAJZ(JE,1,INDN) /= -1.E-15)THEN
+ JF=JE
+ NKL=1
+ NKH=JF
+ EXIT
+ ENDIF
+ ENDDO
+END SELECT
+
+IF(LVLKDIALL(K,INDN))THEN
+
+ NBLVLKDIA(K,INDN)=JF
+ DO J=1,NBLVLKDIA(K,INDN)
+ NLVLKDIA(J,K,INDN)=J+NKL-1
+ ENDDO
+
+ELSE
+
+ IF(LKINCRDIA(K,INDN))THEN
+
+ IF(NBLVLKDIA(K,INDN) == 2)THEN
+
+ IP1=MAX(NLVLKDIA(1,K,INDN),NKL)
+ IP2=MIN(NLVLKDIA(2,K,INDN),NKH)
+ NBLVLKDIA(K,INDN)=IP2-IP1+1
+ JJ=0
+ DO J=IP1,IP2
+ JJ=JJ+1
+ NLVLKDIA(JJ,K,INDN)=J
+ ENDDO
+
+ ELSE IF(NBLVLKDIA(K,INDN) == 3)THEN
+
+ IP1=MAX(NLVLKDIA(1,K,INDN),NKL)
+ IP2=MIN(NLVLKDIA(2,K,INDN),NKH)
+ IP3=NLVLKDIA(3,K,INDN)
+ NLVLKDIA(1,K,INDN)=IP1
+ NLVLKDIA(2,K,INDN)=IP2
+ NBLVLKDIA(K,INDN)=1
+ DO J=2,1000
+ IP1=IP1+IP3
+ IF(IP1 > IP2)EXIT
+ NBLVLKDIA(K,INDN)=NBLVLKDIA(K,INDN)+1
+ NLVLKDIA(J,K,INDN)=IP1
+ ENDDO
+
+ ENDIF
+
+ ENDIF
+
+ENDIF
+
+LKINCRDIA(K,INDN)=.FALSE.
+
+IF(NBLVLKDIA(K,INDN) == 0)THEN
+ NLVLKDIA(:,K,INDN)=0
+ENDIF
+ENDDO ! Fin boucle Num traj ou stations
+!
+! Traitement des altitudes Z
+!
+! On a directement les altitudes en numerique en incremental ou non.
+! Si (LZINCRDIA(K)) --> NBLVLZDIA(K)=3
+! XLVLZDIA(1:3,K)= extremes + increment
+! Si (.NOT.LZINCRDIA(K)) --> NBLVLZDIA(K)=N
+! XLVLZDIA(1:N,K)=altitudes
+!
+!
+! Positionnement de CTYPHOR
+!
+SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ CTYPHOR(1:LEN(CTYPHOR))=' '
+ IF(NBLVLKDIA(K,1) == 0 .AND. NBLVLZDIA(K) /=0 )THEN
+ IF(LPR)THEN
+ CTYPHOR='P'
+ ELSE IF(LTK)THEN
+ CTYPHOR='T'
+ ELSE IF(LEV)THEN
+ CTYPHOR='E'
+ ELSE IF(LSV3)THEN
+ CTYPHOR='V'
+ ELSE
+ CTYPHOR='Z'
+ ENDIF
+ LHORIZ=.TRUE.; LVERTI=.FALSE.
+ ELSE IF(NBLVLKDIA(K,1) /= 0 .AND. NBLVLZDIA(K) ==0 )THEN
+ CTYPHOR='K'
+ LHORIZ=.TRUE.; LVERTI=.FALSE.
+
+ IF(LTINCRDIA(K,1))THEN
+ ILEN=(NTIMEDIA(2,K,1)-NTIMEDIA(1,K,1))/NTIMEDIA(3,K,1)+1
+ ELSE
+ ILEN=NBTIMEDIA(K,1)
+ ENDIF
+
+ INBGRA=NBPROCDIA(K)*NBLVLKDIA(K,1)*ILEN
+
+ IF(INBGRA > 35 .AND. LCH .AND. CTYPE /= 'SPXY')THEN
+ print *,'VOUS AVEZ DEMANDE: ',NBLVLKDIA(K,1),' NIVEAUX * ', &
+& ILEN,' TEMPS * ',NBPROCDIA(K),' PROCESSUS = '
+ print *,INBGRA,' GRAPHIQUES '
+ print *,' EN ETES VOUS SUR ???? (y/n) '
+ YREP(1:LEN(YREP))=' '
+ READ(5,*)YREP
+ SELECT CASE(YREP)
+ CASE('y','Y','o','O','yes','YES','oui','OUI')
+ CASE DEFAULT
+ LPBREAD=.TRUE.
+ print *,' VERIFIEZ LA SYNTAXE DE VOTRE DIRECTIVE ET RENTREZ LA A ',&
+& 'NOUVEAU'
+ END SELECT
+ ENDIF
+
+ ENDIF
+ CASE DEFAULT
+END SELECT
+
+
+
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE KZTNP
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/latlongrid.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/latlongrid.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1831424ab923ef4dd9e766e02987c943db8f4148
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/latlongrid.f90
@@ -0,0 +1,78 @@
+! ######spl
+ SUBROUTINE LATLONGRID
+! ################################
+!
+!!**** *LATLONGRID* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 16/06/98
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_NMGRID
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+!
+!* 0.1 Local variables
+! ---------------
+! !------------------------------------------------------------------------------
+NLATLON=0
+NLATLON=INDEX(CCOMMENT(NLOOPP),'LATLON')
+IF(NLATLON == 0)THEN
+ NLATLON=INDEX(CCOMMENT(NLOOPP),'Latlon')
+ENDIF
+IF(NLATLON == 0)THEN
+ NLATLON=INDEX(CCOMMENT(NLOOPP),'latlon')
+ENDIF
+IF(NLATLON == 0)THEN
+ NLATLON=INDEX(CCOMMENT(NLOOPP),'LatLon')
+ENDIF
+IF(NVERBIA > 5)THEN
+ print *,' NLATLON,CCOMMENT(NLOOPP) ',NLATLON,CCOMMENT(NLOOPP)
+ENDIF
+NMGRID=NGRIDIA(NLOOPP)
+IF(NMGRID <1 .OR. NMGRID >7)THEN
+ PRINT *,' VALEUR NMGRID ABERRANTE: ',NMGRID, &
+ ' FORCEE A : 1'
+ NMGRID=1
+ENDIF
+RETURN
+END SUBROUTINE LATLONGRID
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/load_expr.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/load_expr.f90
new file mode 100644
index 0000000000000000000000000000000000000000..362dc3c7955e572565a209cac235b4055ce72bfe
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/load_expr.f90
@@ -0,0 +1,542 @@
+! ######spl
+ SUBROUTINE LOAD_EXPR(KIND,HCARIN)
+! ################################
+!
+!!**** *LOAD_FMTAXES* -
+!!
+!! PURPOSE
+!! -------
+! Analyser l'expression a mutiplier ou diviser (actuellement un
+! processus) et le charger en memoire pour le calcul ulterieur
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 02/07/01
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_EXPR
+USE MODN_NCAR
+USE MODD_FILES_DIACHRO
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_SEVERAL_RECORDS
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+INTEGER :: KIND
+CHARACTER(LEN=*) :: HCARIN
+!
+!* 0.1 Local variables
+! ---------------
+CHARACTER(LEN=LEN(HCARIN)) :: YCARIN
+CHARACTER(LEN=20) :: YTEM
+CHARACTER(LEN=16) :: YGROUP
+CHARACTER(LEN=1) :: YSTAR
+INTEGER,SAVE :: INDEXPR, ILEN, IPARG, IPARD, IETOILE,IMULT
+INTEGER,SAVE :: IEGAL, J,JM, IP, IPR
+INTEGER :: INDPLUS, INDMINUS
+REAL,SAVE :: ZCONSTANTE
+! !------------------------------------------------------------------------------
+!*********************************************
+! Cas RM*EXPRx (RM/EXPRx) et *EXPRx= (/EXPRx=)
+!*********************************************
+IF(KIND == 0)THEN
+ INDEXPR=INDEX(HCARIN,'RM*')
+ IF(INDEXPR /= 0)THEN
+! RM*EXPRx
+!!!!!!!!!!
+ IF(HCARIN == 'RM*EXPR1')THEN
+ IF(ALLOCATED(XEXPR1))DEALLOCATE(XEXPR1)
+ ELSE IF(HCARIN == 'RM*EXPR2')THEN
+ IF(ALLOCATED(XEXPR2))DEALLOCATE(XEXPR2)
+ ELSE IF(HCARIN == 'RM*EXPR3')THEN
+ IF(ALLOCATED(XEXPR3))DEALLOCATE(XEXPR3)
+ ELSE IF(HCARIN == 'RM*EXPR4')THEN
+ IF(ALLOCATED(XEXPR4))DEALLOCATE(XEXPR4)
+ ELSE IF(HCARIN == 'RM*EXPR5')THEN
+ IF(ALLOCATED(XEXPR5))DEALLOCATE(XEXPR5)
+ ELSE IF(HCARIN == 'RM*EXPR6')THEN
+ IF(ALLOCATED(XEXPR6))DEALLOCATE(XEXPR6)
+ ELSE IF(HCARIN == 'RM*EXPR7')THEN
+ IF(ALLOCATED(XEXPR7))DEALLOCATE(XEXPR7)
+ ELSE IF(HCARIN == 'RM*EXPR8')THEN
+ IF(ALLOCATED(XEXPR8))DEALLOCATE(XEXPR8)
+ ELSE IF(HCARIN == 'RM*EXPR9')THEN
+ IF(ALLOCATED(XEXPR9))DEALLOCATE(XEXPR9)
+ ENDIF
+ ELSE
+ INDEXPR=INDEX(HCARIN,'RM/')
+ IF(INDEXPR /= 0)THEN
+! RM/EXPRx
+!!!!!!!!!!
+ IF(HCARIN == 'RM/EXPR1')THEN
+ IF(ALLOCATED(XDEXPR1))DEALLOCATE(XDEXPR1)
+ ELSE IF(HCARIN == 'RM/EXPR2')THEN
+ IF(ALLOCATED(XDEXPR2))DEALLOCATE(XDEXPR2)
+ ELSE IF(HCARIN == 'RM/EXPR3')THEN
+ IF(ALLOCATED(XDEXPR3))DEALLOCATE(XDEXPR3)
+ ELSE IF(HCARIN == 'RM/EXPR4')THEN
+ IF(ALLOCATED(XDEXPR4))DEALLOCATE(XDEXPR4)
+ ELSE IF(HCARIN == 'RM/EXPR5')THEN
+ IF(ALLOCATED(XDEXPR5))DEALLOCATE(XDEXPR5)
+ ELSE IF(HCARIN == 'RM/EXPR6')THEN
+ IF(ALLOCATED(XDEXPR6))DEALLOCATE(XDEXPR6)
+ ELSE IF(HCARIN == 'RM/EXPR7')THEN
+ IF(ALLOCATED(XDEXPR7))DEALLOCATE(XDEXPR7)
+ ELSE IF(HCARIN == 'RM/EXPR8')THEN
+ IF(ALLOCATED(XDEXPR8))DEALLOCATE(XDEXPR8)
+ ELSE IF(HCARIN == 'RM/EXPR9')THEN
+ IF(ALLOCATED(XDEXPR9))DEALLOCATE(XDEXPR9)
+ ENDIF
+ ELSE
+! *EXPRx= ou /EXPRx=
+!!!!!!!!!!!!!!!!!!!!
+! *EXPRx=
+!!!!!!!!!
+! /EXPRx=
+!!!!!!!!!
+ YCARIN(1:LEN(YCARIN))=' '
+ INDEXPR=INDEX(HCARIN,'*EXPR')
+
+ IF(INDEXPR == 0)THEN
+ INDEXPR=INDEX(HCARIN,'/EXPR')
+ YSTAR='*'
+ ELSE
+ YSTAR='*'
+ ENDIF
+
+ INDEXPR=INDEX(HCARIN,'=')
+ IEGAL=INDEX(HCARIN,'=')
+! Extraction du champ
+ YCARIN=HCARIN(INDEXPR+1:LEN_TRIM(HCARIN))
+ YCARIN=ADJUSTL(YCARIN)
+ ILEN=LEN_TRIM(YCARIN)
+! Eventuelle constante a * ou +
+ IPARG=INDEX(YCARIN,'(')
+! Eventuel autre champ a - ou +
+ INDPLUS= INDEX(YCARIN,'_PLUS_')
+ INDMINUS= INDEX(YCARIN,'_MINUS_')
+ YTEM(1:LEN(YTEM))=' '
+
+ IF(IPARG /= 0)THEN
+ IPARD=INDEX(YCARIN,')')
+ IETOILE=INDEX(YCARIN(IPARG:IPARD),YSTAR)
+ ZCONSTANTE=0
+ IF(IETOILE /= 0)THEN
+! Multiplication par une constante
+ IMULT=2
+ READ(YCARIN(IETOILE+IPARG:IPARD-1),*)ZCONSTANTE
+ YTEM(1:IPARG-1)=YCARIN(1:IPARG-1)
+ YTEM(IPARG:IPARG+ILEN-IPARD)=YCARIN(IPARD+1:ILEN)
+ ELSE
+! Addition d'une constante
+ IMULT=1
+ READ(YCARIN(IPARG+1:IPARD-1),*)ZCONSTANTE
+ YTEM(1:IPARG-1)=YCARIN(1:IPARG-1)
+ YTEM(IPARG:IPARG+ILEN-IPARD)=YCARIN(IPARD+1:ILEN)
+ ENDIF
+ ELSE IF(INDPLUS /= 0)THEN
+ IMULT=0
+! Addition d'un autre champ
+ YTEM(1:INDPLUS-1)=YCARIN(1:INDPLUS-1)
+ ELSE IF(INDMINUS /= 0)THEN
+ IMULT=0
+! Soustraction d'un autre champ
+ YTEM(1:INDMINUS-1)=YCARIN(1:INDMINUS-1)
+ ELSE
+! Pas de cste
+ IMULT=0
+ YTEM(1:ILEN)=YCARIN(1:ILEN)
+ ENDIF
+ YTEM=ADJUSTL(YTEM)
+ print *,' ** load_expr IMULT,zconstante YTEM ',IMULT,zconstante,YTEM
+ ILEN=LEN_TRIM(YTEM)
+ INDEXPR=INDEX(YTEM,'_P_')
+ YGROUP(1:LEN(YGROUP))=' '
+ IF(INDEXPR == 0)THEN
+ YGROUP=YTEM(1:ILEN)
+ ELSE
+ YGROUP=YTEM(1:INDEXPR-1)
+ ENDIF
+ YGROUP=ADJUSTL(YGROUP)
+ IF(INDEXPR == 0)THEN
+ IP=1
+ ELSE
+ READ(YTEM(INDEXPR+3:ILEN),*)IP
+ ENDIF
+ DO J=1,NBFILES
+ IF(NUMFILES(J) == NUMFILECUR)THEN
+ JM=J
+ ENDIF
+ ENDDO
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ print *, ' ** load_expr PB avec le nom du groupe ',YGROUP
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ IF(LGROUP)THEN
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ ENDIF
+ IF(IP > SIZE(XVAR,6))THEN
+ print *, ' ** load_expr PB avec le numero de processus :',IP, &
+ ' > au nb de processus du groupe: ',SIZE(XVAR,6),'. Corrigez.'
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ ILEN=LEN_TRIM(YCARIN)
+ IF(HCARIN(1:6) == '*EXPR1')THEN
+ IF(ALLOCATED(XEXPR1))DEALLOCATE(XEXPR1)
+ ALLOCATE(XEXPR1(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPRX(XEXPR1)
+ ELSE IF(HCARIN(1:6) == '*EXPR2')THEN
+ IF(ALLOCATED(XEXPR2))DEALLOCATE(XEXPR2)
+ ALLOCATE(XEXPR2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPRX(XEXPR2)
+ ELSE IF(HCARIN(1:6) == '*EXPR3')THEN
+ IF(ALLOCATED(XEXPR3))DEALLOCATE(XEXPR3)
+ ALLOCATE(XEXPR3(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPRX(XEXPR3)
+ ELSE IF(HCARIN(1:6) == '*EXPR4')THEN
+ IF(ALLOCATED(XEXPR4))DEALLOCATE(XEXPR4)
+ ALLOCATE(XEXPR4(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPRX(XEXPR4)
+ ELSE IF(HCARIN(1:6) == '*EXPR5')THEN
+ IF(ALLOCATED(XEXPR5))DEALLOCATE(XEXPR5)
+ ALLOCATE(XEXPR5(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPRX(XEXPR5)
+ ELSE IF(HCARIN(1:6) == '*EXPR6')THEN
+ IF(ALLOCATED(XEXPR6))DEALLOCATE(XEXPR6)
+ ALLOCATE(XEXPR6(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPRX(XEXPR6)
+ ELSE IF(HCARIN(1:6) == '*EXPR7')THEN
+ IF(ALLOCATED(XEXPR7))DEALLOCATE(XEXPR7)
+ ALLOCATE(XEXPR7(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPRX(XEXPR7)
+ ELSE IF(HCARIN(1:6) == '*EXPR8')THEN
+ IF(ALLOCATED(XEXPR8))DEALLOCATE(XEXPR8)
+ ALLOCATE(XEXPR8(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ XEXPR8(:,:,:,:,:,1)=XVAR(:,:,:,:,:,IP)
+ CALL LOAD_EXPRX(XEXPR8)
+ ELSE IF(HCARIN(1:6) == '*EXPR9')THEN
+ IF(ALLOCATED(XEXPR9))DEALLOCATE(XEXPR9)
+ ALLOCATE(XEXPR9(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPRX(XEXPR9)
+!
+ ELSE IF(HCARIN(1:6) == '/EXPR1')THEN
+ IF(ALLOCATED(XDEXPR1))DEALLOCATE(XDEXPR1)
+ ALLOCATE(XDEXPR1(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPR1X(XDEXPR1)
+ ELSE IF(HCARIN(1:6) == '/EXPR2')THEN
+ IF(ALLOCATED(XDEXPR2))DEALLOCATE(XDEXPR2)
+ ALLOCATE(XDEXPR2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPR1X(XDEXPR2)
+ ELSE IF(HCARIN(1:6) == '/EXPR3')THEN
+ IF(ALLOCATED(XDEXPR3))DEALLOCATE(XDEXPR3)
+ ALLOCATE(XDEXPR3(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPR1X(XDEXPR3)
+ ELSE IF(HCARIN(1:6) == '/EXPR4')THEN
+ IF(ALLOCATED(XDEXPR4))DEALLOCATE(XDEXPR4)
+ ALLOCATE(XDEXPR4(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPR1X(XDEXPR4)
+ ELSE IF(HCARIN(1:6) == '/EXPR5')THEN
+ IF(ALLOCATED(XDEXPR5))DEALLOCATE(XDEXPR5)
+ ALLOCATE(XDEXPR5(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPR1X(XDEXPR5)
+ ELSE IF(HCARIN(1:6) == '/EXPR6')THEN
+ IF(ALLOCATED(XDEXPR6))DEALLOCATE(XDEXPR6)
+ ALLOCATE(XDEXPR6(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPR1X(XDEXPR6)
+ ELSE IF(HCARIN(1:6) == '/EXPR7')THEN
+ IF(ALLOCATED(XDEXPR7))DEALLOCATE(XDEXPR7)
+ ALLOCATE(XDEXPR7(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPR1X(XDEXPR7)
+ ELSE IF(HCARIN(1:6) == '/EXPR8')THEN
+ IF(ALLOCATED(XDEXPR8))DEALLOCATE(XDEXPR8)
+ ALLOCATE(XDEXPR8(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPR1X(XDEXPR8)
+ ELSE IF(HCARIN(1:6) == '/EXPR9')THEN
+ IF(ALLOCATED(XDEXPR9))DEALLOCATE(XDEXPR9)
+ ALLOCATE(XDEXPR9(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),1))
+ CALL LOAD_EXPR1X(XDEXPR9)
+ ENDIF
+
+ ENDIF
+ ENDIF
+ELSE
+!*********************
+! Cas *EXPRx (/EXPRx)
+!*********************
+ IF(HCARIN == '*EXPR1')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XEXPR1(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '*EXPR2')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XEXPR2(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '*EXPR3')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XEXPR3(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '*EXPR4')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XEXPR4(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '*EXPR5')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XEXPR5(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '*EXPR6')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XEXPR6(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '*EXPR7')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XEXPR7(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '*EXPR8')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XEXPR8(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '*EXPR9')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XEXPR9(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+
+ ELSE IF(HCARIN == '/EXPR1')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL .AND. XDEXPR1(:,:,:,:,:,1) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XDEXPR1(:,:,:,:,:,1)
+ ELSEWHERE
+ XVAR(:,:,:,:,:,IPR)=XSPVAL
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '/EXPR2')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XDEXPR2(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '/EXPR3')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XDEXPR3(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '/EXPR4')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XDEXPR4(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '/EXPR5')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XDEXPR5(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '/EXPR6')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XDEXPR6(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '/EXPR7')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XDEXPR7(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '/EXPR8')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XDEXPR8(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ELSE IF(HCARIN == '/EXPR9')THEN
+ DO IPR=1,SIZE(XVAR,6)
+ WHERE(XVAR(:,:,:,:,:,IPR) /= XSPVAL)
+ XVAR(:,:,:,:,:,IPR)=XVAR(:,:,:,:,:,IPR)*XDEXPR9(:,:,:,:,:,1)
+ ENDWHERE
+ ENDDO
+ ENDIF
+ENDIF
+RETURN
+
+CONTAINS
+ SUBROUTINE LOAD_EXPRX(PEXPR)
+REAL,DIMENSION(:,:,:,:,:,:) :: PEXPR
+REAL :: ZFAC
+
+PEXPR(:,:,:,:,:,1)=XVAR(:,:,:,:,:,IP)
+CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+IF(IMULT == 2)PEXPR=PEXPR*ZCONSTANTE
+IF(IMULT == 1)PEXPR=PEXPR+ZCONSTANTE
+
+IF(INDPLUS/=0 .OR. INDMINUS/=0) THEN
+ IF (INDPLUS/=0) THEN
+ YGROUP=YCARIN(INDPLUS+6:ILEN)
+ ZFAC=1.
+ ELSE IF (INDMINUS/=0) THEN
+ YGROUP=YCARIN(INDPLUS+7:ILEN)
+ ZFAC=-1.
+ END IF
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ print *, ' ** load_expr PB avec le nom du groupe dans exprx',YGROUP
+ IF(ALLOCATED(XVAR)) CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ RETURN
+ ENDIF
+ IF(LGROUP)THEN
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ ENDIF
+ IF(IP > SIZE(XVAR,6))THEN
+ print *, ' ** load_expr PB avec le numero de processus :',IP, &
+ ' > au nb de processus du groupe: ',SIZE(XVAR,6),'. Corrigez.'
+ IF(ALLOCATED(XVAR)) CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ RETURN
+ ENDIF
+ WHERE( (PEXPR(:,:,:,:,:,1) == XSPVAL) .OR. &
+ (XVAR (:,:,:,:,:,IP) == XSPVAL) )
+ PEXPR(:,:,:,:,:,1)= XSPVAL
+ ELSEWHERE
+ PEXPR(:,:,:,:,:,1)=PEXPR(:,:,:,:,:,1)+ZFAC*XVAR(:,:,:,:,:,IP)
+ ENDWHERE
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ENDIF
+
+END SUBROUTINE LOAD_EXPRX
+
+ SUBROUTINE LOAD_EXPR1X(PEXPR)
+REAL,DIMENSION(:,:,:,:,:,:) :: PEXPR
+REAL :: ZFAC
+
+PEXPR(:,:,:,:,:,1)=XVAR(:,:,:,:,:,IP)
+CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+IF(IMULT == 2)THEN
+ WHERE(PEXPR /= XSPVAL)
+ PEXPR=PEXPR*ZCONSTANTE
+ ENDWHERE
+ELSEIF(IMULT == 1)THEN
+ WHERE(XDEXPR1 /= XSPVAL)
+ PEXPR=PEXPR+ZCONSTANTE
+ ENDWHERE
+ENDIF
+
+IF(INDPLUS/=0 .OR. INDMINUS/=0) THEN
+ IF (INDPLUS/=0) THEN
+ YGROUP=YCARIN(INDPLUS+6:ILEN)
+ ZFAC=1.
+ ELSE IF (INDMINUS/=0) THEN
+ YGROUP=YCARIN(INDPLUS+7:ILEN)
+ ZFAC=-1.
+ END IF
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ print *, ' ** load_expr PB avec le nom du groupe dans expr1x',YGROUP
+ IF(ALLOCATED(XVAR)) CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ RETURN
+ ENDIF
+ IF(LGROUP)THEN
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ ENDIF
+ IF(IP > SIZE(XVAR,6))THEN
+ print *, ' ** load_expr PB avec le numero de processus :',IP, &
+ ' > au nb de processus du groupe: ',SIZE(XVAR,6),'. Corrigez.'
+ IF(ALLOCATED(XVAR)) CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ RETURN
+ ENDIF
+ WHERE( (PEXPR(:,:,:,:,:,1) == XSPVAL) .OR. &
+ (XVAR (:,:,:,:,:,IP) == XSPVAL) )
+ PEXPR(:,:,:,:,:,1)= XSPVAL
+ ELSEWHERE
+ PEXPR(:,:,:,:,:,1)=PEXPR(:,:,:,:,:,1)+ZFAC*XVAR(:,:,:,:,:,IP)
+ ENDWHERE
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ENDIF
+
+WHERE(PEXPR(:,:,:,:,:,1) /= XSPVAL .AND. PEXPR(:,:,:,:,:,1) /= 0.)
+ PEXPR(:,:,:,:,:,1)=1./PEXPR(:,:,:,:,:,1)
+ELSEWHERE
+ PEXPR(:,:,:,:,:,1)=XSPVAL
+ENDWHERE
+END SUBROUTINE LOAD_EXPR1X
+
+END SUBROUTINE LOAD_EXPR
+
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/load_fmtaxes.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/load_fmtaxes.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8038f5c7f413e2f7c17d8bd9967d0d101c9f9d30
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/load_fmtaxes.f90
@@ -0,0 +1,120 @@
+! ######spl
+ MODULE MODI_LOAD_FMTAXES
+! #########################
+!
+INTERFACE
+!
+SUBROUTINE LOAD_FMTAXES(HCARIN,K)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: K
+END SUBROUTINE LOAD_FMTAXES
+!
+END INTERFACE
+!
+END MODULE MODI_LOAD_FMTAXES
+! ######spl
+ SUBROUTINE LOAD_FMTAXES(HCARIN,K)
+! ################################
+!
+!!**** *LOAD_FMTAXES* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 02/08/00
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+INTEGER :: K
+CHARACTER(LEN=*) :: HCARIN
+!
+!* 0.1 Local variables
+! ---------------
+INTEGER :: IEGAL,IQ1,IQ2
+! !------------------------------------------------------------------------------
+!nverbia=6
+IEGAL=INDEX(HCARIN,'=')
+IQ2=LEN_TRIM(HCARIN)
+IQ1=INDEX(HCARIN,'"')
+IF(IQ1 == 0)THEN
+ IQ1=INDEX(HCARIN,"'")
+ENDIF
+IF(IQ1 == 0 .OR. IQ1 == IQ2)THEN
+ IQ1=IEGAL
+ENDIF
+IF(HCARIN(IQ2:IQ2) == "'" .OR. HCARIN(IQ2:IQ2) == '"')THEN
+ELSE
+ IQ2=IQ2+1
+ENDIF
+!print *,' HCARIN(K:IEGAL-1) ',HCARIN(K:IEGAL-1)
+IF(HCARIN(K:IEGAL-1) == 'CFMTAXEX')THEN
+ CFMTAXEX=' '
+ CFMTAXEX=HCARIN(IQ1+1:IQ2-1)
+ CFMTAXEX=ADJUSTL(CFMTAXEX)
+! CFMTAXEX="'"//HCARIN(IQ1+1:IQ2-1)//"'"
+ if(nverbia >0)then
+ print *,' CFMTAXEX=',CFMTAXEX
+ endif
+ELSEIF(HCARIN(K:IEGAL-1) == 'CFMTAXEY')THEN
+ CFMTAXEY=' '
+ CFMTAXEY=HCARIN(IQ1+1:IQ2-1)
+ CFMTAXEY=ADJUSTL(CFMTAXEY)
+! CFMTAXEY="'"//HCARIN(IQ1+1:IQ2-1)//"'"
+ if(nverbia >0)then
+ print *,' CFMTAXEY=',CFMTAXEY
+ endif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!! pour les retrotrajectoires !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ELSEIF(HCARIN(K:IEGAL-1) == 'CFMTRTRAJ')THEN
+ CFMTRTRAJ=' '
+ CFMTRTRAJ=HCARIN(IQ1+1:IQ2-1)
+ CFMTRTRAJ=ADJUSTL(CFMTRTRAJ)
+ if(nverbia >0)then
+ print *,' CFMTRTRAJ=',CFMTRTRAJ
+ endif
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ELSE
+ print *, ' Erreur Passage ds LOAD_FMTAXES mais la variable n''est ni CFMTAXEX ni CFMTAXEY ni CFMTRTRAJ'
+ENDIF
+RETURN
+END SUBROUTINE LOAD_FMTAXES
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/load_segments.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/load_segments.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e48dc89b55ee1e24bdc131c3d6c0e84a1c75830c
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/load_segments.f90
@@ -0,0 +1,142 @@
+! ######spl
+ MODULE MODI_LOAD_SEGMENTS
+! #########################
+!
+INTERFACE
+!
+SUBROUTINE LOAD_SEGMENTS(HCARIN,K)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: K
+END SUBROUTINE LOAD_SEGMENTS
+!
+END INTERFACE
+!
+END MODULE MODI_LOAD_SEGMENTS
+! ######spl
+ SUBROUTINE LOAD_SEGMENTS(HCARIN,K)
+! ################################
+!
+!!**** *LOAD_SEGMENTS* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 02/08/00
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS, ONLY : JPHEXT
+USE MODD_DIM1, ONLY : NIMAX,NJMAX
+USE MODD_RESOLVCAR
+USE MODD_GRID1
+USE MODD_ALLOC_FORDIACHRO, ONLY : NGRIDIA
+USE MODD_COORD, ONLY : XXX,XXY
+USE MODE_GRIDPROJ
+USE MODI_RESOLVXISOLEV
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+INTEGER :: K
+CHARACTER(LEN=*) :: HCARIN
+!
+!* 0.1 Local variables
+! ---------------
+INTEGER :: IK,JM,J,IL, IMIN,II,IJ
+INTEGER, DIMENSION(1):: IMINA
+REAL :: ZX,ZY,ZLAT,ZLON
+REAL,DIMENSION(200) :: ZTEM
+!------------------------------------------------------------------------------
+IL=LEN_TRIM(HCARIN)
+! IK= indice du 1er XSEGMx trouve puis mis a jour ensuite si plusieurs/ligne
+IK=K
+! Exploration de toute la ligne au cas ou plusieurs definitions/ligne
+ZTEM(:)=9999.
+CALL RESOLVXISOLEV(HCARIN(1:IL),IK,ZTEM)
+DO J=SIZE(ZTEM,1),1,-1
+ IF(ZTEM(J) /= 9999.)THEN
+ JM=J
+ EXIT
+ ENDIF
+ENDDO
+!
+IMIN=1
+DO
+ ! NSEGMS=0 ou 1, ici on cherche deux 0 consecutifs
+ IMINA(1:1)=MINLOC(NSEGMS(IMIN:))
+ IMIN=IMINA(1)+(IMIN-1)+1
+ IF (NSEGMS(IMIN)==0 .OR. IMIN==SIZE(NSEGMS,1)) EXIT
+ENDDO
+XSEGMS(IMIN:IMIN-1+JM/2,1)=ZTEM(1:JM-1:2)
+XSEGMS(IMIN:IMIN-1+JM/2,2)=ZTEM(2:JM:2)
+DO J=IMIN,IMIN-1+JM/2
+ if(nverbia >0)then
+ print *,' J XSEGMS(J,:) ','J= ',J,' ',XSEGMS(J,:)
+ endif
+ ZLAT=XSEGMS(J,1)
+ ZLON=XSEGMS(J,2)
+ IF(ZLAT /= 0. .OR. ZLON /= 0.)THEN
+ IF(HCARIN(K:K)=='X') THEN ! XSEGMS
+ NSEGMS(J)=1
+ ENDIF
+ IF(HCARIN(K:K)=='I') THEN ! ISEGMS
+ NSEGMS(J)=-1
+ ENDIF
+ ENDIF
+! Conversion en coordonnees conformes
+!maintenant dans oper_process et closf (juste avant le trace)
+! IF(HCARIN(K:K)=='X') THEN ! XSEGMS
+! CALL SM_XYHAT_S(XLATOR,XLONOR,ZLAT,ZLON,ZX,ZY)
+! XCONFSEGMS(J,1)=ZX
+! XCONFSEGMS(J,2)=ZY
+! ENDIF
+! IF(HCARIN(K:K)=='I') THEN ! ISEGMS
+! II=MAX(MIN(INT(ZLAT),NIMAX+2*JPHEXT-1),1)
+! IJ=MAX(MIN(INT(ZLON),NJMAX+2*JPHEXT-1),1)
+! ZX=XXX(II,NGRIDIA(1)) + &
+! (ZLAT-FLOAT(II))*(XXX(II+1,NGRIDIA(1)) - XXX(II,NGRIDIA(1)) )
+! ZY=XXY(IJ,NGRIDIA(1)) + &
+! (ZLON-FLOAT(IJ))*(XXY(IJ+1,NGRIDIA(1)) - XXY(IJ,NGRIDIA(1)) )
+! XCONFSEGMS(J,1)=ZX
+! XCONFSEGMS(J,2)=ZY
+! ENDIF
+ENDDO
+do j=1,size(xsegms,1)
+if(nverbia >0)then
+print *,' J XSEGM ', J ,XSEGMS(J,:)
+endif
+enddo
+RETURN
+END SUBROUTINE LOAD_SEGMENTS
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/load_tit.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/load_tit.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1f375128d9d0a49672741c5ca157d040551af652
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/load_tit.f90
@@ -0,0 +1,255 @@
+! ######spl
+ MODULE MODI_LOAD_TIT
+! ####################
+!
+INTERFACE
+!
+SUBROUTINE LOAD_TIT(HCARIN,KIND)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND
+END SUBROUTINE LOAD_TIT
+!
+END INTERFACE
+END MODULE MODI_LOAD_TIT
+! ######spl
+ SUBROUTINE LOAD_TIT(HCARIN,KIND)
+! ################################
+!
+!!**** *LOAD_TIT* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_TIT
+USE MODI_RESOLV_TIT
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: INDGUIL1, INDGUIL2 ,INDM
+INTEGER :: ILEN
+INTEGER :: J,JM
+CHARACTER(LEN=8) :: YTEM
+
+!
+!------------------------------------------------------------------------------
+INDM=KIND
+IF(HCARIN(KIND:KIND+6) == 'LTITDEF')THEN
+ DO J=KIND+8,LEN(HCARIN)
+ IF(HCARIN(J:J) /= '=' .AND. HCARIN(J:J) /= '.' &
+ .AND. HCARIN(J:J) /= ' ')THEN
+ JM=J
+ EXIT
+ ENDIF
+ ENDDO
+ IF(HCARIN(JM:JM) == 'T')THEN
+ LTITDEF=.TRUE.
+ CALL RESOLV_TIT('CTITALL',YTEM)
+ ENDIF
+ IF(HCARIN(JM:JM) == 'F')LTITDEF=.FALSE.
+ RETURN
+ENDIF
+INDGUIL1=INDEX(HCARIN,'"')
+IF(INDGUIL1 == 0)THEN
+ INDGUIL1=INDEX(HCARIN,"'")
+ENDIF
+ILEN=LEN_TRIM(HCARIN)
+INDGUIL2=INDEX(HCARIN(INDGUIL1+1:ILEN),'"')
+IF(INDGUIL2 == 0)THEN
+ INDGUIL2=INDEX(HCARIN(INDGUIL1+1:ILEN),"'")
+ENDIF
+INDGUIL2=INDGUIL1+INDGUIL2
+!print *,' **load_tit INDGUIL1,INDGUIL2 ',INDGUIL1,INDGUIL2
+
+SELECT CASE(HCARIN(INDM:INDM+5))
+ CASE('CTITT1')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITT1=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITT2')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITT2=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITT3')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+! print *,' **load_tit HCARIN et LEN CTITT3 ',HCARIN,LEN(HCARIN),&
+! LEN(CTITT3),CTITT3
+ CTITT3=HCARIN(INDGUIL1+1:INDGUIL2-1)
+! print *,' **load_tit HCARIN et LEN CTITT3 ',HCARIN,LEN(HCARIN),&
+! LEN(CTITT3),CTITT3
+ CASE('CTITB1')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITB1=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITB2')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITB2=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITB3')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITB3=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITYT')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITYT=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITYM')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITYM=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITYB')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITYB=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITXL')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITXL=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITXM')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITXM=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITXR')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITXR=HCARIN(INDGUIL1+1:INDGUIL2-1)
+END SELECT
+SELECT CASE(HCARIN(INDM:INDM+7))
+ CASE('CTITVAR1')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITVAR1=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITVAR2')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITVAR2=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITVAR3')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITVAR3=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITVAR4')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITVAR4=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITVAR5')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITVAR5=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITVAR6')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITVAR6=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITVAR7')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITVAR7=HCARIN(INDGUIL1+1:INDGUIL2-1)
+ CASE('CTITVAR8')
+ KIND=999
+ IF(INDGUIL1 == 0 .OR. INDGUIL2 == 0)THEN
+ print *,' Le TITRE doit etre entre guillemets ou quotes. Corrigez le et '
+ print *,' Rentrez le a nouveau '
+ ENDIF
+ CTITVAR8=HCARIN(INDGUIL1+1:INDGUIL2-1)
+END SELECT
+RETURN
+END SUBROUTINE LOAD_TIT
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/load_xprdat.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/load_xprdat.f90
new file mode 100644
index 0000000000000000000000000000000000000000..330fc5b270e29e64dcb81eee6bb7352894e2de5d
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/load_xprdat.f90
@@ -0,0 +1,65 @@
+! ######spl
+ SUBROUTINE LOAD_XPRDAT(KIND,KLOOPT)
+! ################################
+!
+!!**** *LOAD_FMTAXES* -
+!!
+!! PURPOSE
+!! -------
+! Charger dans XPRDAT les dates modele, exp., segment et courante
+! pour ecriture dans le fichier FICVAL (G.Jaubert JUIN 2001)
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 20/06/01
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+
+INTEGER :: KIND,KLOOPT
+!
+!------------------------------------------------------------------------------
+IF(.NOT.ALLOCATED(XPRDAT))THEN
+ RETURN
+ENDIF
+! Chargement des dates courante , modele, experience et segment
+XPRDAT(1:4,KIND)=XDATIME(13:16,KLOOPT)
+XPRDAT(5:8,KIND)=XDATIME(9:12,KLOOPT)
+XPRDAT(9:12,KIND)=XDATIME(1:4,KLOOPT)
+XPRDAT(13:16,KIND)=XDATIME(5:8,KLOOPT)
+RETURN
+END SUBROUTINE LOAD_XPRDAT
+
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/loadmnmx_ft_pvkt.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/loadmnmx_ft_pvkt.f90
new file mode 100644
index 0000000000000000000000000000000000000000..85d328833af8b5649f6f4750010b38d38482be92
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/loadmnmx_ft_pvkt.f90
@@ -0,0 +1,188 @@
+! ######spl
+ MODULE MODI_LOADMNMX_FT_PVKT
+! ############################
+!
+INTERFACE
+!
+SUBROUTINE LOADMNMX_FT_PVKT(HCARIN,KIND,PMNMX,K)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND,K
+REAL :: PMNMX
+END SUBROUTINE LOADMNMX_FT_PVKT
+!
+END INTERFACE
+END MODULE MODI_LOADMNMX_FT_PVKT
+! ######spl
+ SUBROUTINE LOADMNMX_FT_PVKT(HCARIN,KIND,PMNMX,K)
+! ################################################
+!
+!!**** *LOADMNMX_FT_PVKT* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 2/09/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND, K
+REAL :: PMNMX
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: ILEN
+INTEGER :: J,JM
+INTEGER,DIMENSION(:),ALLOCATABLE :: ICOLI
+REAL,DIMENSION(:),ALLOCATABLE :: ZFTMN, ZFTMX
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE :: YFTMN, YFTMX, YCOLI
+
+!
+!------------------------------------------------------------------------------
+!print *,' loadmnmx... HCARIN ',HCARIN
+IF(K == 1 .OR. K == 2)THEN
+ ILEN=6
+ELSE IF(K == 3 .OR. K == 4)THEN
+ ILEN=8
+ELSE IF(K == 5 .OR. K == 6)THEN
+ ILEN=7
+ELSE IF(K == 7)THEN
+ ILEN=8
+ELSE IF(K == 8)THEN
+ ILEN=6
+ELSE IF(K == 9)THEN
+ ILEN=7
+ENDIF
+IF(HCARIN(KIND+ILEN:KIND+ILEN) /= '_')THEN
+ RETURN
+ELSE
+ DO J=ILEN+1,ILEN+100
+ IF(HCARIN(KIND+J:KIND+J) == ' ' .OR. &
+ HCARIN(KIND+J:KIND+J) == '=')THEN
+ JM=J-1
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(K == 1 .OR. K == 3 .OR. K == 5)THEN
+ IF(NBFTMN == 0)THEN
+ NBFTMN=NBFTMN+1
+ ALLOCATE(XFTMN(NBFTMN),CFTMN(NBFTMN))
+ XFTMN(NBFTMN)=PMNMX
+ CFTMN(NBFTMN)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CFTMN(NBFTMN)=ADJUSTL(CFTMN(NBFTMN))
+ ELSE
+ DO J=1,NBFTMN
+ IF(HCARIN(KIND+ILEN+1:KIND+JM) == CFTMN(J))THEN
+ XFTMN(J)=PMNMX
+ RETURN
+ ENDIF
+ ENDDO
+ ALLOCATE(ZFTMN(NBFTMN),YFTMN(NBFTMN))
+ ZFTMN(:)=XFTMN(:)
+ YFTMN(:)=CFTMN(:)
+ DEALLOCATE(XFTMN,CFTMN)
+ NBFTMN=NBFTMN+1
+ ALLOCATE(XFTMN(NBFTMN),CFTMN(NBFTMN))
+ XFTMN(1:NBFTMN-1)=ZFTMN(:)
+ CFTMN(1:NBFTMN-1)=YFTMN(:)
+ XFTMN(NBFTMN)=PMNMX
+ CFTMN(NBFTMN)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CFTMN(NBFTMN)=ADJUSTL(CFTMN(NBFTMN))
+ DEALLOCATE(ZFTMN,YFTMN)
+ ENDIF
+ELSE IF(K == 2 .OR. K == 4 .OR. K == 6)THEN
+ IF(NBFTMX == 0)THEN
+ NBFTMX=NBFTMX+1
+ ALLOCATE(XFTMX(NBFTMX),CFTMX(NBFTMX))
+ XFTMX(NBFTMX)=PMNMX
+ CFTMX(NBFTMX)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CFTMX(NBFTMX)=ADJUSTL(CFTMX(NBFTMX))
+ ELSE
+ DO J=1,NBFTMX
+ IF(HCARIN(KIND+ILEN+1:KIND+JM) == CFTMX(J))THEN
+ XFTMX(J)=PMNMX
+ RETURN
+ ENDIF
+ ENDDO
+ ALLOCATE(ZFTMX(NBFTMX),YFTMX(NBFTMX))
+ ZFTMX(:)=XFTMX(:)
+ YFTMX(:)=CFTMX(:)
+ DEALLOCATE(XFTMX,CFTMX)
+ NBFTMX=NBFTMX+1
+ ALLOCATE(XFTMX(NBFTMX),CFTMX(NBFTMX))
+ XFTMX(1:NBFTMX-1)=ZFTMX(:)
+ CFTMX(1:NBFTMX-1)=YFTMX(:)
+ XFTMX(NBFTMX)=PMNMX
+ CFTMX(NBFTMX)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CFTMX(NBFTMX)=ADJUSTL(CFTMX(NBFTMX))
+ DEALLOCATE(ZFTMX,YFTMX)
+ ENDIF
+ELSE IF(K == 7 .OR. K == 8 .OR. K == 9)THEN
+ IF(NBCOLI == 0)THEN
+ NBCOLI=NBCOLI+1
+ ALLOCATE(NCOLI(NBCOLI),CCOLI(NBCOLI))
+ NCOLI(NBCOLI)=NINT(PMNMX)
+ CCOLI(NBCOLI)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CCOLI(NBCOLI)=ADJUSTL(CCOLI(NBCOLI))
+ ELSE
+ DO J=1,NBCOLI
+ IF(HCARIN(KIND+ILEN+1:KIND+JM) == CCOLI(J))THEN
+ NCOLI(J)=NINT(PMNMX)
+ RETURN
+ ENDIF
+ ENDDO
+ ALLOCATE(ICOLI(NBCOLI),YCOLI(NBCOLI))
+ ICOLI(:)=NCOLI(:)
+ YCOLI(:)=CCOLI(:)
+ DEALLOCATE(NCOLI,CCOLI)
+ NBCOLI=NBCOLI+1
+ ALLOCATE(NCOLI(NBCOLI),CCOLI(NBCOLI))
+ NCOLI(1:NBCOLI-1)=ICOLI(:)
+ CCOLI(1:NBCOLI-1)=YCOLI(:)
+ NCOLI(NBCOLI)=NINT(PMNMX)
+ CCOLI(NBCOLI)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CCOLI(NBCOLI)=ADJUSTL(CCOLI(NBCOLI))
+ DEALLOCATE(ICOLI,YCOLI)
+ ENDIF
+ENDIF
+RETURN
+END SUBROUTINE LOADMNMX_FT_PVKT
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/loadmnmxint_iso.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/loadmnmxint_iso.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a535a3a8d35836cc7334a8c374d3155bd36dbec8
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/loadmnmxint_iso.f90
@@ -0,0 +1,205 @@
+! ######spl
+ MODULE MODI_LOADMNMXINT_ISO
+! ############################
+!
+INTERFACE
+!
+SUBROUTINE LOADMNMXINT_ISO(HCARIN,KIND,PMNMXINT,K)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND,K
+REAL :: PMNMXINT
+END SUBROUTINE LOADMNMXINT_ISO
+!
+END INTERFACE
+END MODULE MODI_LOADMNMXINT_ISO
+! ######spl
+ SUBROUTINE LOADMNMXINT_ISO(HCARIN,KIND,PMNMXINT,K)
+! ##################################################
+!
+!!**** *LOADMNMXINT_ISO* -
+!!
+!! PURPOSE
+!! -------
+! Memorise pour un processus donne les limites et l'intervalle
+! d'isocontours (utilises quand NIMNMX=1)
+!
+!!** METHOD
+!! ------
+!! K = 1 --> memorisation MIN
+!! K = 2 --> memorisation MAX
+!! K = 3 --> memorisation Intervalle
+!! K = 4 --> memorisation ISOREF (NIMNMX=3)
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 2/09/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND, K
+REAL :: PMNMXINT
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: ILEN
+INTEGER :: J,JM
+REAL,DIMENSION(:),ALLOCATABLE :: ZISOSAVE
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE :: YISOSAVE
+
+!
+!------------------------------------------------------------------------------
+ILEN=7
+IF(HCARIN(KIND+ILEN:KIND+ILEN) /= '_')THEN
+ RETURN
+ELSE
+ DO J=ILEN+1,ILEN+100
+ IF(HCARIN(KIND+J:KIND+J) == ' ' .OR. &
+ HCARIN(KIND+J:KIND+J) == '=')THEN
+ JM=J-1
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(K == 1)THEN ! memorisation MIN
+ IF(NBISOMN == 0)THEN
+ NBISOMN=NBISOMN+1
+ ALLOCATE(XISOMN(NBISOMN),CISOMN(NBISOMN))
+ XISOMN(NBISOMN)=PMNMXINT
+ CISOMN(NBISOMN)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CISOMN(NBISOMN)=ADJUSTL(CISOMN(NBISOMN))
+ ELSE
+ DO J=1,NBISOMN
+ IF(HCARIN(KIND+ILEN+1:KIND+JM) == CISOMN(J))THEN
+ XISOMN(J)=PMNMXINT
+ RETURN
+ ENDIF
+ ENDDO
+ ALLOCATE(ZISOSAVE(NBISOMN),YISOSAVE(NBISOMN))
+ ZISOSAVE(:)=XISOMN(:)
+ YISOSAVE(:)=CISOMN(:)
+ DEALLOCATE(XISOMN,CISOMN)
+ NBISOMN=NBISOMN+1
+ ALLOCATE(XISOMN(NBISOMN),CISOMN(NBISOMN))
+ XISOMN(1:NBISOMN-1)=ZISOSAVE(:)
+ CISOMN(1:NBISOMN-1)=YISOSAVE(:)
+ XISOMN(NBISOMN)=PMNMXINT
+ CISOMN(NBISOMN)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CISOMN(NBISOMN)=ADJUSTL(CISOMN(NBISOMN))
+ DEALLOCATE(ZISOSAVE,YISOSAVE)
+ ENDIF
+ELSE IF(K == 2)THEN ! memorisation MAX
+ IF(NBISOMX == 0)THEN
+ NBISOMX=NBISOMX+1
+ ALLOCATE(XISOMX(NBISOMX),CISOMX(NBISOMX))
+ XISOMX(NBISOMX)=PMNMXINT
+ CISOMX(NBISOMX)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CISOMX(NBISOMX)=ADJUSTL(CISOMX(NBISOMX))
+ ELSE
+ DO J=1,NBISOMX
+ IF(HCARIN(KIND+ILEN+1:KIND+JM) == CISOMX(J))THEN
+ XISOMX(J)=PMNMXINT
+ RETURN
+ ENDIF
+ ENDDO
+ ALLOCATE(ZISOSAVE(NBISOMX),YISOSAVE(NBISOMX))
+ ZISOSAVE(:)=XISOMX(:)
+ YISOSAVE(:)=CISOMX(:)
+ DEALLOCATE(XISOMX,CISOMX)
+ NBISOMX=NBISOMX+1
+ ALLOCATE(XISOMX(NBISOMX),CISOMX(NBISOMX))
+ XISOMX(1:NBISOMX-1)=ZISOSAVE(:)
+ CISOMX(1:NBISOMX-1)=YISOSAVE(:)
+ XISOMX(NBISOMX)=PMNMXINT
+ CISOMX(NBISOMX)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CISOMX(NBISOMX)=ADJUSTL(CISOMX(NBISOMX))
+ DEALLOCATE(ZISOSAVE,YISOSAVE)
+ ENDIF
+ELSE IF(K == 3)THEN ! memorisation INTervalle
+ IF(NBISOINT == 0)THEN
+ NBISOINT=NBISOINT+1
+ ALLOCATE(XISOINT(NBISOINT),CISOINT(NBISOINT))
+ XISOINT(NBISOINT)=PMNMXINT
+ CISOINT(NBISOINT)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CISOINT(NBISOINT)=ADJUSTL(CISOINT(NBISOINT))
+ ELSE
+ DO J=1,NBISOINT
+ IF(HCARIN(KIND+ILEN+1:KIND+JM) == CISOINT(J))THEN
+ XISOINT(J)=PMNMXINT
+ RETURN
+ ENDIF
+ ENDDO
+ ALLOCATE(ZISOSAVE(NBISOINT),YISOSAVE(NBISOINT))
+ ZISOSAVE(:)=XISOINT(:)
+ YISOSAVE(:)=CISOINT(:)
+ DEALLOCATE(XISOINT,CISOINT)
+ NBISOINT=NBISOINT+1
+ ALLOCATE(XISOINT(NBISOINT),CISOINT(NBISOINT))
+ XISOINT(1:NBISOINT-1)=ZISOSAVE(:)
+ CISOINT(1:NBISOINT-1)=YISOSAVE(:)
+ XISOINT(NBISOINT)=PMNMXINT
+ CISOINT(NBISOINT)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CISOINT(NBISOINT)=ADJUSTL(CISOINT(NBISOINT))
+ DEALLOCATE(ZISOSAVE,YISOSAVE)
+ ENDIF
+ELSE IF(K == 4)THEN ! memorisation ISOligne de REF
+ IF(NBISOREF == 0)THEN
+ NBISOREF=NBISOREF+1
+ ALLOCATE(XISOREFP(NBISOREF),CISOREF(NBISOREF))
+ XISOREFP(NBISOREF)=PMNMXINT
+ CISOREF(NBISOREF)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CISOREF(NBISOREF)=ADJUSTL(CISOREF(NBISOREF))
+ ELSE
+ DO J=1,NBISOREF
+ IF(HCARIN(KIND+ILEN+1:KIND+JM) == CISOINT(J))THEN
+ XISOREFP(J)=PMNMXINT
+ RETURN
+ ENDIF
+ ENDDO
+ ALLOCATE(ZISOSAVE(NBISOREF),YISOSAVE(NBISOREF))
+ ZISOSAVE(:)=XISOREFP(:)
+ YISOSAVE(:)=CISOREF(:)
+ DEALLOCATE(XISOREFP,CISOREF)
+ NBISOREF=NBISOREF+1
+ ALLOCATE(XISOREFP(NBISOREF),CISOREF(NBISOREF))
+ XISOREFP(1:NBISOREF-1)=ZISOSAVE(:)
+ CISOREF(1:NBISOREF-1)=YISOSAVE(:)
+ XISOREFP(NBISOREF)=PMNMXINT
+ CISOREF(NBISOREF)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CISOREF(NBISOREF)=ADJUSTL(CISOREF(NBISOREF))
+ DEALLOCATE(ZISOSAVE,YISOSAVE)
+ ENDIF
+ENDIF
+
+RETURN
+END SUBROUTINE LOADMNMXINT_ISO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/loadunitit.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/loadunitit.f90
new file mode 100644
index 0000000000000000000000000000000000000000..647478e61d271c0683b64f11f643ce72deb5a458
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/loadunitit.f90
@@ -0,0 +1,106 @@
+! ######spl
+ MODULE MODI_LOADUNITIT
+! ##############################
+!
+INTERFACE
+!
+SUBROUTINE LOADUNITIT(KJ,K)
+INTEGER :: KJ,K
+END SUBROUTINE LOADUNITIT
+!
+END INTERFACE
+!
+END MODULE MODI_LOADUNITIT
+! ######spl
+ SUBROUTINE LOADUNITIT(KJ,K)
+! ################################
+!
+!!**** *LOADUNITIT* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_NMGRID
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+INTEGER :: KJ,K
+!
+!* 0.1 Local variables
+! ---------------
+! !------------------------------------------------------------------------------
+IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. &
+ LSUMVM .OR. LSUTVT .OR. &
+ LDIRWM .OR. LDIRWT .OR. &
+ LMLSUMVM .OR. LMLSUTVT .OR. LVTM .OR. LVTT .OR. &
+ LULM .OR. LULT)THEN
+ CTITGAL=ADJUSTL(CGROUP)
+ CTITGAL=ADJUSTL(CTITGAL)
+ CUNITGAL(1:LEN(CUNITGAL))=' '
+ NMGRID=1
+ELSE
+
+ CTITGAL=ADJUSTL(CTITRE(NPROCDIA(KJ,K)))
+ CUNITGAL=ADJUSTL(CUNITE(NPROCDIA(KJ,K)))
+ CTITGAL=ADJUSTL(CTITGAL)
+ IF(CTITGAL(1:LEN_TRIM(CTITGAL)) == 'ZSBIS')THEN
+ CTITGAL(1:LEN_TRIM(CTITGAL))=' '
+ CTITGAL='ZS'
+ ENDIF
+ IF(CTITGAL(1:LEN_TRIM(CTITGAL)) == 'ZSMTBIS')THEN
+ CTITGAL(1:LEN_TRIM(CTITGAL))=' '
+ CTITGAL='ZSMT'
+ ENDIF
+ CTITGAL=ADJUSTL(CTITGAL)
+ CUNITGAL=ADJUSTL(CUNITGAL)
+ CUNITGAL(INDEX(CUNITGAL,' '):LEN(CUNITGAL))=' '
+ NMGRID=NGRIDIA(NPROCDIA(KJ,K))
+
+ENDIF
+
+IF(NMGRID <1 .OR. NMGRID >7)THEN
+ PRINT *,' VALEUR NMGRID ABERRANTE: ',NMGRID, &
+ ' FORCEE A : 1'
+ NMGRID=1
+ENDIF
+RETURN
+END SUBROUTINE LOADUNITIT
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/loadxisolevp.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/loadxisolevp.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d74c66aea036ed668596b790b962c6a608e9fbab
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/loadxisolevp.f90
@@ -0,0 +1,177 @@
+! ######spl
+ MODULE MODI_LOADXISOLEVP
+! ##############################
+!
+INTERFACE
+!
+SUBROUTINE LOADXISOLEVP(HCARIN,KIND,PISOLEVP)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND
+REAL,DIMENSION(:):: PISOLEVP
+END SUBROUTINE LOADXISOLEVP
+!
+END INTERFACE
+!
+END MODULE MODI_LOADXISOLEVP
+! ######spl
+ SUBROUTINE LOADXISOLEVP(HCARIN,KIND,PISOLEVP)
+! #############################################
+!
+!!**** *LOADXISOLEVP* -
+!!
+!! PURPOSE
+!! -------
+! Memorise pour un processus donne les valeurs
+! d'isocontours (utilises avec NIMNMX=2)
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 2/09/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND
+REAL,DIMENSION(:):: PISOLEVP
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: ILEN, IMA
+INTEGER :: J,JM, JA
+REAL,DIMENSION(:,:),ALLOCATABLE :: ZISOLEVP
+INTEGER,DIMENSION(:),ALLOCATABLE :: ILENP
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE :: YISOLEVP
+
+!
+!------------------------------------------------------------------------------
+ILEN=7
+IF(HCARIN(KIND+ILEN:KIND+ILEN) /= '_')THEN
+ RETURN
+ELSE
+ DO J=ILEN+1,ILEN+100
+ IF(HCARIN(KIND+J:KIND+J) == ' ' .OR. &
+ HCARIN(KIND+J:KIND+J) == '=')THEN
+ JM=J-1
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+IF(NVERBIA > 0)THEN
+ print *,' LOADXISOLEVP ',SIZE(PISOLEVP),' SIZE(PISOLEVP,1) ',SIZE(PISOLEVP,1)
+ENDIF
+
+IF(NBISOLEVP == 0)THEN
+! 1er passage
+ NBISOLEVP=NBISOLEVP+1
+ ALLOCATE(XISOLEVP(SIZE(PISOLEVP),NBISOLEVP),CISOLEVP(NBISOLEVP))
+ ALLOCATE(NLENP(NBISOLEVP))
+ XISOLEVP(:,NBISOLEVP)=9999.
+ XISOLEVP(:,NBISOLEVP)=PISOLEVP(:)
+ NLENP(NBISOLEVP)=SIZE(PISOLEVP)
+ CISOLEVP(NBISOLEVP)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CISOLEVP(NBISOLEVP)=ADJUSTL(CISOLEVP(NBISOLEVP))
+ IF(NVERBIA >= 5)THEN
+ DO JA=1,NBISOLEVP
+ print *,' NBISOLEVP ',NBISOLEVP
+ print *,NLENP(JA),CISOLEVP(JA)
+ print *,XISOLEVP(1:NLENP(JA),JA)
+ ENDDO
+ ENDIF
+ RETURN
+ELSE
+ DO J=1,NBISOLEVP
+ IF(HCARIN(KIND+ILEN+1:KIND+JM) == CISOLEVP(J))THEN
+! Cas ou la variable existe deja
+ if(nverbia > 0)then
+ print *,' loadxisolev ap deja.. HCARIN(KIND+ILEN+1:KIND+JM) ', &
+ HCARIN(KIND+ILEN+1:KIND+JM)
+ print *,' loadxisolev CISOLEVP(J) ',CISOLEVP(J)
+ endif
+ IF(SIZE(PISOLEVP) <= SIZE(XISOLEVP,1))THEN
+ XISOLEVP(1:SIZE(XISOLEVP,1),J)=9999.
+ XISOLEVP(1:SIZE(PISOLEVP),J)=PISOLEVP(:)
+ NLENP(J)=SIZE(PISOLEVP)
+ EXIT
+ ELSE
+! AFAIRE A FAIRE
+ ALLOCATE(ZISOLEVP(SIZE(XISOLEVP,1),NBISOLEVP))
+ ZISOLEVP(:,:)=XISOLEVP(:,:)
+ IMA=MAX(SIZE(XISOLEVP,1),SIZE(PISOLEVP,1))
+ DEALLOCATE(XISOLEVP)
+ ALLOCATE(XISOLEVP(IMA,NBISOLEVP))
+ XISOLEVP(1:SIZE(ZISOLEVP,1),:)=ZISOLEVP(:,:)
+ XISOLEVP(1:SIZE(PISOLEVP),J)=PISOLEVP(:)
+ NLENP(J)=SIZE(PISOLEVP)
+ ENDIF
+ IF(NVERBIA >= 5)THEN
+ DO JA=1,NBISOLEVP
+ print *,' NBISOLEVP ',NBISOLEVP
+ print *,NLENP(JA),CISOLEVP(JA)
+ print *,XISOLEVP(1:NLENP(JA),JA)
+ ENDDO
+ ENDIF
+ RETURN
+ ENDIF
+ ENDDO
+! Cas ou la variable n'existe pas
+ ALLOCATE(ZISOLEVP(SIZE(XISOLEVP,1),NBISOLEVP),YISOLEVP(NBISOLEVP))
+ ALLOCATE(ILENP(NBISOLEVP))
+ ZISOLEVP(:,:)=XISOLEVP(:,:)
+ YISOLEVP(:)=CISOLEVP(:)
+ ILENP(:)=NLENP(:)
+ IMA=MAX(SIZE(XISOLEVP,1),SIZE(PISOLEVP,1))
+ DEALLOCATE(XISOLEVP,CISOLEVP,NLENP)
+ NBISOLEVP=NBISOLEVP+1
+ ALLOCATE(XISOLEVP(IMA,NBISOLEVP),CISOLEVP(NBISOLEVP))
+ ALLOCATE(NLENP(NBISOLEVP))
+ XISOLEVP(1:SIZE(ZISOLEVP,1),1:NBISOLEVP-1)=ZISOLEVP(:,:)
+ CISOLEVP(1:NBISOLEVP-1)=YISOLEVP(:)
+ XISOLEVP(1:SIZE(PISOLEVP),NBISOLEVP)=PISOLEVP(:)
+ NLENP(1:NBISOLEVP-1)=ILENP(:)
+ NLENP(NBISOLEVP)=SIZE(PISOLEVP)
+ CISOLEVP(NBISOLEVP)=HCARIN(KIND+ILEN+1:KIND+JM)
+ CISOLEVP(NBISOLEVP)=ADJUSTL(CISOLEVP(NBISOLEVP))
+ DEALLOCATE(ZISOLEVP,YISOLEVP,ILENP)
+ IF(NVERBIA >= 5)THEN
+ DO JA=1,NBISOLEVP
+ print *,' NBISOLEVP ',NBISOLEVP
+ print *,NLENP(JA),CISOLEVP(JA)
+ print *,XISOLEVP(1:NLENP(JA),JA)
+ ENDDO
+ ENDIF
+ENDIF
+RETURN
+END SUBROUTINE LOADXISOLEVP
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/memcv.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/memcv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1674323e0a081a4c83143dfdc7b6af8e2e3cf4bc
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/memcv.f90
@@ -0,0 +1,120 @@
+! #################
+ SUBROUTINE MEMCV
+! #################
+!
+!!**** *MEMCV* -
+!!
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 15/03/99
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_NMGRID
+USE MODD_COORD
+USE MODD_MEMCV
+USE MODN_PARA
+USE MODD_RESOLVCAR, ONLY : XCONFSEGMS,NSEGMS,NVERBIA
+!
+IMPLICIT NONE
+!
+!* 0.1 Local variables
+!
+INTEGER :: JILOOP,IMIN
+INTEGER,DIMENSION(1):: IMINA
+!
+REAL,DIMENSION(:,:),ALLOCATABLE :: ZX, ZY
+!
+!-------------------------------------------------------------------------------
+!
+!* 1.
+! ----------------------------
+!
+!
+IF(NTRACECV > 0)THEN
+ DO JILOOP=1,NTRACECV
+ IF(XTRACECV(1,JILOOP)==XDSX(1,NMGRID) .AND. XTRACECV(2,JILOOP)==XDSX(NLMAX,NMGRID) .AND.&
+ XYTRACECV(1,JILOOP)==XDSY(1,NMGRID) .AND. XYTRACECV(2,JILOOP)==XDSY(NLMAX,NMGRID))THEN
+ RETURN
+ ENDIF
+ ENDDO
+ ALLOCATE(ZX(2,SIZE(XTRACECV,2)))
+ ALLOCATE(ZY(2,SIZE(XYTRACECV,2)))
+ ZX=XTRACECV
+ ZY=XYTRACECV
+ NTRACECV=NTRACECV+1
+ DEALLOCATE(XTRACECV)
+ DEALLOCATE(XYTRACECV)
+ ALLOCATE(XTRACECV(2,NTRACECV))
+ ALLOCATE(XYTRACECV(2,NTRACECV))
+ XTRACECV(:,1:NTRACECV-1)=ZX
+ XYTRACECV(:,1:NTRACECV-1)=ZY
+ XTRACECV(1,NTRACECV)=XDSX(1,NMGRID)
+ XTRACECV(2,NTRACECV)=XDSX(NLMAX,NMGRID)
+ XYTRACECV(1,NTRACECV)=XDSY(1,NMGRID)
+ XYTRACECV(2,NTRACECV)=XDSY(NLMAX,NMGRID)
+ DEALLOCATE(ZX)
+ DEALLOCATE(ZY)
+ELSE
+ NTRACECV=NTRACECV+1
+ IF(ALLOCATED(XTRACECV))THEN
+ DEALLOCATE(XTRACECV)
+ ENDIF
+ IF(ALLOCATED(XYTRACECV))THEN
+ DEALLOCATE(XYTRACECV)
+ ENDIF
+ ALLOCATE(XTRACECV(2,NTRACECV))
+ ALLOCATE(XYTRACECV(2,NTRACECV))
+ XTRACECV(1,NTRACECV)=XDSX(1,NMGRID)
+ XTRACECV(2,NTRACECV)=XDSX(NLMAX,NMGRID)
+ XYTRACECV(1,NTRACECV)=XDSY(1,NMGRID)
+ XYTRACECV(2,NTRACECV)=XDSY(NLMAX,NMGRID)
+ENDIF
+! stockage dans segments pour trace de la CV dans CH suivante(s)
+IF(LTRACECV) THEN
+ IMIN=1
+ DO
+ ! NSEGMS=0 ou 1, ici on cherche deux 0 consecutifs
+ IMINA(1:1)=MINLOC(NSEGMS(IMIN:))
+ IMIN=IMINA(1)+(IMIN-1)+1
+ IF (NSEGMS(IMIN)==0 .OR. IMIN==SIZE(NSEGMS,1)) EXIT
+ ENDDO
+ NSEGMS(IMIN)=2
+ XCONFSEGMS(IMIN,1)=XDSX(1,NMGRID)
+ XCONFSEGMS(IMIN,2)=XDSY(1,NMGRID)
+ NSEGMS(IMIN+1)=2
+ XCONFSEGMS(IMIN+1,1)=XDSX(NLMAX,NMGRID)
+ XCONFSEGMS(IMIN+1,2)=XDSY(NLMAX,NMGRID)
+END IF
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE MEMCV
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/myheurx.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/myheurx.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b36cbe5038a60307f092e9f98d7430364b784411
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/myheurx.f90
@@ -0,0 +1,260 @@
+! ######spl
+ SUBROUTINE MYHEURX(KITVXJ,KITVXN,KITVYJ,KITVYN,I1,I2,I3,Z1,Z2)
+! ####################
+!
+!!**** *MYHEURX* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!
+!!** METHOD
+!! ------
+!! NCAR routines are called to select a display window
+!! corresponding to the post-processed section of the model
+!! arrays (NIINFxNISUP).(NJINFxNJSUP)
+!!
+!!
+!! EXTERNAL
+!! --------
+!! SET : defines NCAR window and viewport in normalized and user
+!! coordinates
+!! LABMOD : defines axis label format
+!! GRIDAL : draws axis divisions and ticks
+!! PERIM : draws a perimeter box for the current plot
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX,XXY : coordinate values for all the MESO-NH grids
+!!
+!! Module MODD_NMGRID : declares global variable NMGRID
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NIINF, NISUP : lower and upper bounds of arrays
+!! to be plotted in x direction
+!! NJINF, NJSUP : lower and upper bounds of arrays
+!! to be plotted in y direction
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 25/04/02
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODD_CTL_AXES_AND_STYL
+USE MODD_DIM1
+USE MODN_NCAR
+!
+IMPLICIT NONE
+!
+INTEGER :: KITVXJ,KITVXN,KITVYJ,KITVYN,I1,I2,I3
+REAL :: Z1,Z2
+!
+
+REAL :: ZWL, ZWR, ZWB, ZWT
+REAL :: ZWLL, ZWRR, ZWBB, ZWTT
+REAL :: ZVL, ZVR, ZVB, ZVT
+REAL :: ZH, ZJ, ZJJ,ZINT, ZINTT, ZWBBB
+INTEGER :: ID, IDD ,J
+CHARACTER(LEN=2) :: YC2
+CHARACTER(LEN=3) :: YC3
+CHARACTER(LEN=4) :: YC4
+CHARACTER(LEN=10) :: FORMAX, FORMAY
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DISPLAY WINDOW SETTING AND DRAWING
+! ----------------------------------
+!
+!-----------------------------------------------------------------------------
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL/3600.,ZWR/3600.,ZWB,ZWT,ID)
+
+!!!!!!!Avril 2002
+ IF(LMYHEURX)THEN
+ ZH=NHEURXGRAD*3600.
+ ELSE
+!!!!!!!Avril 2002
+
+ IF((ZWR-ZWL)/3600. > 24.)THEN
+ ZH=10800.
+ ELSE
+ ZH=3600.
+ ENDIF
+!!!!!!!Avril 2002
+ ENDIF
+!!!!!!!Avril 2002
+
+ DO J=INT(ZWL),INT(ZWR)
+ ZJ=J
+! print *,' ZJ, ',ZJ
+ IF(MOD(ZJ,ZH) == 0.)THEN
+! print *,' ZJ,ZH,ZWB,ZWT ',ZJ,ZH,ZWB,ZWT
+ IF(I1 /= -1 .AND. I1 /= 0)THEN
+
+ CALL FRSTPT(ZJ,ZWB)
+ CALL VECTOR(ZJ,ZWB+(ZWT-ZWB)/90.)
+ CALL FRSTPT(ZJ,ZWT)
+ CALL VECTOR(ZJ,ZWT-(ZWT-ZWB)/90.)
+
+ ENDIF
+!!!!!!!Avril 2002
+ IF(LMYHEURX)THEN
+ ZJJ=ZJ/ZH*NHEURXGRAD
+ ZINTT=NHEURXLBL
+ ELSE
+!!!!!!!Avril 2002
+
+
+ IF(ZH == 10800.)THEN
+ ZJJ=ZJ/ZH*3.
+ ZINTT=6.
+ ELSE
+ ZJJ=ZJ/ZH
+ ZINTT=3.
+ ENDIF
+ !!!!!!!Avril 2002
+ ENDIF
+!!!!!!!Avril 2002
+
+ CALL GSCLIP(0)
+ ZWBBB=ZWB-((ZWT-ZWB)/40)
+! print *,' ZWB ZWT ZWBBB ',ZWB,ZWT,ZWBBB
+
+
+ IF(I1 == 1 .AND. .NOT.LNOLABELX)THEN
+ IF(MOD(ZJJ,ZINTT) == 0.)THEN
+ IF(LFACTAXEX)THEN
+ ZJJ=ZJJ*XFACTAXEX
+ ENDIF
+ IF(ZJJ < 1.)THEN
+ YC4=' '
+ WRITE(YC4,'(F4.2)')ZJJ
+ CALL PLCHHQ(ZJ,ZWBBB,YC4,.010,0.,0.)
+
+ ELSEIF(ZJJ < 10.)THEN
+ YC2=' '
+ WRITE(YC2,'(F2.0)')ZJJ
+ CALL PLCHHQ(ZJ,ZWBBB,YC2,.010,0.,0.)
+ ELSEIF(ZJJ < 100.)THEN
+ YC3=' '
+ WRITE(YC3,'(F3.0)')ZJJ
+ CALL PLCHHQ(ZJ,ZWBBB,YC3,.010,0.,0.)
+ ELSE
+ YC4=' '
+ WRITE(YC4,'(F4.0)')ZJJ
+ CALL PLCHHQ(ZJ,ZWBBB,YC4,.010,0.,0.)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ENDIF
+ENDDO
+!!! Inutile IMPLEMENTE SEULEMENT EN CV
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
+ print *,'**myheurx ZWLL,ZWRR,ZWBB,ZWTT ',ZWLL,ZWRR,ZWBB,ZWTT
+ IF(LFACTAXEX)THEN
+ IF(LFACTAXEY)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,&
+ ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
+ ELSE
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,&
+ ZWBB,ZWTT,IDD)
+ ENDIF
+ ELSEIF(LFACTAXEY)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
+ ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
+ ELSEIF(LAXEXUSER)THEN
+ IF(LAXEYUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,XAXEXUSERD,XAXEXUSERF,&
+ XAXEYUSERD,XAXEYUSERF,IDD)
+ ELSE
+ CALL SET(ZVL,ZVR,ZVB,ZVT,XAXEXUSERD,XAXEXUSERF,&
+ ZWBB,ZWTT,IDD)
+ ENDIF
+ ELSEIF(LAXEYUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
+ XAXEYUSERD,XAXEYUSERF,IDD)
+ ENDIF
+!!! Inutile IMPLEMENTE SEULEMENT EN CV
+! Mars 2001
+
+
+! Mars 2001
+ print *,'**myheurx ZWLL,ZWRR,ZWBB,ZWTT ',ZWLL,ZWRR,ZWBB,ZWTT
+!CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
+ print *,'**myheurx ZWLL,ZWRR,ZWBB,ZWTT ',ZWLL,ZWRR,ZWBB,ZWTT
+!IF(LFACTAXEX)THEN
+!CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL/3600.*XFACTAXEX,ZWRR/3600.*XFACTAXEX,ZWBB,ZWTT,IDD)
+!ELSE
+
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL/3600.,ZWRR/3600.,ZWBB,ZWTT,IDD)
+ print *,'**myheurx ZWLL/3600,ZWRR/3600,ZWBB,ZWTT ',ZWLL/3600,ZWRR/3600,ZWBB,ZWTT
+!ENDIF
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ IF(I1 /= -1)THEN
+ CALL GRIDAL(0,0,KITVYJ,KITVYN,0,0,I3,Z1,Z2)
+ ELSE
+ CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,0,I3,Z1,Z2)
+ ENDIF
+! CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,I2,I3,Z1,Z2)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ IF(I1 /= -1)THEN
+ CALL GRIDAL(0,0,KITVYJ,KITVYN,0,I2,I3,Z1,Z2)
+ ELSE
+ CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,I2,I3,Z1,Z2)
+ ENDIF
+! CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,I2,I3,Z1,Z2)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ IF(I1 /= -1)THEN
+ CALL GRIDAL(0,0,KITVYJ,KITVYN,0,0,I3,Z1,Z2)
+ ELSE
+ CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,0,I3,Z1,Z2)
+ ENDIF
+! CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,I2,I3,Z1,Z2)
+ ELSE
+ IF(I1 == 1)THEN
+ CALL GRIDAL(0,0,KITVYJ,KITVYN,0,I2,I3,Z1,Z2)
+ ELSE
+ CALL GRIDAL(0,0,KITVYJ,KITVYN,I1,I2,I3,Z1,Z2)
+ ENDIF
+ ENDIF
+!Avril 2002
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+! ENDIF
+ CALL GSCLIP(1)
+
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE MYHEURX
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/oper_process.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/oper_process.f90
new file mode 100644
index 0000000000000000000000000000000000000000..23a87849f8c6a2985c80908a6b4cd18a2e4c5c52
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/oper_process.f90
@@ -0,0 +1,6637 @@
+! ######spl
+ MODULE MODI_OPER_PROCESS
+! #########################
+!
+INTERFACE
+!
+SUBROUTINE OPER_PROCESS(KLOOP,HTYPE)
+CHARACTER(LEN=*) :: HTYPE
+INTEGER :: KLOOP
+END SUBROUTINE OPER_PROCESS
+!
+END INTERFACE
+!
+END MODULE MODI_OPER_PROCESS
+! ######spl
+ SUBROUTINE OPER_PROCESS(KLOOP,HTYPE)
+! ####################################
+!
+
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!!
+!! NIOFFD : Label normalisation (=0 none, =/=0 active)
+!! NULBLL : Nb of contours between 2 labelled contours
+!! NIOFFM : =0 --> message at picture bottom
+!! =/= 0 --> no message
+!! NIOFFP : Special point value detection
+!! (=0 none, =/=0 active)
+!! NHI : Extrema detection
+!! (=0 --> H+L, <0 nothing)
+!! NINITA : For streamlimes
+!! NINITB : Not yet implemented
+!! NIGRNC : Not yet implemented
+!! NDOT : Line style
+!! (=0|1|1023|65535 --> solid lines;
+!! <0 --> solid lines for positive values and
+!! dotted lines(ABS(NDOT))for negative values;
+!! >0 --> dotted lines(ABS(NDOT)) )
+!! NIFDC : Coastline data style (0 none, 1 NCAR, 2 IGN)
+!! NLPCAR : Number of land-mark points to be plotted
+!! NIMNMX : Contour selection option
+!! (=-1 Min, max and inc. automatically set;
+!! =0 Min, max automatically set; inc. given;
+!! >0 Min, max, inc. given by user)
+!! NISKIP : Rate for drawing velocity vectors
+!! CTYPHOR : Horizontal cross-section type
+!! (='K' --> model level section;
+!! ='Z' --> constant-altitude section;
+!! ='P' --> isobar section (planned)
+!! ='T' --> isentrope section (planned)
+!! XSPVAL : Special value
+!! XSIZEL : Label size
+!! XLATCAR, XLONCAR : Lat. and Long. of land-mark points
+!! LXY : If =.TRUE., plots a grid-mesh stencil background
+!! LXZ : If =.TRUE., plots a model-level stencil background
+!!
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist
+!! (former PARA common)
+!!
+!! XIDEBCOU, XJDEBCOU : Origin of a vertical cross-section
+!! in cartesian (or conformal) real values
+!! XHMIN : Altitude of the vert. cross-section
+!! bottom (in meters above sea-level)
+!! XHMAX : Altitude of the vert. cross-section
+!! top (in meters above sea-level)
+!!
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODD_FILES_DIACHRO
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODI_TRACEH_FORDIACHRO
+USE MODD_TYPE_AND_LH
+USE MODD_DIM1
+USE MODD_GRID1
+USE MODD_GRID, ONLY:XLONORI,XLATORI
+USE MODD_NMGRID
+USE MODD_CVERT
+USE MODD_MASK3D
+USE MODD_TITLE
+USE MODD_PARAMETERS
+USE MODD_EXPERIM
+USE MODN_NCAR
+USE MODN_PARA
+USE MODI_PRECOU_FORDIACHRO
+USE MODI_TRACEV_FORDIACHRO
+USE MODI_VARFCT
+USE MODI_PVFCT
+USE MODI_CLOSF
+USE MODI_LOADUNITIT
+USE MODI_TRAMASK
+USE MODI_CONV2XY
+USE MODI_TRAPRO_FORDIACHRO
+USE MODD_COORD
+USE MODD_CONF
+USE MODD_SUPER
+USE MODD_CST
+USE MODD_PVT
+USE MODD_DEFCV
+USE MODD_MEMCV
+USE MODE_GRIDPROJ
+
+IMPLICIT NONE
+
+INTERFACE
+ SUBROUTINE COLVECT(KKU,PTEM2D)
+ REAL, DIMENSION(:,:), INTENT(IN) :: PTEM2D
+ INTEGER :: KKU
+ END SUBROUTINE COLVECT
+END INTERFACE
+INTERFACE
+ SUBROUTINE IMCOU_FORDIACHRO(PTABV,PINT,HLEGEND,HTEXT)
+ REAL,DIMENSION(:,:) :: PTABV
+ REAL :: PINT
+ CHARACTER(LEN=*) :: HTEXT, HLEGEND
+ END SUBROUTINE IMCOU_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE INTERP_FORDIACHRO(KLREF,KD,KF,PTAB,PTABREF)
+ REAL,DIMENSION(:,:,:), INTENT(IN) :: PTAB
+ REAL,DIMENSION(SIZE(PTAB,1),SIZE(PTAB,2)) :: PTABREF
+ INTEGER :: KLREF
+ END SUBROUTINE INTERP_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE IMAGE_FORDIACHRO(PTAB,KLREF,PTABINT,KNHI,KNDOT,HTEXTE)
+ CHARACTER(LEN=*) :: HTEXTE
+ REAL :: PTABINT
+ REAL,DIMENSION(:,:) :: PTAB
+ INTEGER :: KNHI, KNDOT, KLREF
+ END SUBROUTINE IMAGE_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE TSOUND_FORDIACHRO(PPRES,PPTEMP,PPQV,PPU,PPV,KNN,HEADER,HTEXTE, &
+ OMXRAT, &
+ OMIXRAT,ODOFRAME,OSAMPLEUV)
+ REAL,DIMENSION(:) :: PPRES, PPTEMP, PPQV, PPU, PPV
+ CHARACTER(LEN=*) :: HEADER
+ CHARACTER(LEN=*) :: HTEXTE
+ LOGICAL :: OMXRAT, OMIXRAT, ODOFRAME
+ LOGICAL :: OSAMPLEUV
+ END SUBROUTINE TSOUND_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE TRAXY(PTEMX,PTEMY,KLOOP,HTITX,HTITY,PTIMED,PTIMEF)
+ INTEGER :: KLOOP
+ REAL,DIMENSION(:) :: PTEMX, PTEMY
+ REAL :: PTIMED, PTIMEF
+ CHARACTER(LEN=*) :: HTITX, HTITY
+ END SUBROUTINE TRAXY
+END INTERFACE
+INTERFACE
+ SUBROUTINE ROTA(PTEM1,PTEMV)
+ REAL, DIMENSION(:,:), INTENT(INOUT) :: PTEM1
+ REAL, DIMENSION(:,:), INTENT(INOUT) :: PTEMV
+ END SUBROUTINE ROTA
+END INTERFACE
+INTERFACE
+ SUBROUTINE CALUV_FORDIACHRO(KLOOP)
+ INTEGER :: KLOOP
+ END SUBROUTINE CALUV_FORDIACHRO
+END INTERFACE
+COMMON/TEMV/XZWORKZ,XZZDS,NINX,NINY
+COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+#include "big.h"
+REAL,DIMENSION(N2DVERTX,2500) :: XZWORKZ
+!REAL,DIMENSION(1000,400) :: XZWORKZ
+!REAL,DIMENSION(200,200) :: XZWORKZ
+REAL,DIMENSION(N2DVERTX) :: XZZDS
+!REAL,DIMENSION(1000) :: XZZDS
+!REAL,DIMENSION(200) :: XZZDS
+INTEGER :: NINX, NINY
+LOGICAL :: LVERT, LHOR, LPT, LXABS
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HTYPE
+INTEGER :: KLOOP
+
+!
+!* 0.1 Local variables
+! ---------------
+!
+INTEGER :: J, JJ
+INTEGER :: II, IJ, IK, IKU, IKB, IKE, IIU, IJU
+INTEGER :: JU, ILT
+INTEGER :: JLOOPP, JLOOPN, JLOOPT, JLOOPK, JLOOPZ, JLOOPK1, JLOOPPF
+INTEGER :: IZ, IN, ILOOPP
+INTEGER :: JKLOOP
+INTEGER :: ILENW, IJLT, ILENT, ILENU, ITIMEND
+INTEGER :: ISUP, IJSUP, IINF, IJINF
+INTEGER :: IIB, IIE, IJB, IJE
+INTEGER :: INBK, INUMK, INUMK1
+INTEGER :: INDN
+INTEGER,SAVE :: ISEGM=0, ISEGD=0, ISEGMCOL, ICOLSEGM
+INTEGER :: IJDEBCOU, IIDEBCOU
+INTEGER :: IER, INB, IWK, IX, IY, ICOLI
+INTEGER :: IDEFCV
+INTEGER :: IINFCV, IISUPCV, IJINFCV, IJSUPCV
+INTEGER,SAVE :: IIRS, IJRS
+INTEGER :: IGRID
+
+REAL :: ZLAT, ZLON
+REAL :: ZX, ZY
+REAL :: ZWL, ZWR, ZWB, ZWT
+REAL :: ZTIMED, ZTIMEF
+REAL :: ZZZXD, ZZZXF, ZZZYD, ZZZYF
+REAL :: ZLW
+
+
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: ZWORK3D, ZPROVI, ZWORK3V
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZTEMCV,ZTEM2D, ZWORKRS,ZPROVI2
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZTEM1, ZTEMV
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZWORK1D, ZWORKT, ZTEM1D, ZWORKZ, ZWORKZ2
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZTE, ZWO, ZWORKY
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZTE2, ZSTAB
+
+CHARACTER(LEN=40) :: YTEXTE
+CHARACTER(LEN=LEN(CTITGAL)) :: YTITGAL
+CHARACTER(LEN=2) :: YC2
+CHARACTER(LEN=1) :: YC1
+CHARACTER(LEN=16) :: YTITX, YTITY, YTEM
+CHARACTER(LEN=16) :: YBID
+INTEGER :: IBID,IRESP
+
+LOGICAL :: GINVZ
+LOGICAL :: GMXRAT
+LOGICAL :: GII1, GIJ1, GCH
+!------------------------------------------------------------------------------
+!
+YTEXTE(1:LEN(YTEXTE)) = ' '
+YTEXTE=ADJUSTL(CGROUP)
+CLEGEND(1:LEN(CLEGEND))=' '
+!CLEGEND2(1:LEN(CLEGEND2))=' '
+!CLEGEND2(1:7)='TIME = '
+CTITGAL(1:LEN(CTITGAL))=' '
+CUNITGAL(1:LEN(CUNITGAL))=' '
+CTIMEC(1:LEN(CTIMEC))=' '
+CTIMECS(1:LEN(CTIMECS))=' '
+CTIMEC(1:7)='TIME = '
+CTIMECS(1:7)='TIME = '
+NLOOPT=0
+LXABS=LXABSC
+if(nverbia > 0)then
+ print *,' **oper entree LPRESY,XHMIN,XHMAX ',LPRESY,XHMIN,XHMAX
+endif
+
+SELECT CASE(HTYPE)
+
+!*****************************************************************************
+!*****************************************************************************
+ CASE('CART')
+
+ IF(ALLOCATED(XVAR))THEN
+ II=SIZE(XVAR,1)
+ IJ=SIZE(XVAR,2)
+ IK=SIZE(XVAR,3)
+
+ ELSE
+ IF(LRS .OR. LRS1)THEN
+ IF(ALLOCATED(XTH))THEN
+ II=SIZE(XTH,1)
+ IJ=SIZE(XTH,2)
+ IK=SIZE(XTH,3)
+ ENDIF
+ ENDIF
+ ENDIF
+ if(nverbia > 0)then
+ print *,' **oper Entree II,IJ,IK,KLOOP ',II,IJ,IK,KLOOP
+ endif
+
+ IIB=1+JPHEXT; IIE=NIMAX+JPHEXT
+ IJB=1+JPHEXT; IJE=NJMAX+JPHEXT
+ IIU=NIMAX+2*JPHEXT
+ IJU=NJMAX+2*JPHEXT
+ IKU=NKMAX+2*JPVEXT
+ IF(CSTORAGE_TYPE == 'PG' .OR. CSTORAGE_TYPE == 'SU')THEN
+ IKU=1
+ ENDIF
+ IKB=1+JPVEXT; IKE=IKU-JPVEXT
+
+! Traitement des RS
+! *****************
+ IF(LRS .OR. LRS1)THEN
+!
+! Cas LRS ou LRS1 et KLOOP = 1 --> Allocation de tableaux pour memoriser
+! les infos utiles
+!
+ IF(KLOOP == 1)THEN
+
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+ IF(LRS)THEN
+ ILENW=NBTIMEDIA(KLOOP,1)
+ ELSE
+ ILENW=NSUPERDIA
+ ENDIF
+ ELSE
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1)+1
+ if(nverbia >0)then
+ print *,' **oper ilenw ',ILENW
+ endif
+ ENDIF
+ ALLOCATE(XTRS(SIZE(XTH,3),ILENW))
+ ALLOCATE(XPRS(SIZE(XTH,3),ILENW))
+ ALLOCATE(XURS(SIZE(XTH,3),ILENW))
+ ALLOCATE(XVRS(SIZE(XTH,3),ILENW))
+ ALLOCATE(XRVRS(SIZE(XTH,3),ILENW))
+ ALLOCATE(XTIMRS(ILENW))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF
+
+ ENDIF
+!
+! Lecture de U V et RV; chargement dans les tableaux de
+! travail puis desallocation des tableaux inutiles.
+!
+ IF(XIRS /= -999.)THEN
+ IIRS=NIRS
+ IJRS=NJRS
+ ENDIF
+ CALL CALUV_FORDIACHRO(KLOOP)
+ if(nverbia >0)then
+ print *,' **oper NIRS,NJRS ',NIRS,NJRS
+ endif
+
+
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF
+
+ IF(LRS)THEN
+ XTRS(:,JLOOPT)=XTH(NIRS,NJRS,:,NTIMEDIA(JLOOPT,KLOOP,1),1,1)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Correction suggeree par Joel et Isa en Decembre 98
+! XTRS(:,JLOOPT)=XTRS(:,JLOOPT)*XEXNREF(NIRS,NJRS,:)
+ XPRS(:,JLOOPT)=(XPRES(NIRS,NJRS,:,NTIMEDIA(JLOOPT,KLOOP,1),1,1)/ &
+ XP00)**(XRD/XCPD)
+ XTRS(:,JLOOPT)=XTRS(:,JLOOPT)*XPRS(:,JLOOPT)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ XPRS(:,JLOOPT)=XPRES(NIRS,NJRS,:,NTIMEDIA(JLOOPT,KLOOP,1),1,1)
+ ELSE IF(LRS1)THEN
+ XTRS(:,KLOOP)=XTH(NIRS,NJRS,:,NTIMEDIA(JLOOPT,KLOOP,1),1,1)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Correction suggeree par Joel et Isa en Decembre 98
+! XTRS(:,KLOOP)=XTRS(:,KLOOP)*XEXNREF(NIRS,NJRS,:)
+ XPRS(:,KLOOP)=(XPRES(NIRS,NJRS,:,NTIMEDIA(JLOOPT,KLOOP,1),1,1)/ &
+ XP00)**(XRD/XCPD)
+ XTRS(:,KLOOP)=XTRS(:,KLOOP)*XPRS(:,KLOOP)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ XPRS(:,KLOOP)=XPRES(NIRS,NJRS,:,NTIMEDIA(JLOOPT,KLOOP,1),1,1)
+ ENDIF
+ ENDDO
+
+ ELSE
+
+ II=0
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+ II=II+1
+ if(nverbia >0)then
+ print *,' **oper JLOOPT II ',JLOOPT,II
+ endif
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(II,JLOOPT)
+ ENDIF
+ XTRS(:,II)=XTH(NIRS,NJRS,:,JLOOPT,1,1)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Correction suggeree par Joel et Isa en Decembre 98
+! XTRS(:,II)=XTRS(:,II)*XEXNREF(NIRS,NJRS,:)
+ XPRS(:,II)=(XPRES(NIRS,NJRS,:,JLOOPT,1,1)/ &
+ XP00)**(XRD/XCPD)
+ XTRS(:,II)=XTRS(:,II)*XPRS(:,II)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ XPRS(:,II)=XPRES(NIRS,NJRS,:,JLOOPT,1,1)
+ ENDDO
+
+ ENDIF
+
+ IF(ALLOCATED(XTH))THEN
+ DEALLOCATE(XTH)
+ ENDIF
+ IF(ALLOCATED(XPRES))THEN
+ DEALLOCATE(XPRES)
+ ENDIF
+
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ IF(LRS)THEN
+ XURS(:,JLOOPT)=XU(NIRS,NJRS,:,NTIMEDIA(JLOOPT,KLOOP,1),1,1)
+ XVRS(:,JLOOPT)=XV(NIRS,NJRS,:,NTIMEDIA(JLOOPT,KLOOP,1),1,1)
+ XRVRS(:,JLOOPT)=XRVJD(NIRS,NJRS,:,NTIMEDIA(JLOOPT,KLOOP,1),1,1)
+ XTIMRS(JLOOPT)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ELSE IF(LRS1)THEN
+ XURS(:,KLOOP)=XU(NIRS,NJRS,:,NTIMEDIA(JLOOPT,KLOOP,1),1,1)
+ XVRS(:,KLOOP)=XV(NIRS,NJRS,:,NTIMEDIA(JLOOPT,KLOOP,1),1,1)
+ XRVRS(:,KLOOP)=XRVJD(NIRS,NJRS,:,NTIMEDIA(JLOOPT,KLOOP,1),1,1)
+ XTIMRS(KLOOP)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ENDIF
+ ENDDO
+
+ ELSE
+
+ II=0
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+ II=II+1
+ XTIMRS(II)=XTRAJT(JLOOPT,1)
+ XURS(:,II)=XU(NIRS,NJRS,:,JLOOPT,1,1)
+ XVRS(:,II)=XV(NIRS,NJRS,:,JLOOPT,1,1)
+ XRVRS(:,II)=XRVJD(NIRS,NJRS,:,JLOOPT,1,1)
+ ENDDO
+ ENDIF
+
+ IF(ALLOCATED(XU))THEN
+ DEALLOCATE(XU)
+ ENDIF
+ IF(ALLOCATED(XV))THEN
+ DEALLOCATE(XV)
+ ENDIF
+ IF(ALLOCATED(XRVJD))THEN
+ DEALLOCATE(XRVJD)
+ ENDIF
+
+
+ GMXRAT=.TRUE.
+ IF(XIRS == -999.)THEN
+ IF(NIRS>99) THEN
+ IF(NJRS>99) THEN
+ WRITE(YTEXTE,'(''I='',I4,'' J='',I4)')NIRS,NJRS
+ ELSE
+ WRITE(YTEXTE,'(''I='',I4,'' J='',I2)')NIRS,NJRS
+ ENDIF
+ ELSE
+ IF(NJRS>99) THEN
+ WRITE(YTEXTE,'(''I='',I2,'' J='',I4)')NIRS,NJRS
+ ELSE
+ WRITE(YTEXTE,'(''I='',I2,'' J='',I2)')NIRS,NJRS
+ ENDIF
+ ENDIF
+ ELSE
+ WRITE(YTEXTE,'(''LAT='',F6.2,'' LON='',F6.2)')XIRS,XJRS
+ ENDIF
+ YTEXTE=ADJUSTL(YTEXTE)
+ IF(NMT == 1)THEN
+! WRITE(CLEGEND(104:110),'(''UM-VM'')')
+! YTEXTE(1:5)='UM-VM'
+ CLEGEND(104:108)='UM-VM'
+ ELSE
+! WRITE(CLEGEND(104:110),'(''UT-VT'')')
+! YTEXTE(1:5)='UT-VT'
+ CLEGEND(104:108)='UT-VT'
+ ENDIF
+ CALL TABCOL_FORDIACHRO
+ CALL GSTXFP(-13,2)
+
+ IF(KLOOP == 1 .AND. LRS)THEN
+
+ DO JLOOPT=1,ILENW
+ IF(LPRDAT .AND. ILENW > 1)THEN ! Juin 2001 Ajout des dates ds FICVAL
+! Pour distiller les dates une par une
+! Si ILENW = 1 on ne fait rien . OK
+ IF(JLOOPT == 1)THEN
+!!!dec 2001
+ IF(ALLOCATED(XPRDAT))THEN
+!!!dec 2001
+ IF(ALLOCATED(ZPROVI2))DEALLOCATE(ZPROVI2)
+ ALLOCATE(ZPROVI2(16,SIZE(XPRDAT,2)))
+ ZPROVI2(:,:)=XPRDAT(:,:)
+ DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ XPRDAT(:,1)=ZPROVI2(:,JLOOPT)
+!!!dec 2001
+ ELSE
+ XPRDAT(:,1)=ZPROVI2(:,JLOOPT)
+ ENDIF
+ ELSE
+ print *,' *operA XPRDAT NON ALLOUE'
+ ENDIF
+!!!dec 2001
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+ IF(NVERBIA > 0)THEN
+ print *,' KLOOP,LRS,JLOOPT,NTIMEDIA(JLOOPT,KLOOP,1) ', &
+ KLOOP,LRS,JLOOPT,NTIMEDIA(JLOOPT,KLOOP,1)
+ ENDIF
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ ELSE
+ II=NTIMEDIA(1,KLOOP,1)+(JLOOPT-1)*NTIMEDIA(3,KLOOP,1)
+ if(nverbia >0)then
+ print *,' **oper II de RESOLV_TIMES(II) ',II
+ endif
+ CALL RESOLV_TIMES(II)
+ ENDIF
+ CTIMEC(1:LEN(CTIMEC))=' '
+ CTIMEC(1:3)=' ('
+ WRITE(CTIMEC(4:11),'(F8.0)')XTIMRS(JLOOPT)
+ CTIMEC(LEN_TRIM(CTIMEC)+1:LEN_TRIM(CTIMEC)+2)='s)'
+
+ GMXRAT=.TRUE.
+
+ DO J=IKB,IKE
+ IF(XRVRS(J,JLOOPT) <=0.)print *,' No dew point line drawn as nil or' &
+ ,' negative water values were found'
+ ENDDO
+ CALL GSCLIP(0)
+ CALL TSOUND_FORDIACHRO(XPRS(IKB:IKE,JLOOPT),XTRS(IKB:IKE,JLOOPT), &
+ XRVRS(IKB:IKE,JLOOPT),XURS(IKB:IKE,JLOOPT), &
+ XVRS(IKB:IKE,JLOOPT),IKE-IKB+1,CLEGEND,&
+ YTEXTE,GMXRAT,.TRUE.&
+ ,.FALSE.,.FALSE.)
+ CALL GSCLIP(1)
+! CALL NGPICT(1,1)
+! CALL GQACWK(1,IER,INB,IWK)
+! IF(INB > 1)CALL NGPICT(2,3)
+ CALL FRAME
+ ENDDO
+ IF(.NOT.ALLOCATED(XTRS))print *,' XTRS NON ALLOUE'
+ IF(.NOT.ALLOCATED(XPRS))print *,' XPRS NON ALLOUE'
+ IF(.NOT.ALLOCATED(XURS))print *,' XURS NON ALLOUE'
+ IF(.NOT.ALLOCATED(XVRS))print *,' XVRS NON ALLOUE'
+ IF(.NOT.ALLOCATED(XRVRS))print *,' XRVRS NON ALLOUE'
+ IF(.NOT.ALLOCATED(XTIMRS))print *,' XTIMRS NON ALLOUE'
+ if(nverbia > 0)then
+ print *,' *operA AV DEALLOCATE(XTRS,XPRS,XURS,XVRS,XRVRS,XTIMRS) '
+ endif
+ DEALLOCATE(XTRS,XPRS,XURS,XVRS,XRVRS,XTIMRS)
+ if(nverbia > 0)then
+ print *,' *operA AP DEALLOCATE(XTRS,XPRS,XURS,XVRS,XRVRS,XTIMRS) '
+ endif
+ ELSE IF(LRS1 .AND. KLOOP == NSUPERDIA)THEN
+
+ GMXRAT=.TRUE.
+! On met la date courante du 1er temps demande de la 1ere superposition
+ CALL RESOLV_TIMES(NTIMEDIA(1,1,1))
+ CALL GSCLIP(0)
+ CALL TSOUND_FORDIACHRO(XPRS(IKB:IKE,1),XTRS(IKB:IKE,1), &
+ XRVRS(IKB:IKE,1),XURS(IKB:IKE,1), &
+ XVRS(IKB:IKE,1),IKE-IKB+1,CLEGEND,YTEXTE,GMXRAT,.TRUE.&
+ ,.FALSE.,.FALSE.)
+ CALL GSCLIP(1)
+! CALL NGPICT(1,1)
+! CALL GQACWK(1,IER,INB,IWK)
+! IF(INB > 1)CALL NGPICT(2,3)
+ CALL FRAME
+ print *,' *operB AV DEALLOCATE(XTRS,XPRS,XURS,XVRS,XRVRS,XTIMRS) '
+ DEALLOCATE(XTRS,XPRS,XURS,XVRS,XRVRS,XTIMRS)
+ print *,' *operB AP DEALLOCATE(XTRS,XPRS,XURS,XVRS,XRVRS,XTIMRS) '
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(XIRS /= -999.)THEN
+ NIRS=IIRS
+ NJRS=IJRS
+ ENDIF
+
+ ELSE
+!
+! Infos autres que RS
+! *******************
+
+ IF(II == 1 .AND. IJ == 1 .AND. IK == 1)THEN
+
+! Cas compression bilan sur tous les axes ou scalaire unique f(t)
+! ****************************************************************
+
+
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+ ILENW=NBTIMEDIA(KLOOP,1)
+ ELSE
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/NTIMEDIA(3,KLOOP,1)+1
+ ENDIF
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+ ALLOCATE(ZWORKT(NBTIMEDIA(KLOOP,1)))
+ ALLOCATE(ZWORK1D(NBTIMEDIA(KLOOP,1)))
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+
+ CALL LOADUNITIT(JLOOPP,KLOOP)
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+ IF(JLOOPT == 1)CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ ZWORKT(JLOOPT)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ZWORK1D(JLOOPT)=XVAR(1,1,1,NTIMEDIA(JLOOPT,KLOOP,1),1,NPROCDIA(JLOOPP,KLOOP))
+ ENDDO
+ CALL VARFCT(ZWORKT,ZWORK1D,1)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDDO
+ DEALLOCATE(ZWORKT,ZWORK1D)
+ ELSE
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/NTIMEDIA(3,KLOOP,1)+1
+ ALLOCATE(ZWORKT(ILENW))
+ ALLOCATE(ZWORK1D(ILENW))
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+
+ CALL LOADUNITIT(JLOOPP,KLOOP)
+
+ IJLT=0
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))CALL RESOLV_TIMES(JLOOPT)
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(IJLT)=XTRAJT(JLOOPT,1)
+ ZWORK1D(IJLT)=XVAR(1,1,1,JLOOPT,1,NPROCDIA(JLOOPP,KLOOP))
+ ENDDO
+ CALL VARFCT(ZWORKT,ZWORK1D,1)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDDO
+ DEALLOCATE(ZWORKT,ZWORK1D)
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(.NOT.LICP .AND. .NOT.LJCP .AND. .NOT.LKCP)THEN
+
+! Cas scalaire (Impression dim mat. modele et matrice(1,1,1)
+! ------------
+
+ ELSE IF(LICP .AND. LJCP .AND. LKCP)THEN
+
+! Cas bilan compresse (Impression dim mat. modele et matrice
+! ------------------- NIL:NIH,NJL:NJH,NKL:NKH)et
+! matrice (1,1,1)
+
+ ENDIF
+
+ ELSE IF(II == 1 .AND. IJ == 1 .AND. IK /= 1)THEN
+
+! Cas compression bilan sur axes X et Y ou PV --> Profil vertical
+! ****************************************************************
+!
+ IDEFCV=0 !%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(LDEFCV2CC)THEN
+ LDEFCV2CC=.FALSE.
+ IDEFCV=1
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%
+ L1DT=.TRUE.
+ ALLOCATE(ZTEM1D(IKU),ZWORKZ(IKU))
+
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+
+!!! Octobre 2001
+ IF(JLOOPP > 1 .AND. LUMVMPV .AND. LPV)EXIT
+!!! Octobre 2001
+ IF(LPVKT .AND. NSUPERDIA>1)THEN
+ IF(NBPROCDIA(KLOOP)>1 .OR. NBLVLKDIA(KLOOP,1)>1)THEN
+ print *,' _PVKT_ SUPERPOSITIONS : '
+!fuji print *,' On ne peut definir de part de d''autre '&
+!fuji &'de _ON_ qu''1 seul processus et 1 seul niveau'
+ print *,' On ne peut definir de part de d''autre '
+ print *,'de _ON_ qu''1 seul processus et 1 seul niveau'
+ print *,' Nb de niveaux demandes : ',NBLVLKDIA(KLOOP,1)
+ print *,' Nb de processus demandes : ',NBPROCDIA(KLOOP)
+ print *,' *** MODIFIEZ VOTRE DIRECTIVE *** '
+ EXIT
+ ENDIF
+ ENDIF
+
+! Modif AOUT 97
+ ZTEM1D(:)=XSPVAL; ZWORKZ(:)=0.
+! ZTEM1D(:)=0.; ZWORKZ(:)=0.
+
+ CALL LOADUNITIT(JLOOPP,KLOOP)
+!!!!!Mars 2000
+ IF(LUMVM)THEN
+ NMGRID=1
+ ENDIF
+ IF(LUMVMPV)THEN
+ NMGRID=1
+ ENDIF
+!!!!!Mars 2000
+
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+! Expression temps non incrementale
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+! Chargement cas PV
+
+ ZTEM1D(NKL:NKH)=XVAR(1,1,: &
+ ,NTIMEDIA(JLOOPT,KLOOP,1),1,NPROCDIA(JLOOPP,KLOOP))
+
+ ZWORKZ(:)=XXZ(:,NMGRID)
+! print * ,'**operoper NMGRID XXZ ',NMGRID
+! print * ,XXZ(:,NMGRID)
+ IF(NIL /= 1 .OR. NJL /= 1)THEN
+ IF(LICP .OR. LJCP)THEN
+! print *,'**operoper LICP LJCP ',LICP,LJCP
+ ELSE
+ ZWORKZ(:)=XZZ(NIL,NJL,:)
+ ENDIF
+ IF(NKL == 1 .AND. NKH == IKU)THEN
+ ZTEM1D(1)=XSPVAL
+ ZTEM1D(IKU)=XSPVAL
+ ENDIF
+ ENDIF
+
+
+ IF(LPV)THEN
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(LUMVMPV)THEN
+ LPV=.FALSE. ; LPVT=.TRUE.
+ IF(JLOOPP == 1)THEN
+!!!! Octobre 2001
+ ILENW=1
+ ALLOCATE(ZTEM2D(1:IKU,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZWORKT=NLOOPT
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ ALLOCATE(XTEM2D2(1:IKU,ILENW))
+ XTEM2D2=XSPVAL
+ XTEM2D(:,1)=ZTEM1D
+ XTEM2D2(NKL:NKH,1)=XVAR(1,1,: &
+ ,NTIMEDIA(JLOOPT,KLOOP,1),1,NPROCDIA(JLOOPP+1,KLOOP))
+ IF(NBPROCDIA(KLOOP) == 3)THEN
+ ZTEM2D=XSPVAL
+ ZTEM2D(NKL:NKH,1)=XVAR(1,1,: &
+ ,NTIMEDIA(JLOOPT,KLOOP,1),1,NPROCDIA(JLOOPP+2,KLOOP))
+
+ CALL COLVECT(IKU,ZTEM2D)
+ ENDIF
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LUMVMPV)THEN
+ LPV=.TRUE. ; LPVT=.FALSE.
+ ENDIF
+ DEALLOCATE(ZTEM2D,ZWORKT)
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ LCOLPVT=.FALSE.
+ ENDIF
+
+ ELSE
+!!!! Octobre 2001
+
+ CALL TRAPRO_FORDIACHRO(ZTEM1D,ZWORKZ,KLOOP)
+
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ELSE IF(LPVT .OR. LPVKT)THEN
+ IF(JLOOPT == 1)THEN
+ ILENW=NBTIMEDIA(KLOOP,1)
+ ALLOCATE(ZTEM2D(1:IKU,ILENW))
+ ZTEM2D=XSPVAL
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+!!!!!Mars 2000
+ IF(LUMVM)THEN
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ ENDIF
+
+ IF(LUMVMPV .AND. JLOOPP == 1)THEN
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ ALLOCATE(XTEM2D2(1:IKU,ILENW))
+ XTEM2D2=XSPVAL
+ ENDIF
+!!!!!Mars 2000
+ ALLOCATE(ZWORKT(ILENW))
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(JLOOPT)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ZTEM2D(NKL:NKH,JLOOPT)= XVAR(1,1,:, &
+ NTIMEDIA(JLOOPT,KLOOP,1),1,NPROCDIA(JLOOPP,KLOOP))
+!!!!!Mars 2000
+ IF(LUMVM)THEN
+ XTEM2D(NKL:NKH,JLOOPT)= XU(1,1,:, &
+ NTIMEDIA(JLOOPT,KLOOP,1),1,NPROCDIA(JLOOPP,KLOOP))
+ ENDIF
+!!!!!Mars 2000
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ XPVMIN=MINVAL(ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),:))
+ XPVMAX=MAXVAL(ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),:))
+ CALL VALMNMX(XPVMIN,XPVMAX)
+ IF(ABS(XPVMAX-XPVMIN) < 1.E-4)THEN
+ XPVMIN=XPVMIN-1.
+ XPVMAX=XPVMAX+1.
+ ENDIF
+ IF(NKL == 1 .AND. NKH == IKU)THEN
+ ZTEM2D(1,:)=XSPVAL
+ ZTEM2D(IKU,:)=XSPVAL
+ ENDIF
+
+ IF(LUMVMPV)THEN
+ IF(JLOOPP == 1)THEN
+! Memorisation de U
+ XTEM2D=ZTEM2D
+ CYCLE
+ ELSEIF(JLOOPP == 2)THEN
+ IF(JLOOPP == NBPROCDIA(KLOOP))THEN
+ XTEM2D2=ZTEM2D
+ ELSE
+ XTEM2D2=ZTEM2D
+ CYCLE
+ ENDIF
+ ELSEIF(JLOOPP == 3)THEN
+ CALL COLVECT(IKU,ZTEM2D)
+ ENDIF
+ ENDIF
+
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LPRDAT) DEALLOCATE(XPRDAT) ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(ZTEM2D,ZWORKT)
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ LCOLPVT=.FALSE.
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ELSE
+! Expression temps incrementale !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+ CALL RESOLV_TIMES(JLOOPT)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(JLOOPT,1)
+
+ ZTEM1D(NKL:NKH)=XVAR(1,1,: &
+ ,JLOOPT,1,NPROCDIA(JLOOPP,KLOOP))
+
+ ZWORKZ(:)=XXZ(:,NMGRID)
+! print * ,'**operoper NMGRID XXZ ',NMGRID
+! print * ,XXZ(:,NMGRID)
+ IF(NIL /= 1 .OR. NJL /= 1)THEN
+ IF(LICP .OR. LJCP)THEN
+! print * ,'**operoper LICP, LJCP ',LICP, LJCP
+ ELSE
+ ZWORKZ(:)=XZZ(NIL,NJL,:)
+ ENDIF
+ IF(NKL == 1 .AND. NKH == IKU)THEN
+ ZTEM1D(1)=XSPVAL
+ ZTEM1D(IKU)=XSPVAL
+ ENDIF
+ ENDIF
+
+ IF(LPV)THEN
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(LUMVMPV)THEN
+ LPV=.FALSE. ; LPVT=.TRUE.
+!!!Octobre 2001
+ IF(JLOOPP == 1)THEN
+ ILENW=1
+ ALLOCATE(ZTEM2D(1:IKU,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZWORKT=NLOOPT
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ ALLOCATE(XTEM2D2(1:IKU,ILENW))
+ XTEM2D2=XSPVAL
+ XTEM2D(:,1)=ZTEM1D
+ XTEM2D2(NKL:NKH,1)=XVAR(1,1,: &
+ ,JLOOPT,1,NPROCDIA(JLOOPP+1,KLOOP))
+ IF(NBPROCDIA(KLOOP) == 3)THEN
+ ZTEM2D=XSPVAL
+ ZTEM2D(NKL:NKH,1)=XVAR(1,1,: &
+ ,JLOOPT,1,NPROCDIA(JLOOPP+2,KLOOP))
+
+ CALL COLVECT(IKU,ZTEM2D)
+ ENDIF
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LUMVMPV)THEN
+ LPV=.TRUE. ; LPVT=.FALSE.
+ ENDIF
+ DEALLOCATE(ZTEM2D,ZWORKT)
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ LCOLPVT=.FALSE.
+ ENDIF
+
+ ELSE
+!!!Octobre 2001
+ CALL TRAPRO_FORDIACHRO(ZTEM1D,ZWORKZ,KLOOP)
+!!!Octobre 2001
+ ENDIF
+!!!Octobre 2001
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+
+ ELSE IF(LPVT .OR. LPVKT)THEN
+
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/NTIMEDIA(3,KLOOP,1) +1
+ IF(NVERBIA > 0)THEN
+ print *,' OPER NTIMEDIA(2,KLOOP,1) NTIMEDIA(1,KLOOP,1) NTIMEDIA(3,KLOOP,1) ILENW ', &
+ NTIMEDIA(2,KLOOP,1),NTIMEDIA(1,KLOOP,1),NTIMEDIA(3,KLOOP,1), &
+ ILENW, &
+ XTIMEDIA(2,KLOOP,1),XTIMEDIA(1,KLOOP,1),XTIMEDIA(3,KLOOP,1)
+ ENDIF
+
+ ITIMEND=NTIMEDIA(1,KLOOP,1) + &
+ (((NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1))*NTIMEDIA(3,KLOOP,1))
+
+ IF(NVERBIA > 0)THEN
+ print *,' ITIMEND A',ITIMEND
+ ENDIF
+
+ IF(ALLOCATED(ZTEM2D))THEN
+ DEALLOCATE(ZTEM2D)
+ ENDIF
+ IF(ALLOCATED(ZWORKT))THEN
+ DEALLOCATE(ZWORKT)
+ ENDIF
+ ALLOCATE(ZTEM2D(1:IKU,ILENW))
+ ZTEM2D=XSPVAL
+!!!!!Mars 2000
+ IF(LUMVM)THEN
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ ENDIF
+
+ IF(LUMVMPV .AND. JLOOPP == 1)THEN
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ ALLOCATE(XTEM2D2(1:IKU,ILENW))
+ XTEM2D2=XSPVAL
+ ENDIF
+!!!!!Mars 2000
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ALLOCATE(ZWORKT(ILENW))
+ IJLT=0
+ ENDIF
+
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(IJLT)=XTRAJT(JLOOPT,1)
+ if(nverbia >0)then
+! print *,' **oper AV ZTEM2D(NKL:NKH,IJLT)= '
+ endif
+ ZTEM2D(NKL:NKH,IJLT)= &
+ XVAR(1,1,:, &
+ JLOOPT,1,NPROCDIA(JLOOPP,KLOOP))
+ if(nverbia >0)then
+! print *,' **oper AP ZTEM2D(NKL:NKH,IJLT)= '
+ endif
+!!!!!Mars 2000
+ IF(LUMVM)THEN
+ XTEM2D(NKL:NKH,IJLT)= &
+ XU(1,1,:, &
+ JLOOPT,1,NPROCDIA(JLOOPP,KLOOP))
+ ENDIF
+!!!!!Mars 2000
+
+! IF(JLOOPT == NTIMEDIA(2,KLOOP,1))THEN
+ IF(JLOOPT == ITIMEND)THEN
+ XPVMIN=MINVAL(ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),:))
+ XPVMAX=MAXVAL(ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),:))
+ CALL VALMNMX(XPVMIN,XPVMAX)
+ if(nverbia >0)then
+ print *,' **oper AP CALL VALMNMX(XPVMIN,XPVMAX)'
+ endif
+ IF(ABS(XPVMAX-XPVMIN) < 1.E-4)THEN
+ XPVMIN=XPVMIN-1.
+ XPVMAX=XPVMAX+1.
+ ENDIF
+ IF(NKL == 1 .AND. NKH == IKU)THEN
+ ZTEM2D(1,:)=XSPVAL
+ ZTEM2D(IKU,:)=XSPVAL
+ ENDIF
+
+ IF(LUMVMPV)THEN !llllllllllllllllllll
+
+ IF(JLOOPP == 1)THEN !kkkkkkkkkkkkkkkkkkkkkkk
+! Memorisation de U
+ XTEM2D=ZTEM2D
+ CYCLE
+ ELSEIF(JLOOPP == 2)THEN !kkkkkkkkkkkkkkkkkkkkk
+ IF(JLOOPP == NBPROCDIA(KLOOP))THEN
+ XTEM2D2=ZTEM2D
+ ELSE
+ XTEM2D2=ZTEM2D
+ CYCLE
+ ENDIF
+ ELSEIF(JLOOPP == 3)THEN !kkkkkkkkkkkkkkkkkkkkk
+ CALL COLVECT(IKU,ZTEM2D)
+ ENDIF !kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk
+ ENDIF !llllllllllllllllllllllllllllllllll
+
+ if(nverbia >0)then
+ print *,' ** oper AV CALL PVFCT xx'
+ endif
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(ZWORKT,ZTEM2D)
+ if(nverbia >0)then
+ print *,' ** oper AP CALL PVFCT xx'
+ endif
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ LCOLPVT=.FALSE.
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ if(nverbia >0)then
+ print *,' ** oper AP CALL FRAME xx'
+ endif
+ ENDIF
+
+ ENDIF ! Fin if=ITIMEND
+ ENDIF
+ ENDDO ! fin boucle temporelle
+ ENDIF ! Tps increm ou non
+
+ ENDDO ! Processus
+ DEALLOCATE(ZTEM1D,ZWORKZ)
+ IF(.NOT.LICP .AND. .NOT.LJCP .AND. .NOT.LKCP)THEN
+!
+! Cas PV enregistre comme tel
+!
+ ELSE IF(LICP .AND. LJCP .AND. .NOT.LKCP)THEN
+! (Impression dim mat. modele et matrice(NIL:NIH,NJL:NJH,
+! NKL:NKH) et matrice(1,1,NKL:NKH)
+ ENDIF
+
+ IF(IDEFCV==1)THEN !%%%%%%%%%%%%%%%%%%%%%%%%%%
+ LDEFCV2CC=.TRUE.
+ IDEFCV=0
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+ ELSE IF(II == 1 .AND. IJ /= 1 .AND. IK /= 1 .AND. LICP)THEN
+
+! Cas compression bilan sur axe X --> Plan vertical // Y
+! *******************************************************
+! (Impression dim mat. modele et matrice(NIL:NIH,NJL:NJH,
+! NKL:NKH) et matrice(1,NJL:NJH,NKL:NKH)
+ LCVYZ=.TRUE.
+ IDEFCV=0 !%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(LDEFCV2CC)THEN
+ LDEFCV2CC=.FALSE.
+ IDEFCV=1
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(.NOT.L2DBY)THEN
+ IJINF=MAX(IJB,NJL)
+ IJSUP=MIN(IJE,NJH)
+ print *,' 2D Vertical // Y '
+ print *,' Limites J par defaut (L2DBY=.FALSE.)(par / au domaine integral de simulation, points de garde compris) :',&
+& ' MAX(IJB,NJL) - MIN(IJE,NJH) ',IJINF,' - ',IJSUP
+ print *,' Si vous voulez selectionner les limites en J, mettez : ',&
+& 'L2DBY=.TRUE.'
+ print *,' et definissez : NJDEBCOU= NLMAX= '
+ ELSE
+ IJINF=NJDEBCOU
+ IJSUP=NJDEBCOU+NLMAX-1
+ IJSUP=MIN(IJSUP,NJH)
+ ENDIF
+ ALLOCATE(ZTEM2D(1:IJSUP-IJINF+1,1:IKU))
+ NINX=IJSUP-IJINF+1
+ NINY=IKU
+ NLMAX=NINX
+ NLANGLE=90
+ NJDEBCOU=IJINF
+ IIDEBCOU=-999
+ IF(NIDEBCOU /= NIL)THEN
+ IIDEBCOU=NIDEBCOU
+ NIDEBCOU=NIL
+! print *,' NIDEBCOU force a la valeur de NIL ',NIL,' pour ', &
+!& 'obtention altitudes correctes '
+! print *,' AP utilisation, sera remis a la valeur precedente : ', &
+! IIDEBCOU
+ ENDIF
+ LVERT=.TRUE.
+ LHOR=.FALSE.
+ LPT=LPXT
+ IF(NSUPERDIA > 1)THEN
+ IF(LMINUS .OR. LPLUS)THEN
+ IF(NBPM > 1)THEN
+ DO JU=1,NBPM
+ IF(NUMPM(JU) == 3)THEN
+ LSUPER=.TRUE.
+ EXIT
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ ENDDO
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ ELSE
+ LSUPER=.TRUE.
+ ENDIF
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ IF(KLOOP == 1)NSUPER=0
+ DO JLOOPP=1,NBPROCDIA(KLOOP) !--- LCVYZ-------------
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+ NMGRID=NGRIDIA(NLOOPP)
+ IF(JLOOPP == 1)NSUPER=0
+
+ CALL LOADUNITIT(JLOOPP,KLOOP)
+
+ ILENT=LEN_TRIM(CTITGAL)
+ ILENU=LEN_TRIM(CUNITGAL)
+ YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+ YTEXTE(ILENT+1:ILENT+1)=' '
+ YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ IF(.NOT. LSUPER .OR. (LSUPER .AND. NSUPER == 0))THEN
+ DO J=1,NINX
+ XZWORKZ(J,1:IKU)=XXZ(:,NMGRID)
+ ENDDO
+ XZZDS(1:NINX)=XXY(IJINF:IJSUP,NMGRID)
+ ZWL=XZZDS(1); ZWR=XZZDS(NINX)
+ IF((XHMIN == 0. .AND. XHMAX == 0.) .OR. (XHMAX<=XHMIN))THEN
+ XHMIN=0.
+ XHMAX=XZWORKZ(1,IKE)
+ ENDIF
+ ZWB=XHMIN; ZWT=XHMAX
+ CALL SET(.1,.9,.1,.9,ZWL,ZWR,ZWB,ZWT,1)
+ CALL GSCLIP(1)
+ CALL CPSETI('SET',0)
+ CALL CPSETI('MAP',4)
+ ENDIF
+ ZTEM2D=XSPVAL
+ ZTEM2D(1:IJSUP-IJINF+1,NKL:NKH)=XVAR(1, &
+ IJINF-NJL+1:IJSUP-NJL+1,:,NTIMEDIA(JLOOPT,KLOOP,1),&
+ 1,NPROCDIA(JLOOPP,KLOOP))
+ IF(NKL < IKB)THEN
+ ZTEM2D(:,1:IKB-1)=XSPVAL
+ ENDIF
+ IF(NKH > IKE)THEN
+ ZTEM2D(:,IKE+1:IKU)=XSPVAL
+ ENDIF
+ if(nverbia >0)THEN
+ print *,' ** oper appel imcou Ytexte ',YTEXTE(1:LEN_TRIM(YTEXTE))
+ endif
+ IF(KLOOP == 1)NSUPER=0
+ CALL IMCOU_FORDIACHRO(ZTEM2D,XDIAINT,CLEGEND,YTEXTE(1:LEN_TRIM&
+ (YTEXTE)))
+! IF(KLOOP == NSUPERDIA)CALL FRAME
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDDO
+ ELSE
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1), &
+ NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL RESOLV_TIMES(JLOOPT)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(JLOOPT,1)
+ IF(.NOT. LSUPER .OR. (LSUPER .AND. NSUPER == 0))THEN
+ DO J=1,NINX
+ XZWORKZ(J,1:IKU)=XXZ(:,NMGRID)
+ ENDDO
+ XZZDS(1:NINX)=XXY(IJINF:IJSUP,NMGRID)
+ ZWL=XZZDS(1); ZWR=XZZDS(NINX)
+ IF((XHMIN == 0. .AND. XHMAX == 0.) .OR. (XHMAX<=XHMIN))THEN
+ XHMIN=0.
+ XHMAX=XZWORKZ(1,IKE)
+ ENDIF
+ ZWB=XHMIN; ZWT=XHMAX
+ CALL SET(.1,.9,.1,.9,ZWL,ZWR,ZWB,ZWT,1)
+ CALL GSCLIP(1)
+ CALL CPSETI('SET',0)
+ CALL CPSETI('MAP',4)
+ ENDIF
+ ZTEM2D=XSPVAL
+ ZTEM2D(1:IJSUP-IJINF+1,NKL:NKH)=XVAR(1, &
+ IJINF-NJL+1:IJSUP-NJL+1,:,JLOOPT,1, &
+ NPROCDIA(JLOOPP,KLOOP))
+ IF(NKL < IKB)THEN
+ ZTEM2D(:,1:IKB-1)=XSPVAL
+ ENDIF
+ IF(NKH > IKE)THEN
+ ZTEM2D(:,IKE+1:IKU)=XSPVAL
+ ENDIF
+ if(nverbia >0)THEN
+ print *,' ** oper appel imcou Ytexte ',YTEXTE(1:LEN_TRIM(YTEXTE))
+ endif
+ IF(KLOOP ==1)NSUPER=0
+ CALL IMCOU_FORDIACHRO(ZTEM2D,XDIAINT,CLEGEND,YTEXTE(1:LEN_TRIM&
+ (YTEXTE)))
+! IF(KLOOP == NSUPERDIA)CALL FRAME
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO !--- LCVYZ-------------
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(ZTEM2D)
+ IF(IIDEBCOU /= -999)THEN
+ NIDEBCOU=IIDEBCOU
+ ENDIF
+
+ IF(IDEFCV==1)THEN !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ LDEFCV2CC=.TRUE.
+ IDEFCV=0
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+ ELSE IF((II == 1 .OR. IIE-IIB == 0) .AND. IJ /= 1 .AND. IK == 1)THEN
+
+! Cas compression bilan sur axes X et Z --> Profil horizontal // Y
+! mais a representer comme f(t)
+! ********************************************************************
+! (Impression dim mat. modele et matrice(NIL:NIH,NJL:NJH,
+! NKL:NKH) et matrice(1,NJL:NJH,1)
+ print *,' Profil horizontal // Y'
+ IINF=NIINF;ISUP=NISUP;IJINF=NJINF;IJSUP=NJSUP
+ if(nverbia > 0)then
+ print *,'IINF,ISUP,IJINF,IJSUP ',IINF,ISUP,IJINF,IJSUP
+ endif
+ IF(II == 1)THEN
+ GII1=.TRUE.
+ ELSE
+ GII1=.FALSE.
+ LCH=.FALSE.
+ ENDIF
+
+ IF(GII1)THEN
+ IF(.NOT.L2DBY)THEN
+ NIINF=1; NISUP=1
+ NJINF=MAX(IJB,NJL); NJSUP=MIN(IJE,NJH)
+ print *,' Profil horizontal // Y '
+ print *,' Limites J par defaut (L2DBY=.FALSE.) :',&
+& ' MAX(IJB,NJL) - MIN(IJE,NJH) ',NJINF,' - ',NJSUP
+ print *,' Si vous voulez selectionner les limites en J, mettez : ',&
+& 'L2DBY=.TRUE.'
+ print *,' et definissez : NJDEBCOU= NLMAX= '
+ ELSE
+ NIINF=1; NISUP=1
+ NJINF=NJDEBCOU; NJSUP=NJDEBCOU+NLMAX-1
+ NJINF=MAX(NJINF,NJL);NJSUP=MIN(NJSUP,NJH)
+ ENDIF
+ ELSE
+ IF(.NOT.L2DBY)THEN
+ NIINF=IIB; NISUP=NIINF
+ NJINF=MAX(IJB,NJL); NJSUP=MIN(IJE,NJH)
+ print *,' Profil horizontal // Y '
+ print *,' Limites J par defaut (L2DBY=.FALSE.) :',&
+& ' MAX(IJB,NJL) - MIN(IJE,NJH) ',NJINF,' - ',NJSUP
+ print *,' Si vous voulez selectionner les limites en J, mettez : ',&
+& 'L2DBY=.TRUE.'
+ print *,' et definissez : NJDEBCOU= NLMAX= '
+ ELSE
+ NIINF=IIB; NISUP=NIINF
+ NJINF=NJDEBCOU; NJSUP=NJDEBCOU+NLMAX-1
+ NJINF=MAX(NJINF,NJL);NJSUP=MIN(NJSUP,NJH)
+ ENDIF
+ ENDIF
+ ILENW=NJSUP-NJINF+1
+
+ ALLOCATE(ZWORK1D(ILENW),ZWORKY(ILENW))
+
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+
+ YTITX(1:LEN(YTITX))=' '
+ YTITY(1:LEN(YTITY))=' '
+
+ CALL LOADUNITIT(JLOOPP,KLOOP)
+
+ YTITX='Y(M)'
+ YTITY=CUNITGAL(1:LEN_TRIM(CUNITGAL))
+
+ ZWORK1D(:)=0.; ZWORKY(:)=0.
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+
+ IF(LPYT)THEN
+ IF(JLOOPT == 1)THEN
+ ILENW=NBTIMEDIA(KLOOP,1)
+ IX=NJSUP-NJINF+1
+ ALLOCATE(ZTEM2D(IX,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(JLOOPT)=XTRAJT(NLOOPT,1)
+ ZTEM2D(:,JLOOPT)=XVAR(NIINF,NJINF-NJL+1:NJSUP-NJL+1,1, &
+ NLOOPT,1,NLOOPP)
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+ DEALLOCATE(ZTEM2D,ZWORKT)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+
+ ELSE
+
+ ZWORK1D=XXY(NJINF:NJSUP,NMGRID)
+ ZWORKY=XVAR(NIINF,NJINF-NJL+1:NJSUP-NJL+1,1,NTIMEDIA(JLOOPT,KLOOP,1),1,NLOOPP)
+ ZTIMED=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ZTIMEF=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ IF(JLOOPT == 1)THEN
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRAXY(ZWORK1D,ZWORKY,KLOOP,YTITX,YTITY,ZTIMED,ZTIMEF)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+! IF(KLOOP == NSUPERDIA)CALL FRAME
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+
+ ENDIF
+ ENDDO
+
+ ELSE
+
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+
+ IF(LPYT)THEN
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1)+1
+! print *,'oper verif ilenw ',ILENW
+ ITIMEND=NTIMEDIA(1,KLOOP,1)+(((NTIMEDIA(2,KLOOP,1)- &
+ NTIMEDIA(1,KLOOP,1))/NTIMEDIA(3,KLOOP,1))*NTIMEDIA(3,KLOOP,1))
+ IX=NJSUP-NJINF+1
+ ALLOCATE(ZTEM2D(IX,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IJLT=0
+ ENDIF
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(IJLT)=XTRAJT(NLOOPT,1)
+ ZTEM2D(:,IJLT)=XVAR(NIINF,NJINF-NJL+1:NJSUP-NJL+1,1, &
+ NLOOPT,1,NLOOPP)
+ IF(JLOOPT == ITIMEND)THEN
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+ DEALLOCATE(ZTEM2D,ZWORKT)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+
+ ELSE
+
+ ZWORK1D=XXY(NJINF:NJSUP,NMGRID)
+ ZWORKY=XVAR(NIINF,NJINF-NJL+1:NJSUP-NJL+1,1,JLOOPT,1,NLOOPP)
+ ZTIMED=XTRAJT(JLOOPT,1)
+ ZTIMEF=XTRAJT(JLOOPT,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(JLOOPT == 1)THEN
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ CALL RESOLV_TIMES(JLOOPT)
+ ENDIF
+ CALL TRAXY(ZWORK1D,ZWORKY,KLOOP,YTITX,YTITY,ZTIMED,ZTIMEF)
+! IF(KLOOP == NSUPERDIA)CALL FRAME
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+
+ DEALLOCATE(ZWORK1D,ZWORKY)
+
+ NIINF=IINF;NISUP=ISUP;NJINF=IJINF;NJSUP=IJSUP
+
+ ELSE IF((II /= 1 .AND. IIE /= IIB) .AND. (IJ /= 1 .AND. IJB /= IJE) .AND. IK == 1)THEN
+
+! Cas compression bilan sur axe Z ou 2D hor. --> Plan horizontal
+! ****************************************************************
+! (Impression dim mat. modele et matrice(NIL:NIH,NJL:NJH,
+! NKL:NKH) et matrice(NIL:NIH,NJL:NJH,1)
+
+ LCHXY=.TRUE.
+ CALL RESOLV_NIJINF_NIJSUP
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! CH Allocation matrice 2D de reception des valeurs
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ALLOCATE (ZTEM2D(1:NISUP-NIINF+1,1:NJSUP-NJINF+1))
+
+! Ajout PH Oct 2000 + 1pt FT ou PVKT_k_1
+ IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. &
+!! Nov 2001
+ LDIRWM .OR. LDIRWT .OR. LDIRWIND .OR. &
+!! Nov 2001
+ (LCH .AND. LCV) .OR. LFT .OR. LPVKT)THEN
+ ALLOCATE (ZWORK3D(1:NISUP-NIINF+1,1:NJSUP-NJINF+1,1))
+ IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. &
+!! Nov 2001
+ LDIRWM .OR. LDIRWT .OR. LDIRWIND )THEN
+!! Nov 2001
+ NMGRID=1
+ ENDIF
+ ENDIF
+
+ DO JLOOPP=1,NBPROCDIA(KLOOP) !--- LCHXY-------------
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+
+ CALL LOADUNITIT(JLOOPP,KLOOP)
+ YTEXTE(1:LEN(YTEXTE)) = ' '
+ ILENT=LEN_TRIM(CTITGAL)
+ ILENU=LEN_TRIM(CUNITGAL)
+ YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+ YTEXTE(ILENT+1:ILENT+1)=' '
+ YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
+ if(nverbia >0)then
+ print *,' OPER TIT=',CTITGAL(1:ILENT),' UNIT=',CUNITGAL(1:ILENU),&
+ ' TEXTE=',TRIM(YTEXTE)
+ endif
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+
+ IF(LANIMT .AND. NISUP-NIINF /= 0 .AND. NJSUP-NJINF /= 0)THEN
+ IF(JLOOPT == 1)THEN
+ CALL FMFREE(YBID,YBID,IRESP)
+ if(nverbia >0)then
+ print *,' OPER FMFREE YBID IRESP ',YBID,IRESP
+ endif
+
+ CALL FMATTR(YBID,YBID,IBID,IRESP)
+ CALL GOPWK(9,IBID,3)
+! CALL GOPWK(9,20,3)
+ ISEGM=ISEGM+1
+ ISEGD=ISEGM
+ CALL GFLAS1(ISEGM)
+ ELSE
+ ISEGM=ISEGM+1
+ CALL GFLAS1(ISEGM)
+ ENDIF
+ ENDIF
+ IF((.NOT.LFT .AND. .NOT.LPVKT) .OR. (LFT .OR. LPVKT .OR. JLOOPT == 1))THEN
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ ENDIF
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+! Ajout PH Oct 2000
+!! Nov 2001
+ IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. LDIRWM &
+ .OR. LDIRWT .OR. LDIRWIND )THEN
+!! Nov 2001
+! IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT )THEN
+ ZWORK3D(:,:,1)=XU(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ 1,NTIMEDIA(JLOOPT,KLOOP,1),1, &
+ NPROCDIA(JLOOPP,KLOOP))
+ ELSE IF((LCH .AND. LCV) .OR. LFT .OR. LPVKT)THEN
+ ZWORK3D(:,:,1)=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ 1,NTIMEDIA(JLOOPT,KLOOP,1),1, &
+ NPROCDIA(JLOOPP,KLOOP))
+ ELSE
+ ZTEM2D(:,:)=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ 1,NTIMEDIA(JLOOPT,KLOOP,1),1, &
+ NPROCDIA(JLOOPP,KLOOP))
+ ENDIF
+ IF(NSUPERDIA > 1)THEN
+ IF(LMINUS .OR. LPLUS)THEN
+ IF(NBPM > 1)THEN
+ DO JU=1,NBPM
+ IF(NUMPM(JU) == 3)THEN
+ LSUPER=.TRUE.
+ EXIT
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ ENDDO
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ ELSE
+ LSUPER=.TRUE.
+ ENDIF
+ IF(KLOOP == 1)NSUPER=0
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ CTYPHOR='K'
+
+ IF(NISUP-NIINF == 0 .OR. NJSUP-NJINF == 0)THEN
+
+ IF(LPXT .OR. LPYT)THEN
+ IF(JLOOPT == 1)THEN
+ ILENW=NBTIMEDIA(KLOOP,1)
+ IF(LPXT)THEN
+ IX=NISUP-NIINF+1
+ ELSE IF(LPYT)THEN
+ IX=NJSUP-NJINF+1
+ ENDIF
+ ALLOCATE(ZPROVI2(IX,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZPROVI2=XSPVAL
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(JLOOPT)=XTRAJT(NLOOPT,1)
+ IF(LPXT)THEN
+ ZPROVI2(:,JLOOPT)=ZTEM2D(:,1)
+ ELSE IF(LPYT)THEN
+ ZPROVI2(:,JLOOPT)=ZTEM2D(1,:)
+ ENDIF
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ CALL PVFCT(ZWORKT,ZPROVI2,KLOOP)
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+ DEALLOCATE(ZPROVI2,ZWORKT)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+
+ ELSE
+ ALLOCATE(ZPROVI(SIZE(ZTEM2D,1),SIZE(ZTEM2D,2),1))
+ ZPROVI(:,:,1)=ZTEM2D(:,:)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRACEH_FORDIACHRO(1,ZPROVI,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(ZPROVI)
+ ENDIF
+
+ ELSE
+
+! Ajout PH Oct 2000
+ IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. &
+!! Nov 2001
+ LDIRWM .OR. LDIRWT .OR. LDIRWIND .OR. &
+!! Nov 2001
+ (LCH .AND. LCV) .OR. LFT .OR. LPVKT)THEN
+
+ IF(LFT .OR. LPVKT)THEN
+ ILENW=NBTIMEDIA(KLOOP,1)
+
+ IF(JLOOPT == 1)THEN
+ ALLOCATE(ZWORKT(ILENW))
+ ALLOCATE(ZWORK1D(ILENW))
+ CALL VERIFLEN_FORDIACHRO
+ CALL MEMCV
+ IF(ALLOCATED(ZTEMCV))THEN
+ DEALLOCATE(ZTEMCV)
+ ENDIF
+ ALLOCATE(ZTEMCV(NLMAX,1))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+
+ CALL PRECOU_FORDIACHRO(ZWORK3D,ZTEMCV)
+ ZWORK1D(JLOOPT)=ZTEMCV(NPROFILE,1)
+ ZWORKT(JLOOPT)=XTRAJT(NLOOPT,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ IF(LFT)THEN
+ CALL VARFCT(ZWORKT,ZWORK1D,1)
+ ELSEIF(LPVKT)THEN
+ ALLOCATE(ZPROVI2(1,SIZE(ZWORKT,1)))
+ ZPROVI2(1,:)=ZWORK1D
+ CALL PVFCT(ZWORKT,ZPROVI2,KLOOP)
+ DEALLOCATE(ZPROVI2)
+ ENDIF
+ DEALLOCATE(ZWORKT,ZWORK1D)
+ IF(ALLOCATED(ZTEMCV))THEN
+ DEALLOCATE(ZTEMCV)
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+
+ ELSE
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRACEH_FORDIACHRO(1,ZWORK3D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+
+ ELSE
+
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL IMAGE_FORDIACHRO(ZTEM2D,1,XDIAINT,NHI,NDOT,YTEXTE(1:&
+ LEN_TRIM(YTEXTE)))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ if(nverbia > 0)then
+ print *,' **oper AP IMAGE1 II,IJ,IK,KLOOP ',II,IJ,IK,KLOOP
+ endif
+ ENDIF
+ ENDIF
+ IF(LANIMT .AND. NISUP-NIINF /= 0 .AND. NJSUP-NJINF /= 0)THEN
+ CALL GFLAS2
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ DO JJ=ISEGD,ISEGM
+ CALL GFLAS3(JJ)
+ ENDDO
+ CALL GCLWK(9)
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ELSE IF(LPXT.OR.LPYT .OR. LFT .OR. LPVKT)THEN
+ ELSE
+! IF(KLOOP == NSUPERDIA)CALL FRAME
+ IF(KLOOP == NSUPERDIA)THEN
+
+ ! Trace du domaine fils eventuellement
+ IF(LDOMAIN .AND. .NOT.LCV)THEN
+ ZZZXD=XXX(NDOMAINL,NMGRID)
+ ZZZXF=XXX(NDOMAINR,NMGRID)
+ ZZZYD=XXY(NDOMAINB,NMGRID)
+ ZZZYF=XXY(NDOMAINT,NMGRID)
+ CALL GSLWSC(XLWDOMAIN)
+ CALL FRSTPT(ZZZXD,ZZZYD)
+ CALL VECTOR(ZZZXF,ZZZYD)
+ CALL VECTOR(ZZZXF,ZZZYF)
+ CALL VECTOR(ZZZXD,ZZZYF)
+ CALL VECTOR(ZZZXD,ZZZYD)
+ ENDIF
+ ! Trace de segments eventuellement
+ IF(LSEGM .AND. .NOT.LCV)THEN
+ CALL GQPLCI(IER,ICOLI)
+ DO J=1,NCOLSEGM
+ !IF(.NOT.LCOLAREA .AND. .NOT.LCOLINE .AND. NCOLSEGMS(J) > 1)THEN
+ IF(NCOLSEGMS(J) > 1)THEN
+ CALL TABCOL_FORDIACHRO
+ print *,' appel a TABCOL_FORDIACHRO pour le trace de polynes'
+ ENDIF
+ EXIT
+ ENDDO
+ CALL GSLWSC(XLWSEGM)
+ ISEGMCOL=0
+ if(nverbia > 0)then
+ print *,' **oper size((NSEGMS) ',size(NSEGMS)
+ endif
+ IGRID=NGRIDIA(NPROCDIA(JLOOPP,KLOOP))
+ DO J=1,SIZE(NSEGMS,1)
+ ! Conversion en coordonnees conformes
+ ZLAT=XSEGMS(J,1)
+ ZLON=XSEGMS(J,2)
+ IF (NSEGMS(J)==1) THEN ! XSEGMS
+ IF (XCONFSEGMS(J,1)==0. .AND. XCONFSEGMS(J,2)==0.) &
+ CALL SM_XYHAT_S(XLATORI,XLONORI, &
+ ZLAT,ZLON, &
+ XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ELSE IF (NSEGMS(J)==-1) THEN ! ISEGMS
+ NSEGMS(J)=1
+ II=MAX(MIN(INT(ZLAT),NIMAX+2*JPHEXT-1),1)
+ IJ=MAX(MIN(INT(ZLON),NJMAX+2*JPHEXT-1),1)
+ XCONFSEGMS(J,1)=XXX(II,IGRID) + &
+ (ZLAT-FLOAT(II))*(XXX(II+1,IGRID) - XXX(II,IGRID) )
+ XCONFSEGMS(J,2)=XXY(IJ,IGRID) + &
+ (ZLON-FLOAT(IJ))*(XXY(IJ+1,IGRID) - XXY(IJ,IGRID) )
+ END IF
+ IF(J == 1 .AND. NSEGMS(J) == 1) THEN
+ ISEGMCOL=ISEGMCOL+1
+ ICOLSEGM=NCOLSEGMS(ISEGMCOL)
+ IF((LCOLAREA .OR. LCOLINE) .AND. ICOLSEGM > 1)THEN
+ print *,' Avec LCOLAREA=T ou LCOLINE=T , attention a la superposition des couleurs'
+ !print *,' valeur trouvee: ',NCOLSEGMS,'FORCEE a 1 '
+ print *,' pour les segments preferez NCOLSEGMS= 0 ou 1 '
+ !ICOLSEGM=1
+ ENDIF
+ CALL GSPLCI(ICOLSEGM)
+ CALL GSTXCI(ICOLSEGM)
+ CALL FRSTPT(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+!!!!!
+ ELSE IF(J > 1 .AND. NSEGMS(J) == 1 )THEN
+ IF( NSEGMS(J-1) == 0)THEN
+ ISEGMCOL=ISEGMCOL+1
+ ICOLSEGM=NCOLSEGMS(ISEGMCOL)
+ IF(J > 1)CALL SFLUSH
+ IF((LCOLAREA .OR. LCOLINE) .AND. ICOLSEGM > 1)THEN
+ print *,' Avec LCOLAREA=T ou LCOLINE=T , attention a la superposition des couleurs'
+ !print *,' valeur trouvee: ',NCOLSEGMS,'FORCEE a 1 '
+ print *,' pour les segments preferez NCOLSEGMS= 0 ou 1 '
+ !ICOLSEGM=1
+ ENDIF
+ CALL GSPLCI(ICOLSEGM)
+ CALL GSTXCI(ICOLSEGM)
+ CALL FRSTPT(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ELSEIF(NSEGMS(J-1)== 1)THEN
+ CALL VECTOR(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ENDIF
+!!!!!
+ ENDIF
+ ENDDO
+ CALL SFLUSH
+ CALL GSPLCI(ICOLI)
+ CALL GSTXCI(1)
+ ENDIF
+ ! Trace de la CV dans CH suivante(s) eventuellement
+ IF(LTRACECV .AND. .NOT.LCV)THEN
+ CALL GQLWSC(IER,ZLW)
+ CALL GSLWSC(XLWTRACECV)
+ CALL GSMKSC(2.)
+ if(nverbia > 0)then
+ print *,' **oper size((NSEGMS) for tracecv',size(NSEGMS)
+ endif
+ DO J=1,SIZE(NSEGMS,1)
+ ICOLSEGM=1
+ IF(J == 1 .AND. NSEGMS(J) == 2) THEN
+ CALL GSPLCI(ICOLSEGM)
+ CALL GSTXCI(ICOLSEGM)
+ CALL GSMK(4)
+ CALL GPM(1,XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ CALL FRSTPT(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ELSE IF(J > 1 .AND. NSEGMS(J) == 2 )THEN
+ IF( NSEGMS(J-1) == 0)THEN
+ CALL SFLUSH
+ CALL GSPLCI(ICOLSEGM)
+ CALL GSTXCI(ICOLSEGM)
+ CALL GSMK(4)
+ CALL GPM(1,XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ CALL FRSTPT(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ELSEIF(NSEGMS(J-1)== 2)THEN
+ CALL GSMK(5)
+ CALL GPM(1,XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ CALL VECTOR(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ENDIF
+ ENDIF
+ ENDDO
+ CALL SFLUSH
+ CALL GSLWSC(ZLW)
+ CALL GSTXCI(1)
+ ENDIF
+ !
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+ ENDDO
+ ELSE
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1), &
+ NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+ IF(LANIMT .AND. NJSUP-NJINF /= 0 .AND. NISUP-NIINF /=0)THEN
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ CALL FMFREE(YBID,YBID,IRESP)
+ if(nverbia >0)then
+ print *,' OPER FMFREE YBID IRESP ',YBID,IRESP
+ endif
+ CALL FMATTR(YBID,YBID,IBID,IRESP)
+ CALL GOPWK(9,IBID,3)
+ ISEGM=ISEGM+1
+ ISEGD=ISEGM
+ CALL GFLAS1(ISEGM)
+ ITIMEND=NTIMEDIA(1,KLOOP,1) + &
+ (((NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1))*NTIMEDIA(3,KLOOP,1))
+ ELSE
+ ISEGM=ISEGM+1
+ CALL GFLAS1(ISEGM)
+ ENDIF
+ ENDIF
+ IF((.NOT.LFT .AND. .NOT.LPVKT) .OR. (LFT .OR. LPVKT .OR. JLOOPT == NTIMEDIA(1,KLOOP,1)))THEN
+ CALL RESOLV_TIMES(JLOOPT)
+ ENDIF
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(JLOOPT,1)
+
+! Ajout PH Oct 2000
+!! Nov 2001
+! IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT)THEN
+ IF(LDIRWM .OR. LDIRWT .OR. LDIRWIND .OR. &
+ LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT)THEN
+!! Nov 2001
+ ZWORK3D(:,:,1)=XU(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ 1,JLOOPT,1,NPROCDIA(JLOOPP,KLOOP))
+ ELSEIF((LCH .AND. LCV) .OR. LFT .OR.LPVKT)THEN
+ ZWORK3D(:,:,1)=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ 1,JLOOPT,1,NPROCDIA(JLOOPP,KLOOP))
+
+ ELSE
+ ZTEM2D(:,:)=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ 1,JLOOPT,1,NPROCDIA(JLOOPP,KLOOP))
+ ENDIF
+ IF(NSUPERDIA > 1)THEN
+! LSUPER=.TRUE.
+ IF(LMINUS .OR. LPLUS)THEN
+ IF(NBPM > 1)THEN
+ DO JU=1,NBPM
+ IF(NUMPM(JU) == 3)THEN
+ LSUPER=.TRUE.
+ EXIT
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ ENDDO
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ ELSE
+ LSUPER=.TRUE.
+ ENDIF
+ IF(KLOOP == 1)NSUPER=0
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ CTYPHOR='K'
+ IF(NISUP-NIINF == 0 .OR. NJSUP-NJINF == 0)THEN
+ IF(LPXT .OR. LPYT)THEN
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))&
+ /NTIMEDIA(3,KLOOP,1)+1
+ IF(NVERBIA > 0)THEN
+ print *,'oper verif ilenw ',ILENW
+ ENDIF
+ ITIMEND=NTIMEDIA(1,KLOOP,1)+(((NTIMEDIA(2,KLOOP,1)- &
+ NTIMEDIA(1,KLOOP,1))/NTIMEDIA(3,KLOOP,1))* &
+ NTIMEDIA(3,KLOOP,1))
+ IF(LPXT)THEN
+ IX=NISUP-NIINF+1
+ ELSE IF(LPYT)THEN
+ IX=NJSUP-NJINF+1
+ ENDIF
+ ALLOCATE(ZPROVI2(IX,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZPROVI2=XSPVAL
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IJLT=0
+ ENDIF
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(IJLT)=XTRAJT(NLOOPT,1)
+ IF(LPXT)THEN
+ ZPROVI2(:,IJLT)=ZTEM2D(:,1)
+ ELSE IF(LPYT)THEN
+ ZPROVI2(:,IJLT)=ZTEM2D(1,:)
+ ENDIF
+ IF(JLOOPT == ITIMEND)THEN
+ CALL PVFCT(ZWORKT,ZPROVI2,KLOOP)
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+ DEALLOCATE(ZPROVI2,ZWORKT)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+ ELSE
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ALLOCATE(ZPROVI(SIZE(ZTEM2D,1),SIZE(ZTEM2D,2),1))
+ ZPROVI(:,:,1)=ZTEM2D(:,:)
+ CALL TRACEH_FORDIACHRO(1,ZPROVI,KLOOP)
+ DEALLOCATE(ZPROVI)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+ ELSE
+! Ajout PH Oct 2000 + Nov FT ou PVKT
+ IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. &
+!! Nov 2001
+ LDIRWM .OR. LDIRWT .OR. LDIRWIND .OR. &
+!! Nov 2001
+ (LCH .AND. LCV ) .OR. LFT .OR. LPVKT)THEN
+
+ IF(LFT .OR. LPVKT)THEN
+ ILENW=(NTIMEDIA(2,KLOOP,1)- &
+ NTIMEDIA(1,KLOOP,1))/NTIMEDIA(3,KLOOP,1)+1
+
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ ALLOCATE(ZWORKT(ILENW))
+ ALLOCATE(ZWORK1D(ILENW))
+ CALL VERIFLEN_FORDIACHRO
+ CALL MEMCV
+ IF(ALLOCATED(ZTEMCV))THEN
+ DEALLOCATE(ZTEMCV)
+ ENDIF
+ ALLOCATE(ZTEMCV(NLMAX,1))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ILT=0
+ ENDIF
+
+ CALL PRECOU_FORDIACHRO(ZWORK3D,ZTEMCV)
+ ILT=ILT+1
+ ZWORK1D(ILT)=ZTEMCV(NPROFILE,1)
+ ZWORKT(ILT)=XTRAJT(NLOOPT,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(ILT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(JLOOPT == NTIMEDIA(2,KLOOP,1))THEN
+ IF(LFT)THEN
+ CALL VARFCT(ZWORKT,ZWORK1D,1)
+ ELSEIF(LPVKT)THEN
+ ALLOCATE(ZPROVI2(1,SIZE(ZWORKT,1)))
+ ZPROVI2(1,:)=ZWORK1D
+ CALL PVFCT(ZWORKT,ZPROVI2,KLOOP)
+ DEALLOCATE(ZPROVI2)
+ ENDIF
+ DEALLOCATE(ZWORKT,ZWORK1D)
+ IF(ALLOCATED(ZTEMCV))THEN
+ DEALLOCATE(ZTEMCV)
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+
+ ELSE
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRACEH_FORDIACHRO(1,ZWORK3D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+
+ ELSE
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ if(nverbia >0)THEN
+ print *,' ** oper appel image Ytexte ',YTEXTE(1:LEN_TRIM(YTEXTE))
+ endif
+ CALL IMAGE_FORDIACHRO(ZTEM2D,1,XDIAINT,NHI,NDOT,YTEXTE(1: &
+ LEN_TRIM(YTEXTE)))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ if(nverbia > 0)then
+ print *,' **oper AP IMAGE2 II,IJ,IK,KLOOP ',II,IJ,IK,KLOOP
+ endif
+ ENDIF
+ ENDIF
+ IF(LANIMT .AND. NISUP-NIINF /= 0 .AND. NJSUP-NJINF /= 0)THEN
+ CALL GFLAS2
+ IF(JLOOPT == ITIMEND)THEN
+ DO JJ=ISEGD,ISEGM
+ CALL GFLAS3(JJ)
+ ENDDO
+ CALL GCLWK(9)
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ELSE IF(LPXT.OR.LPYT .OR. LFT .OR. LPVKT)THEN
+ ELSE
+! IF(KLOOP == NSUPERDIA)CALL FRAME
+ IF(KLOOP == NSUPERDIA)THEN
+ ! Trace du domaine fils eventuellement
+ IF(LDOMAIN .AND. .NOT.LCV)THEN
+ ZZZXD=XXX(NDOMAINL,NMGRID)
+ ZZZXF=XXX(NDOMAINR,NMGRID)
+ ZZZYD=XXY(NDOMAINB,NMGRID)
+ ZZZYF=XXY(NDOMAINT,NMGRID)
+ CALL GSLWSC(XLWDOMAIN)
+ CALL FRSTPT(ZZZXD,ZZZYD)
+ CALL VECTOR(ZZZXF,ZZZYD)
+ CALL VECTOR(ZZZXF,ZZZYF)
+ CALL VECTOR(ZZZXD,ZZZYF)
+ CALL VECTOR(ZZZXD,ZZZYD)
+ ENDIF
+ ! Trace de segments eventuellement
+ IF(LSEGM .AND. .NOT.LCV)THEN
+ CALL GQPLCI(IER,ICOLI)
+ ICOLSEGM=NCOLSEGMS(1)
+ DO J=1,NCOLSEGM
+ !IF(.NOT.LCOLAREA .AND. .NOT.LCOLINE .AND. NCOLSEGMS(J) > 1)THEN
+ IF(NCOLSEGMS(J) > 1)THEN
+ CALL TABCOL_FORDIACHRO
+ print *,' appel a TABCOL_FORDIACHRO pour le trace de polynes'
+ ENDIF
+ EXIT
+ ENDDO
+ CALL GSLWSC(XLWSEGM)
+ ISEGMCOL=0
+ if(nverbia > 0)then
+ print *,' **oper size2(NSEGMS) ',size(NSEGMS)
+ endif
+ IGRID=NGRIDIA(NPROCDIA(JLOOPP,KLOOP))
+ DO J=1,SIZE(NSEGMS,1)
+ ! Conversion en coordonnees conformes
+ ZLAT=XSEGMS(J,1)
+ ZLON=XSEGMS(J,2)
+ IF (NSEGMS(J)==1) THEN ! XSEGMS
+ IF (XCONFSEGMS(J,1)==0. .AND. XCONFSEGMS(J,2)==0.) &
+ CALL SM_XYHAT_S(XLATORI,XLONORI, &
+ ZLAT,ZLON, &
+ XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ELSE IF (NSEGMS(J)==-1) THEN ! ISEGMS
+ NSEGMS(J)=1
+ II=MAX(MIN(INT(ZLAT),NIMAX+2*JPHEXT-1),1)
+ IJ=MAX(MIN(INT(ZLON),NJMAX+2*JPHEXT-1),1)
+ XCONFSEGMS(J,1)=XXX(II,IGRID) + &
+ (ZLAT-FLOAT(II))*(XXX(II+1,IGRID) - XXX(II,IGRID) )
+ XCONFSEGMS(J,2)=XXY(IJ,IGRID) + &
+ (ZLON-FLOAT(IJ))*(XXY(IJ+1,IGRID) - XXY(IJ,IGRID) )
+ END IF
+ IF(J == 1 .AND. NSEGMS(J) == 1)THEN
+ ISEGMCOL=ISEGMCOL+1
+ ICOLSEGM=NCOLSEGMS(ISEGMCOL)
+ IF((LCOLAREA .OR. LCOLINE) .AND. ICOLSEGM > 1)THEN
+ print *,' Avec LCOLAREA=T ou LCOLINE=T , attention a la superposition des couleurs'
+ !print *,' valeur trouvee: ',NCOLSEGMS,'FORCEE a 1 '
+ print *,' pour les segments preferez NCOLSEGMS= 0 ou 1 '
+ !ICOLSEGM=1
+ ENDIF
+ CALL GSPLCI(ICOLSEGM)
+ CALL GSTXCI(ICOLSEGM)
+ CALL FRSTPT(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ELSE IF(J > 1 .AND. NSEGMS(J) == 1 )THEN
+ IF(NSEGMS(J-1) == 0)THEN
+ ISEGMCOL=ISEGMCOL+1
+ ICOLSEGM=NCOLSEGMS(ISEGMCOL)
+ IF(J > 1)CALL SFLUSH
+ IF((LCOLAREA .OR. LCOLINE) .AND. ICOLSEGM > 1)THEN
+ print *,' Avec LCOLAREA=T ou LCOLINE=T , attention a la superposition des couleurs'
+ !print *,' valeur trouvee: ',NCOLSEGMS,'FORCEE a 1 '
+ print *,' pour les segments preferez NCOLSEGMS= 0 ou 1 '
+ !ICOLSEGM=1
+ ENDIF
+ CALL GSPLCI(ICOLSEGM)
+ CALL GSTXCI(ICOLSEGM)
+ CALL FRSTPT(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+
+ ELSEIF(NSEGMS(J-1)== 1)THEN
+ CALL VECTOR(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ENDIF
+ ENDIF
+ ENDDO
+ CALL SFLUSH
+ CALL GSPLCI(ICOLI)
+ CALL GSTXCI(1)
+ ENDIF
+ ! Trace de la CV dans CH suivante(s) eventuellement
+ IF(LTRACECV .AND. .NOT.LCV)THEN
+ CALL GQLWSC(IER,ZLW)
+ CALL GSLWSC(XLWTRACECV)
+ CALL GSMKSC(2.)
+ if(nverbia > 0)then
+ print *,' **oper size((NSEGMS) for tracecv2',size(NSEGMS)
+ endif
+ DO J=1,SIZE(NSEGMS,1)
+ ICOLSEGM=1
+ IF(J == 1 .AND. NSEGMS(J) == 2) THEN
+ CALL GSPLCI(ICOLSEGM)
+ CALL GSTXCI(ICOLSEGM)
+ CALL GSMK(4)
+ CALL GPM(1,XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ CALL FRSTPT(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ELSE IF(J > 1 .AND. NSEGMS(J) == 2 )THEN
+ IF( NSEGMS(J-1) == 0)THEN
+ CALL SFLUSH
+ CALL GSPLCI(ICOLSEGM)
+ CALL GSTXCI(ICOLSEGM)
+ CALL GSMK(4)
+ CALL GPM(1,XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ CALL FRSTPT(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ELSEIF(NSEGMS(J-1)== 2)THEN
+ CALL GSMK(5)
+ CALL GPM(1,XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ CALL VECTOR(XCONFSEGMS(J,1),XCONFSEGMS(J,2))
+ ENDIF
+ ENDIF
+ ENDDO
+ CALL SFLUSH
+ CALL GSLWSC(ZLW)
+ CALL GSTXCI(1)
+ ENDIF
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO !--- LCHXY-------------
+ DEALLOCATE(ZTEM2D)
+ IF(ALLOCATED(ZWORK3D))THEN
+ DEALLOCATE(ZWORK3D)
+ ENDIF
+
+ ELSE IF(II /= 1 .AND. (IJ == 1 .OR. IJE-IJB == 0) .AND. IK == 1)THEN
+
+! Cas compression bilan sur axes Y et Z --> Profil horizontal // X
+! *****************************************************************
+! (Impression dim mat. modele et matrice(NIL:NIH,NJL:NJH,
+! NKL:NKH) et matrice(NIL:NIH,1,1)
+
+ print *,' Profil horizontal // X'
+ IINF=NIINF;ISUP=NISUP;IJINF=NJINF;IJSUP=NJSUP
+ print *,'IINF,ISUP,IJINF,IJSUP ',IINF,ISUP,IJINF,IJSUP
+ IF(IJ == 1)THEN
+ GIJ1=.TRUE.
+ ELSE
+ GIJ1=.FALSE.
+ LCH=.FALSE.
+ ENDIF
+
+ IF(GIJ1)THEN
+ IF(.NOT.L2DBX)THEN
+ NJINF=1; NJSUP=1
+ NIINF=MAX(IIB,NIL); NISUP=MIN(IIE,NIH)
+ print *,' Limites I par defaut (L2DBX=.FALSE.) :',&
+& ' MAX(IIB,NIL) - MIN(IIE,NIH) ',NIINF,' - ',NISUP
+ print *,' Si vous voulez selectionner les limites en I, mettez :',&
+& ' L2DBX=.TRUE.'
+ print *,' et definissez : NIDEBCOU= NLMAX= '
+ ELSE
+ NJINF=1;NJSUP=1
+ NIINF=NIDEBCOU; NISUP=NIDEBCOU+NLMAX-1
+ NIINF=MAX(NIINF,NIL);NISUP=MIN(NISUP,NIH)
+ ENDIF
+ ELSE
+ IF(.NOT.L2DBX)THEN
+ NJINF=IJB; NJSUP=IJE
+ NIINF=MAX(IIB,NIL); NISUP=MIN(IIE,NIH)
+ print *,' Limites I par defaut (L2DBX=.FALSE.) :',&
+& ' MAX(IIB,NIL) - MIN(IIE,NIH) ',NIINF,' - ',NISUP
+ print *,' Si vous voulez selectionner les limites en I, mettez :',&
+& ' L2DBX=.TRUE.'
+ print *,' et definissez : NIDEBCOU= NLMAX= '
+ ELSE
+ NJINF=IJB; NJSUP=IJE
+ NIINF=NIDEBCOU; NISUP=NIDEBCOU+NLMAX-1
+ NIINF=MAX(NIINF,NIL);NISUP=MIN(NISUP,NIH)
+ ENDIF
+ ENDIF
+ ILENW=NISUP-NIINF+1
+
+ ALLOCATE(ZWORK1D(ILENW),ZWORKY(ILENW))
+
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+
+ YTITX(1:LEN(YTITX))=' '
+ YTITY(1:LEN(YTITY))=' '
+
+ CALL LOADUNITIT(JLOOPP,KLOOP)
+
+ YTITX='X(M)'
+ YTITY=CUNITGAL(1:LEN_TRIM(CUNITGAL))
+
+ ZWORK1D(:)=0.; ZWORKY(:)=0.
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+
+ IF(LPXT)THEN
+ IF(JLOOPT == 1)THEN
+ ILENW=NBTIMEDIA(KLOOP,1)
+ IX=NISUP-NIINF+1
+ ALLOCATE(ZTEM2D(IX,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+ ZWORKT(JLOOPT)=XTRAJT(NLOOPT,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ ZTEM2D(:,JLOOPT)=XVAR(NIINF-NIL+1:NISUP-NIL+1,NJINF,1, &
+ NLOOPT,1,NLOOPP)
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+ DEALLOCATE(ZTEM2D,ZWORKT)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+
+ ELSE
+
+ ZWORK1D=XXX(NIINF:NISUP,NMGRID)
+ ZWORKY=XVAR(NIINF-NIL+1:NISUP-NIL+1,NJINF,1,NTIMEDIA(JLOOPT,KLOOP,1),1,NLOOPP)
+ ZTIMED=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ZTIMEF=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(JLOOPT == 1)THEN
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ ENDIF
+ CALL TRAXY(ZWORK1D,ZWORKY,KLOOP,YTITX,YTITY,ZTIMED,ZTIMEF)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+ ENDDO
+
+ ELSE
+
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+ IF(LPXT)THEN
+
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1)+1
+ IF(NVERBIA > 0)THEN
+ print *,'oper verif ilenw ',ILENW
+ ENDIF
+ ITIMEND=NTIMEDIA(1,KLOOP,1)+(((NTIMEDIA(2,KLOOP,1)- &
+ NTIMEDIA(1,KLOOP,1))/NTIMEDIA(3,KLOOP,1))*NTIMEDIA(3,KLOOP,1))
+ IX=NISUP-NIINF+1
+ ALLOCATE(ZTEM2D(IX,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IJLT=0
+ ENDIF
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(IJLT)=XTRAJT(NLOOPT,1)
+ ZTEM2D(:,IJLT)=XVAR(NIINF-NIL+1:NISUP-NIL+1,NJINF,1, &
+ NLOOPT,1,NLOOPP)
+ IF(JLOOPT == ITIMEND)THEN
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(ZTEM2D,ZWORKT)
+ ENDIF
+
+ ELSE
+
+ ZWORK1D=XXX(NIINF:NISUP,NMGRID)
+ ZWORKY=XVAR(NIINF-NIL+1:NISUP-NIL+1,NJINF,1,JLOOPT,1,NLOOPP)
+ ZTIMED=XTRAJT(JLOOPT,1)
+ ZTIMEF=XTRAJT(JLOOPT,1)
+ IF(JLOOPT == 1)THEN
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ CALL RESOLV_TIMES(JLOOPT)
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRAXY(ZWORK1D,ZWORKY,KLOOP,YTITX,YTITY,ZTIMED,ZTIMEF)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+ ENDIF
+ ENDDO
+
+ DEALLOCATE(ZWORK1D,ZWORKY)
+
+ NIINF=IINF;NISUP=ISUP;NJINF=IJINF;NJSUP=IJSUP
+
+ ELSE IF(II /= 1 .AND. IJ == 1 .AND. IK /= 1 .AND. LJCP)THEN
+
+! Cas compression bilan sur axe Y --> Plan vertical // X
+! *******************************************************
+! (Impression dim mat. modele et matrice(NIL:NIH,NJL:NJH,
+! NKL:NKH) et matrice(NIL:NIH,1,NKL:NKH)
+ IDEFCV=0 !%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(LDEFCV2CC)THEN
+ LDEFCV2CC=.FALSE.
+ IDEFCV=1
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%
+ LCVXZ=.TRUE.
+ IF(.NOT.L2DBX)THEN
+ IINF=MAX(IIB,NIL)
+ ISUP=MIN(IIE,NIH)
+ print *,' 2D Vertical // X '
+ print *,' Limites I par defaut (L2DBX=.FALSE.)(par / au domaine integral de simulation,points de garde compris) :',&
+& ' MAX(IIB,NIL) - MIN(IIE,NIH) ',IINF,' - ',ISUP
+ print *,' Si vous voulez selectionner les limites en I, mettez : ',&
+& 'L2DBX=.TRUE.'
+ print *,' et definissez : NIDEBCOU= NLMAX= '
+ ELSE
+ IINF=NIDEBCOU
+ ISUP=NIDEBCOU+NLMAX-1
+ ISUP=MIN(ISUP,NIH)
+ ENDIF
+ ALLOCATE(ZTEM2D(1:ISUP-IINF+1,1:IKU))
+ NINX=ISUP-IINF+1
+ NINY=IKU
+ NLMAX=NINX
+ NLANGLE=0
+ NIDEBCOU=IINF
+ IJDEBCOU=-999
+ IF(NJDEBCOU /= NJL)THEN
+ IJDEBCOU=NJDEBCOU
+ NJDEBCOU=NJL
+ print *,' NJDEBCOU force a la valeur de NJL ',NJL,' pour ', &
+& 'obtention altitudes correctes '
+ print *,' AP utilisation, sera remis a la valeur precedente : ', &
+ IJDEBCOU
+ ENDIF
+ LVERT=.TRUE.
+ LHOR=.FALSE.
+ LPT=LPXT
+ IF(NSUPERDIA > 1)THEN
+! LSUPER=.TRUE.
+ IF(LMINUS .OR. LPLUS)THEN
+ IF(NBPM > 1)THEN
+ DO JU=1,NBPM
+ IF(NUMPM(JU) == 3)THEN
+ LSUPER=.TRUE.
+ EXIT
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ ENDDO
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ ELSE
+ LSUPER=.TRUE.
+ ENDIF
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ IF(KLOOP == 1)NSUPER=0
+ DO JLOOPP=1,NBPROCDIA(KLOOP) !--- LCVXZ-------------
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+
+ CALL LOADUNITIT(JLOOPP,KLOOP)
+
+ ILENT=LEN_TRIM(CTITGAL)
+ ILENU=LEN_TRIM(CUNITGAL)
+ YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+ YTEXTE(ILENT+1:ILENT+1)=' '
+ YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 0))THEN
+! print *,' OPER LJCP .AND. SIZE(XZS,2) ',LJCP,SIZE(XZS,2)
+ IF(.NOT.LJCP .AND. SIZE(XZS,2) == 3)THEN
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+ IF(ALLOCATED(XWORKZ))THEN
+ DEALLOCATE(XWORKZ)
+ ENDIF
+ IF(ALLOCATED(XDS))THEN
+ DEALLOCATE(XDS)
+ ENDIF
+ IF(ALLOCATED(XWZ))THEN
+ DEALLOCATE(XWZ)
+ ENDIF
+ ALLOCATE(XWORKZ(NLMAX,IKU,7))
+ ALLOCATE(XWZ(NLMAX,7))
+ ALLOCATE(XDS(NLMAX+100,7))
+ XDS(1:NLMAX,NMGRID)=XXX(IINF:ISUP,NMGRID)
+ XWORKZ(1:NLMAX,1:IKU,NMGRID)=XZZ(IINF:ISUP,NJDEBCOU,1:IKU)
+ XWZ(1:NLMAX,NMGRID)=XXZS(IINF:ISUP,2,NMGRID)
+ ENDIF
+ IF(.NOT.LJCP .AND. SIZE(XZS,2) == 3)THEN
+ DO J=1,NLMAX
+ XZWORKZ(J,1:IKU)=XWORKZ(J,1:IKU,NMGRID)
+ ENDDO
+ ELSE
+ DO J=1,NINX
+ XZWORKZ(J,1:IKU)=XXZ(:,NMGRID)
+ ENDDO
+ ENDIF
+ XZZDS(1:NINX)=XXX(IINF:ISUP,NMGRID)
+ ZWL=XZZDS(1); ZWR=XZZDS(NINX)
+ IF((XHMIN == 0. .AND. XHMAX == 0.) .OR. (XHMAX<=XHMIN))THEN
+ XHMIN=0.
+ XHMAX=XZWORKZ(1,IKE)
+ ENDIF
+! print *,' OPER XHMIN XHMAX ',XHMIN,XHMAX
+ ZWB=XHMIN; ZWT=XHMAX
+ CALL SET(.1,.9,.1,.9,ZWL,ZWR,ZWB,ZWT,1)
+ CALL GSCLIP(1)
+ CALL CPSETI('SET',0)
+ CALL CPSETI('MAP',4)
+ ENDIF
+ ZTEM2D=XSPVAL
+ ZTEM2D(1:ISUP-IINF+1,NKL:NKH)=XVAR( &
+ IINF-NIL+1:ISUP-NIL+1,1,:,NTIMEDIA(JLOOPT,KLOOP,1),&
+ 1,NPROCDIA(JLOOPP,KLOOP))
+ IF(NKL < IKB)THEN
+ ZTEM2D(:,1:IKB-1)=XSPVAL
+ ENDIF
+ IF(NKH > IKE)THEN
+ ZTEM2D(:,IKE+1:IKU)=XSPVAL
+ ENDIF
+ if(nverbia >0)THEN
+ print *,' ** oper appel imcou Ytexte ',YTEXTE(1:LEN_TRIM(YTEXTE))
+ endif
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(KLOOP == 1)NSUPER=0
+ CALL IMCOU_FORDIACHRO(ZTEM2D,XDIAINT,CLEGEND,YTEXTE(1: &
+ LEN_TRIM(YTEXTE)))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+! IF(KLOOP == NSUPERDIA)CALL FRAME
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDDO
+ ELSE
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1), &
+ NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+ CALL RESOLV_TIMES(JLOOPT)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(JLOOPT,1)
+ IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 0))THEN
+ IF(.NOT.LJCP .AND. SIZE(XZS,2) == 3)THEN
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+ IF(ALLOCATED(XWORKZ))THEN
+ DEALLOCATE(XWORKZ)
+ ENDIF
+ IF(ALLOCATED(XDS))THEN
+ DEALLOCATE(XDS)
+ ENDIF
+ IF(ALLOCATED(XWZ))THEN
+ DEALLOCATE(XWZ)
+ ENDIF
+ ALLOCATE(XWORKZ(NLMAX,IKU,7))
+ ALLOCATE(XWZ(NLMAX,7))
+ ALLOCATE(XDS(NLMAX+100,7))
+ XDS(1:NLMAX,NMGRID)=XXX(IINF:ISUP,NMGRID)
+ XWORKZ(1:NLMAX,1:IKU,NMGRID)=XZZ(IINF:ISUP,NJDEBCOU,1:IKU)
+ XWZ(1:NLMAX,NMGRID)=XXZS(IINF:ISUP,2,NMGRID)
+ ENDIF
+ IF(.NOT.LJCP .AND. SIZE(XZS,2) == 3)THEN
+ XZWORKZ(1:NLMAX,1:IKU)=XWORKZ(1:NLMAX,1:IKU,NMGRID)
+ ELSE
+ DO J=1,NINX
+ XZWORKZ(J,1:IKU)=XXZ(:,NMGRID)
+ ENDDO
+ ENDIF
+ XZZDS(1:NINX)=XXX(IINF:ISUP,NMGRID)
+ ZWL=XZZDS(1); ZWR=XZZDS(NINX)
+ IF((XHMIN == 0. .AND. XHMAX == 0.) .OR. (XHMAX<=XHMIN))THEN
+ XHMIN=0.
+ XHMAX=XZWORKZ(1,IKE)
+ ENDIF
+! print *,' OPER 2 XHMIN XHMAX ',XHMIN,XHMAX
+ ZWB=XHMIN; ZWT=XHMAX
+ CALL SET(.1,.9,.1,.9,ZWL,ZWR,ZWB,ZWT,1)
+ CALL GSCLIP(1)
+ CALL CPSETI('SET',0)
+ CALL CPSETI('MAP',4)
+ ENDIF
+ ZTEM2D=XSPVAL
+ ZTEM2D(1:ISUP-IINF+1,NKL:NKH)=XVAR( &
+ IINF-NIL+1:ISUP-NIL+1,1,:,JLOOPT,1,NPROCDIA( &
+ JLOOPP,KLOOP))
+ IF(NKL < IKB)THEN
+ ZTEM2D(:,1:IKB-1)=XSPVAL
+ ENDIF
+ IF(NKH > IKE)THEN
+ ZTEM2D(:,IKE+1:IKU)=XSPVAL
+ ENDIF
+ if(nverbia >0)THEN
+ print *,' ** oper appel imcou Ytexte ',YTEXTE(1:LEN_TRIM(YTEXTE))
+ endif
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(KLOOP == 1)NSUPER=0
+ CALL IMCOU_FORDIACHRO(ZTEM2D,XDIAINT,CLEGEND,YTEXTE(1: &
+ LEN_TRIM(YTEXTE)))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+! IF(KLOOP == NSUPERDIA)CALL FRAME
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO !--- LCVXZ-------------
+ DEALLOCATE(ZTEM2D)
+
+ IF(IJDEBCOU /= -999)THEN
+ NJDEBCOU=IJDEBCOU
+ ENDIF
+
+ IF(IDEFCV==1)THEN !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ LDEFCV2CC=.TRUE.
+ IDEFCV=0
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+ ELSE
+
+! PAS DE COMPRESSION
+! ******************
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! CH Positionnement NIINF, NJINF, NISUP, NJSUP
+! Defaut : NIINF=MAX(IIB,NIL), NJINF=MAX(IJB,NJL), NISUP=MIN(IIE,NIH),
+! NJSUP=MIN(IJE,NJH)
+! Sinon valeurs fournies par l'utilisateur dans les limites (NIL,NJL NIH,
+! NJH)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! CV Positionnement NIINF, NJINF, NISUP, NJSUP
+! CV Positionnement LHORIZ et LVERTI
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ IF(LCV)THEN
+ IINF=NIINF;ISUP=NISUP;IJINF=NJINF;IJSUP=NJSUP
+ IF(IINF == 0)THEN
+ GCH=LCH
+ LCH=.TRUE.
+ LCV=.FALSE.
+ CALL RESOLV_NIJINF_NIJSUP
+ LCH=GCH
+ LCV=.TRUE.
+ IINF=NIINF;ISUP=NISUP;IJINF=NJINF;IJSUP=NJSUP
+ ENDIF
+ if(NVERBIA > 0)THEN
+ print *,' oper CV IINF,ISUP,IJINF,IJSUP ',IINF,ISUP,IJINF,IJSUP
+ endif
+ ! fichier 1D (points de garde dupliques dans conv2dia)
+ !pour eviter de definir la localisation du profil
+ IF (NIMAX==1 .AND. NJMAX==1) THEN
+ IF(NIDEBCOU==0 .OR. NIDEBCOU==999999999) NIDEBCOU=1+JPHEXT
+ IF(NJDEBCOU==0 .OR. NJDEBCOU==999999999) NJDEBCOU=1+JPHEXT
+ IF(NLMAX==0 .OR. NLMAX==999999999) NLMAX=2
+ IF(NLANGLE==0 .OR. NLANGLE==999999999) NLANGLE=0
+ IF(NPROFILE==0 .OR. NPROFILE==999999999) NPROFILE=1
+ LPOINTG=.TRUE.
+ ENDIF
+ if(NVERBIA > 0)THEN
+ print *,' oper CV NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,PROFILE '&
+ ,NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ endif
+ ENDIF
+ CALL RESOLV_NIJINF_NIJSUP
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! CH + CV Allocation matrice 3D de reception des valeurs
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ALLOCATE (ZWORK3D(1:NISUP-NIINF+1,1:NJSUP-NJINF+1, &
+ 1:NKH-NKL+1))
+
+ if(nverbia >0)then
+ print *,' NBPROCDIA(KLOOP) ',NBPROCDIA(KLOOP)
+ endif
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle externe sur les processus
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+
+ IF((LPVKT .OR. LPVKT1) .AND. NSUPERDIA>1)THEN
+ IF(NBPROCDIA(KLOOP)>1 .OR. NBLVLKDIA(KLOOP,1)>1)THEN
+ print *,' _PVKT_ (_PVKT1_) SUPERPOSITIONS : '
+!fuji print *,' On ne peut definir de part de d''autre '&
+!fuji &'de _ON_ qu''1 seul processus et 1 seul niveau'
+ print *,' On ne peut definir de part de d''autre '
+ print *,'de _ON_ qu''1 seul processus et 1 seul niveau'
+ print *,' Nb de niveaux demandes : ',NBLVLKDIA(KLOOP,1)
+ print *,' Nb de processus demandes : ',NBPROCDIA(KLOOP)
+ print *,' *** MODIFIEZ VOTRE DIRECTIVE *** '
+ EXIT
+ ENDIF
+ ENDIF
+
+ IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. &
+ LULMWM .OR. LULTWT .OR. LSUMVM .OR. LSUTVT .OR. &
+ LDIRWM .OR. LDIRWT .OR. &
+ LMLSUMVM .OR. LMLSUTVT)THEN
+ NMGRID=1
+ ELSE IF(LULM .OR. LULT)THEN
+! Avril 99 a la demande de Joel, Nicole et les autres
+ NMGRID=1
+! NMGRID=2
+ ELSE IF(LVTM .OR. LVTT)THEN
+! Avril 99 a la demande de Joel, Nicole et les autres
+ NMGRID=1
+! NMGRID=3
+ ELSE
+ NMGRID=NGRIDIA(NPROCDIA(JLOOPP,KLOOP))
+ IF(NGRIDIAM /= 0 .AND. (NGRIDIAM /= NMGRID))THEN
+ print *,' ****oper NMGRID Av modif ',NMGRID
+ NMGRID=NGRIDIAM
+ print *,' ****oper NMGRID mis volontairement a la valeur de NGRIDIAM ',NGRIDIAM
+ ENDIF
+ ENDIF
+ IF(NMGRID <1 .OR. NMGRID >7)THEN
+ PRINT *,' VALEUR NMGRID ABERRANTE: ',NMGRID, &
+ ' FORCEE A : 1'
+ NMGRID=1
+ ENDIF
+ IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. &
+ LULMWM .OR. LULTWT .OR. LULM .OR. LULT .OR. &
+ LVTM .OR. LVTT .OR. LSUMVM .OR. LSUTVT .OR. &
+ LDIRWM .OR. LDIRWT .OR. &
+ LMLSUMVM .OR. LMLSUTVT)THEN
+ CTITGAL=ADJUSTL(CGROUP)
+ CUNITGAL(1:LEN(CUNITGAL))=' '
+ ELSE
+ CTITGAL=ADJUSTL(CTITRE(NPROCDIA(JLOOPP,KLOOP)))
+ CUNITGAL=ADJUSTL(CUNITE(NPROCDIA(JLOOPP,KLOOP)))
+ ENDIF
+ if(nverbia >0)then
+ print *,' ++OPER++ CTITGAL,CUNITGAL ',CTITGAL,CUNITGAL
+ endif
+ CTITGAL=ADJUSTL(CTITGAL)
+ CUNITGAL=ADJUSTL(ADJUSTR(CUNITGAL))
+ IF(INDEX(CUNITGAL,' ') /= 0)THEN
+ CUNITGAL(INDEX(CUNITGAL,' '):LEN(CUNITGAL))=' '
+ ELSE
+ IF(LEN(CUNITGAL) > 8)Then
+ print *,' **oper DES caracteres bizarres ds le champ UNITE ',&
+ &' tronque a 8 caractères '
+ CUNITGAL(9:LEN(CUNITGAL))=' '
+ ELSE
+ ENDIF
+ ENDIF
+ if(nverbia >0)then
+ print *,' ++OPER++ CTITGAL,CUNITGAL ',CTITGAL,CUNITGAL
+ endif
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle sur les numeros de masques ou trajectoires
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+! print *,' NBNDIA(KLOOP) ',NBNDIA(KLOOP)
+
+ DO JLOOPN=1,NBNDIA(KLOOP)
+ if(nverbia >0)then
+ print *,' **oper JLOOPN ',JLOOPN
+ endif
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle sur les temps (Formulation sequentielle)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+
+! print *,' NBTIMEDIA(KLOOP,1) ',NBTIMEDIA(KLOOP,1)
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+ if(nverbia >0)then
+ print *,' **oper**A JLOOPT ',JLOOPT
+ endif
+
+ IF(LANIMT)THEN
+ IF(LPVT .OR. LPVKT .OR. LPVKT1)THEN
+ print *,' ANIMATION IMPOSSIBLE avec _PVT_ ou _PVKT_ ou _PVKT1_'
+ print *,' LANIMT remis a .FALSE. '
+ LANIMT=.FALSE.
+ ELSE IF(LPV .AND. NSUPERDIA>1)THEN
+ print *,' ANIMATION IMPOSSIBLE ', &
+ &'avec _PV_ et superpositions'
+ print *,' LANIMT remis a .FALSE. '
+ print *,' mais POSSIBLE sous la forme : ',&
+& 'GPE_PV__P_1 ou GPE_PV__P_1_T_300_TO_3600 '
+ print *,' PENSER a fournir les bornes dans ',&
+& 'XPVMIN_proc= et XPVMAX_proc= et a les activer ',&
+& 'avec LMNMXUSER=T '
+ print *,' Rappel : proc=nom du processus tel ',&
+& 'qu''il est enregistre '
+ LANIMT=.FALSE.
+ ELSE
+ IF(JLOOPT == 1)THEN
+ CALL FMFREE(YBID,YBID,IRESP)
+ print *,' OPER FMFREE YBID IRESP ',YBID,IRESP
+ CALL FMATTR(YBID,YBID,IBID,IRESP)
+ CALL GOPWK(9,IBID,3)
+ ISEGM=ISEGM+1
+ ISEGD=ISEGM
+ CALL GFLAS1(ISEGM)
+ ELSE
+ ISEGM=ISEGM+1
+ CALL GFLAS1(ISEGM)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+
+ if(nverbia > 0)then
+ print *,' **oper LULM LCH LMUMVM,LDIRWM,LDIRWIND lig 2406 ',LULM,LCH,LMUMVM,LDIRWM,LDIRWIND
+ endif
+ IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. &
+ LULMWM .OR. LULTWT .OR. LULM .OR. LULT .OR. &
+ LVTM .OR. LVTT .OR. LSUMVM .OR. LSUTVT .OR. &
+ LDIRWM .OR. LDIRWT .OR. &
+ LMLSUMVM .OR. LMLSUTVT)THEN
+ ZWORK3D=XU(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,NTIMEDIA(JLOOPT,KLOOP,1),JLOOPN, &
+ NPROCDIA(JLOOPP,KLOOP))
+!!!!! Avril 99 Ajout ULM et VTM en CH
+ IF((LCH.AND.LULM).OR.(LCH.AND.LVTM).OR. &
+ (LCH.AND.LULT).OR.(LCH.AND.LVTT))THEN
+ ALLOCATE(ZWORK3V(SIZE(ZWORK3D,1), &
+ SIZE(ZWORK3D,2),SIZE(ZWORK3D,3)))
+ ALLOCATE(ZTEM1(IIU,IJU),ZTEMV(IIU,IJU))
+ ZTEM1=0.
+ ZTEMV=0.
+ ZWORK3V=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,NTIMEDIA(JLOOPT,KLOOP,1),JLOOPN, &
+ NPROCDIA(JLOOPP,KLOOP))
+ DO JKLOOP=1,IKU
+ IF(JKLOOP < MAX(IKB,NKL) .OR. &
+ JKLOOP > MIN(IKE,NKH))THEN
+ ELSE
+ ZTEM1(NIINF:NISUP,NJINF:NJSUP)= &
+ ZWORK3D(:,:,JKLOOP-NKL+1)
+ ZTEMV(NIINF:NISUP,NJINF:NJSUP)= &
+ ZWORK3V(:,:,JKLOOP-NKL+1)
+!!!!essai Nov 2001 pour prise en compte PH 29/11/2001 .. A suivre
+ CALL VERIFLEN_FORDIACHRO
+!!!!essai Nov 2001
+ CALL ROTA(ZTEM1,ZTEMV)
+ ZWORK3D(:,:,JKLOOP-NKL+1)=ZTEM1(NIINF:NISUP,NJINF:NJSUP)
+ ZWORK3V(:,:,JKLOOP-NKL+1)=ZTEMV(NIINF:NISUP,NJINF:NJSUP)
+ ENDIF
+ ENDDO
+ IF(LVTM .OR. LVTT)THEN
+ ZWORK3D=ZWORK3V
+ ENDIF
+ DEALLOCATE(ZWORK3V,ZTEM1,ZTEMV)
+ ENDIF
+!!!!! Avril 99 Ajout ULM et VTM en CH
+ ELSE
+ ZWORK3D=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,NTIMEDIA(JLOOPT,KLOOP,1),JLOOPN, &
+ NPROCDIA(JLOOPP,KLOOP))
+ ENDIF
+!print *,' OPER NIINF-NIL+1:NISUP-NIL+1 ',NIINF-NIL+1,NISUP-NIL+1
+!print *,' OPER NJINF-NJL+1:NJSUP-NJL+1 ',NJINF-NJL+1,NJSUP-NJL+1
+!print *,' OPER XVAR ',XVAR(NIINF-NIL+1,NJINF-NJL+1,1,JLOOPT,JLOOPN,JLOOPP)
+!print *,' OPER XVAR ',XVAR(NISUP-NIL+1,NJSUP-NJL+1,SIZE(ZWORK3D,3),JLOOPT,JLOOPN,JLOOPP)
+! WRITE(CLEGEND2(8:15),'(F8.0)')XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+!!!!!!!!!!!!!!!!!!!!!!!!! CH !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ IF(LCH)THEN
+ if(nverbia >0)then
+ print *,' **oper** AP LCH ',LCH
+ endif
+
+ IF(NBLVLKDIA(KLOOP,1) == 0)THEN
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle sur les altitudes Z (Formulation sequentielle)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ IF(.NOT.LZINCRDIA(KLOOP))THEN
+ DO JLOOPZ=1,NBLVLZDIA(KLOOP)
+
+ IZ=XLVLZDIA(JLOOPZ,KLOOP)
+! Pour LANIMK
+ XLOOPZ=XLVLZDIA(JLOOPZ,KLOOP)
+ if(nverbia > 0)then
+ print *,' ***oper XLOOPZ ',XLOOPZ
+ endif
+! XLOOPZ=IZ
+ IF(LANIMK)THEN
+ IF(JLOOPZ == 1)THEN
+ CALL FMFREE(YBID,YBID,IRESP)
+ if(nverbia >0)then
+ print *,' OPER FMFREE YBID IRESP ',YBID,IRESP
+ endif
+ CALL FMATTR(YBID,YBID,IBID,IRESP)
+ CALL GOPWK(9,IBID,3)
+ ISEGM=ISEGM+1
+ ISEGD=ISEGM
+ CALL GFLAS1(ISEGM)
+ ELSE
+ ISEGM=ISEGM+1
+ CALL GFLAS1(ISEGM)
+ ENDIF
+ ENDIF
+! Pour LANIMK
+ IF(LPXT .OR. LPYT)THEN
+ IF(JLOOPT == 1)THEN
+ IF(ALLOCATED(ZSTAB))THEN
+ DEALLOCATE(ZSTAB)
+ ENDIF
+ IX=NISUP-NIINF+1
+ IY=NJSUP-NJINF+1
+ ILENW=NBTIMEDIA(KLOOP,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(IX /= 1 .AND. IY /= 1)THEN
+ IF(LPXT)THEN
+ print *,' _PXT_ --> Profil horizontal // X f(t) demande'
+ print *,' Definissez correctement NIINF,NISUP,NJINF,NJSUP. Valeurs actuelles :'
+ print *,' NIINF=',NIINF,' NISUP=',NISUP,' NJINF=',NJINF,' NJSUP=',NJSUP
+ ELSE IF(LPYT)THEN
+ print *,' _PYT_ --> Profil horizontal // Y f(t) demande'
+ print *,' Definissez correctement NIINF,NISUP,NJINF,NJSUP. Valeurs actuelles :'
+ print *,' NIINF=',NIINF,' NISUP=',NISUP,' NJINF=',NJINF,' NJSUP=',NJSUP
+
+ ENDIF
+
+ LPBREAD=.TRUE.
+ RETURN
+ ELSE IF(IY == 1 .AND. IX /= 1)THEN
+ ALLOCATE(ZTEM2D(IX,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ ELSE IF(IX == 1 .AND. IY /= 1)THEN
+ ALLOCATE(ZTEM2D(IY,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ ENDIF
+ ALLOCATE(ZSTAB(IX,IY))
+ ENDIF
+ CALL INTERP_FORDIACHRO(IZ,NKL,NKH,ZWORK3D,ZSTAB)
+ ZWORKT(JLOOPT)=XTRAJT(NLOOPT,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(LPXT)THEN
+ ZTEM2D(:,JLOOPT)=ZSTAB(:,1)
+ ELSE IF(LPYT)THEN
+ ZTEM2D(:,JLOOPT)=ZSTAB(1,:)
+ ENDIF
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ ILENU=LEN_TRIM(CUNITGAL)
+ ILENT=LEN(CUNITGAL)
+ IF(ILENT-ILENU-2+1 < 8)THEN
+ IF(NVERBIA > 0)THEN
+ print *,' CUNITGAL ILENT-ILENU-2+1 < 8 ',CUNITGAL
+ ENDIF
+ ELSE
+ IF(LEV)THEN
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A2,''='',I5)')'PV',IZ
+ ELSE IF(LSV3)THEN
+ IF(LXYZ00)THEN
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')CGROUPSV3(1:3),IZ
+! WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')'Z00',IZ
+ ELSE
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')'SV3',IZ
+ ENDIF
+ ELSE
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A1,''='',I5)')CTYPHOR,IZ
+ ENDIF
+ ENDIF
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ DEALLOCATE(ZWORKT,ZTEM2D,ZSTAB)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRACEH_FORDIACHRO(IZ,ZWORK3D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ if(nverbia > 0)then
+ print *,' **oper AP TRACEH1 IZ II,IJ,IK,KLOOP ',IZ,II,IJ,IK,KLOOP
+ endif
+ ENDIF
+ IF(LCV .AND. JLOOPZ == NBLVLZDIA(KLOOP))THEN
+ IINFCV=NIINF; IISUPCV=NISUP; IJINFCV=NJINF; IJSUPCV=NJSUP
+ NIINF=IINF;NISUP=ISUP;NJINF=IJINF;NJSUP=IJSUP
+ IF(NVERBIA > 0)THEN
+ print *,'oper 1 NIINF,NISUP,NJINF,NJSUP ',NIINF,NISUP,NJINF,NJSUP
+ ENDIF
+ ENDIF
+
+ CALL CLOSF(JLOOPT,NBTIMEDIA(KLOOP,1), &
+ ISEGD,ISEGM,KLOOP)
+ IF(LCV .AND. JLOOPZ == NBLVLZDIA(KLOOP))THEN
+ NIINF=IINFCV; NISUP=IISUPCV; NJINF=IJINFCV; NJSUP=IJSUPCV
+ ENDIF
+
+ ENDDO
+
+ ELSE
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle sur les altitudes Z (Formulation incrementale)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!Mars 2000
+ XLOOPZ=XLVLZDIA(1,KLOOP)-XLVLZDIA(3,KLOOP)
+!Mars 2000
+
+ DO JLOOPZ=INT(XLVLZDIA(1,KLOOP)),INT(XLVLZDIA(2,KLOOP)), &
+ INT(XLVLZDIA(3,KLOOP))
+ IZ=JLOOPZ
+! Pour LANIMK
+!Mars 2000
+ XLOOPZ=XLOOPZ+XLVLZDIA(3,KLOOP)
+ if(nverbia > 0)then
+ print *,' ***oper XLOOPZ ',XLOOPZ
+ endif
+! XLOOPZ=IZ
+!Mars 2000
+ IF(LANIMK)THEN
+ IF(JLOOPZ == INT(XLVLZDIA(1,KLOOP)))THEN
+ CALL FMFREE(YBID,YBID,IRESP)
+ print *,' OPER FMFREE YBID IRESP ',YBID,IRESP
+ CALL FMATTR(YBID,YBID,IBID,IRESP)
+ CALL GOPWK(9,IBID,3)
+ ISEGM=ISEGM+1
+ ISEGD=ISEGM
+ CALL GFLAS1(ISEGM)
+ ELSE
+ ISEGM=ISEGM+1
+ CALL GFLAS1(ISEGM)
+ ENDIF
+ ENDIF
+! Pour LANIMK
+ IF(LPXT .OR. LPYT)THEN
+ IF(JLOOPT == 1)THEN
+ IF(ALLOCATED(ZSTAB))THEN
+ DEALLOCATE(ZSTAB)
+ ENDIF
+ IX=NISUP-NIINF+1
+ IY=NJSUP-NJINF+1
+ ILENW=NBTIMEDIA(KLOOP,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(IX /= 1 .AND. IY /= 1)THEN
+ IF(LPXT)THEN
+ print *,' _PXT_ --> Profil horizontal // X f(t) demande'
+ print *,' Definissez correctement NIINF,NISUP,NJINF,NJSUP. Valeurs actuelles :'
+ print *,' NIINF=',NIINF,' NISUP=',NISUP,' NJINF=',NJINF,' NJSUP=',NJSUP
+ ELSE IF(LPYT)THEN
+ print *,' _PYT_ --> Profil horizontal // Y f(t) demande'
+ print *,' Definissez correctement NIINF,NISUP,NJINF,NJSUP. Valeurs actuelles :'
+ print *,' NIINF=',NIINF,' NISUP=',NISUP,' NJINF=',NJINF,' NJSUP=',NJSUP
+
+ ENDIF
+
+ LPBREAD=.TRUE.
+ RETURN
+ ELSE IF(IY == 1 .AND. IX /= 1)THEN
+ ALLOCATE(ZTEM2D(IX,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ ELSE IF(IX == 1 .AND. IY /= 1)THEN
+ ALLOCATE(ZTEM2D(IY,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ ENDIF
+ ALLOCATE(ZSTAB(IX,IY))
+ ENDIF
+ CALL INTERP_FORDIACHRO(IZ,NKL,NKH,ZWORK3D,ZSTAB)
+ ZWORKT(JLOOPT)=XTRAJT(NLOOPT,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(LPXT)THEN
+ ZTEM2D(:,JLOOPT)=ZSTAB(:,1)
+ ELSE IF(LPYT)THEN
+ ZTEM2D(:,JLOOPT)=ZSTAB(1,:)
+ ENDIF
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ ILENU=LEN_TRIM(CUNITGAL)
+ ILENT=LEN(CUNITGAL)
+ IF(ILENT-ILENU-2+1 < 8)THEN
+ IF(NVERBIA > 0)THEN
+ print *,' CUNITGAL ILENT-ILENU-2+1 < 8 ',CUNITGAL
+ ENDIF
+ ELSE
+ IF(LEV)THEN
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A2,''='',I5)')'PV',IZ
+ ELSE IF(LSV3)THEN
+ IF(LXYZ00)THEN
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')CGROUPSV3(1:3),IZ
+! WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')'Z00',IZ
+ ELSE
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')'SV3',IZ
+ ENDIF
+ ELSE
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A1,''='',I5)')CTYPHOR,IZ
+ ENDIF
+ ENDIF
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ DEALLOCATE(ZWORKT,ZTEM2D,ZSTAB)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRACEH_FORDIACHRO(IZ,ZWORK3D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ if(nverbia > 0)then
+ print *,' **oper AP TRACEH2 IZ II,IJ,IK,KLOOP ',IZ,II,IJ,IK,KLOOP
+ endif
+ ENDIF
+ IF(LCV .AND. JLOOPZ == NINT(XLVLZDIA(2,KLOOP)))THEN
+ IINFCV=NIINF; IISUPCV=NISUP; IJINFCV=NJINF; IJSUPCV=NJSUP
+ NIINF=IINF;NISUP=ISUP;NJINF=IJINF;NJSUP=IJSUP
+ IF(NVERBIA > 0)THEN
+ print *,'oper 2 NIINF,NISUP,NJINF,NJSUP ',NIINF,NISUP,NJINF,NJSUP
+ print *,' oper 2 JLOOPZ NINT(XLVLZDIA(2,KLOOP)) ',JLOOPZ,NINT(XLVLZDIA(2,KLOOP))
+ ENDIF
+ ENDIF
+
+ CALL CLOSF(JLOOPT,NBTIMEDIA(KLOOP,1), &
+ ISEGD,ISEGM,KLOOP)
+ IF(LCV .AND. JLOOPZ == NINT(XLVLZDIA(2,KLOOP)))THEN
+ NIINF=IINFCV; NISUP=IISUPCV; NJINF=IJINFCV; NJSUP=IJSUPCV
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
+ ELSE
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle sur les niveaux de modele (Formulation sequentielle)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO JLOOPK=1,NBLVLKDIA(KLOOP,1)
+! Pour LANIMK
+ NLOOPK=JLOOPK
+ IF(LANIMK)THEN
+ IF(JLOOPK == 1)THEN
+ CALL FMFREE(YBID,YBID,IRESP)
+ if(nverbia >0)then
+ print *,' OPER FMFREE YBID IRESP ',YBID,IRESP
+ endif
+ CALL FMATTR(YBID,YBID,IBID,IRESP)
+ CALL GOPWK(9,IBID,3)
+ ISEGM=ISEGM+1
+ ISEGD=ISEGM
+ CALL GFLAS1(ISEGM)
+ ELSE
+ ISEGM=ISEGM+1
+ CALL GFLAS1(ISEGM)
+ ENDIF
+ ENDIF
+! Pour LANIMK
+ IZ=NLVLKDIA(JLOOPK,KLOOP,1)
+ if(nverbia > 0)then
+ print *,' **oper Niveau K transmis a INTERP ',IZ
+ print *,' **oper LPR,LTK,LEV,LSV3 ',LPR,LTK,LEV,LSV3
+ endif
+ IF(LPXT .OR. LPYT)THEN
+ IF(JLOOPT == 1)THEN
+ IF(ALLOCATED(ZSTAB))THEN
+ DEALLOCATE(ZSTAB)
+ ENDIF
+ IX=NISUP-NIINF+1
+ IY=NJSUP-NJINF+1
+ ILENW=NBTIMEDIA(KLOOP,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(IX /= 1 .AND. IY /= 1)THEN
+ IF(LPXT)THEN
+ print *,' _PXT_ --> Profil horizontal // X f(t) demande'
+ print *,' Definissez correctement NIINF,NISUP,NJINF,NJSUP. Valeurs actuelles :'
+ print *,' NIINF=',NIINF,' NISUP=',NISUP,' NJINF=',NJINF,' NJSUP=',NJSUP
+ ELSE IF(LPYT)THEN
+ print *,' _PYT_ --> Profil horizontal // Y f(t) demande'
+ print *,' Definissez correctement NIINF,NISUP,NJINF,NJSUP. Valeurs actuelles :'
+ print *,' NIINF=',NIINF,' NISUP=',NISUP,' NJINF=',NJINF,' NJSUP=',NJSUP
+
+ ENDIF
+
+ LPBREAD=.TRUE.
+ RETURN
+ ELSE IF(IY == 1 .AND. IX /= 1)THEN
+ ALLOCATE(ZTEM2D(IX,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ ELSE IF(IX == 1 .AND. IY /= 1)THEN
+ ALLOCATE(ZTEM2D(IY,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ ENDIF
+ ALLOCATE(ZSTAB(IX,IY))
+ ENDIF
+ CALL INTERP_FORDIACHRO(IZ,NKL,NKH,ZWORK3D,ZSTAB)
+ ZWORKT(JLOOPT)=XTRAJT(NLOOPT,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(LPXT)THEN
+ ZTEM2D(:,JLOOPT)=ZSTAB(:,1)
+ ELSE IF(LPYT)THEN
+ ZTEM2D(:,JLOOPT)=ZSTAB(1,:)
+ ENDIF
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ ILENU=LEN_TRIM(CUNITGAL)
+ ILENT=LEN(CUNITGAL)
+ IF(ILENT-ILENU-2+1 < 8)THEN
+ IF(NVERBIA > 0)THEN
+ print *,' CUNITGAL ILENT-ILENU-2+1 < 8 ',CUNITGAL
+ ENDIF
+ ELSE
+ IF(LEV)THEN
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A2,''='',I5)')'PV',IZ
+ ELSE IF(LSV3)THEN
+ IF(LXYZ00)THEN
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')CGROUPSV3(1:3),IZ
+! WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')'Z00',IZ
+ ELSE
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')'SV3',IZ
+ ENDIF
+ ELSE
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A1,''='',I5)')CTYPHOR,IZ
+ ENDIF
+ ENDIF
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ DEALLOCATE(ZWORKT,ZTEM2D,ZSTAB)
+ ENDIF
+ ENDIF
+ ELSE
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRACEH_FORDIACHRO(NLVLKDIA(JLOOPK, &
+ KLOOP,1),ZWORK3D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ if(nverbia > 0)then
+ print *,' **oper AP TRACEH3 IZ II,IJ,IK,KLOOP ',NLVLKDIA(JLOOPK,KLOOP,1),II,IJ,IK,KLOOP
+ endif
+ ENDIF
+ IF(LCV .AND. JLOOPK == NBLVLKDIA(KLOOP,1))THEN
+ IINFCV=NIINF; IISUPCV=NISUP; IJINFCV=NJINF; IJSUPCV=NJSUP
+ NIINF=IINF;NISUP=ISUP;NJINF=IJINF;NJSUP=IJSUP
+ IF(NVERBIA > 0)THEN
+ print *,' oper 3 NIINF,NISUP,NJINF,NJSUP ',NIINF,NISUP,NJINF,NJSUP
+ ENDIF
+ ENDIF
+
+
+ CALL CLOSF(JLOOPT,NBTIMEDIA(KLOOP,1), &
+ ISEGD,ISEGM,KLOOP)
+ IF(LCV .AND. JLOOPK == NBLVLKDIA(KLOOP,1))THEN
+ NIINF=IINFCV; NISUP=IISUPCV; NJINF=IJINFCV; NJSUP=IJSUPCV
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+! CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!! CV !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ELSE IF(LCV)THEN
+
+ IF(.NOT.LDEFCV2CC)THEN !%%%%%%%%%%%%%%%%%%%%%%%%
+
+ IF(NLMAX <= 1 .OR. (NLANGLE<0 .OR. NLANGLE>360) .OR. &
+ (NIDEBCOU <=0 .AND. XIDEBCOU == -999.) .OR. &
+ (NJDEBCOU <=0 .AND. XJDEBCOU == -999.))THEN
+ PRINT *,' DEFINISSEZ D''ABORD NIDEBCOU, NJDEBCOU,',&
+& ' NLMAX, NLANGLE (Pour CV + PV), PROFILE (Pour PV)'
+ PRINT *,' ou XIDEBCOU, XJDEBCOU'
+ PRINT *,' PUIS RENTREZ A NOUVEAU VOTRE DIRECTIVE '
+ print *,' ( Pour le 1D, mettre Obligatoirement ',&
+& 'NLMAX=2 et LPOINTG=T )'
+ PRINT *,' VALEURS ACTUELLES: '
+ PRINT '('' NIDEBCOU:'',I5,'' NJDEBCOU:'',I5,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5,'' PROFILE: '',I5)',NIDEBCOU, &
+& NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ IF(II == 1 .AND. .NOT.LICP .AND. IJ>1 .AND. IK>1)THEN
+ PRINT *,'DANS LE CAS CONSIDERE (CV // Y), si vous voulez ',&
+ 'la totalite de la coupe, METTEZ: '
+ PRINT '('' NIDEBCOU='',I5,'' NJDEBCOU='',I5,&
+ & '' NLMAX='',I6,'' NLANGLE= 90 '')',NIL,NJL,NJH-NJL+1
+ ENDIF
+ IF(IJ == 1 .AND. .NOT.LJCP .AND. II > 1 .AND. IK >1)THEN
+ PRINT *,' DANS LE CAS CONSIDERE (CV // X), si vous voulez ',&
+ &'la totalite de la coupe, METTEZ: '
+ PRINT '('' NIDEBCOU='',I5,'' NJDEBCOU='',I5,&
+ &'' NLMAX='',I6,'' NLANGLE= 0 '')',NIL,NJl,NIH-NIL+1
+ ENDIF
+ IF(ALLOCATED(ZWORK3D))THEN
+ DEALLOCATE(ZWORK3D)
+ LPBREAD=.TRUE.
+ ENDIF
+ RETURN
+ ELSE
+ IF((.NOT.LPVT .AND. .NOT.LPVKT .AND. .NOT.LPVKT1) .OR. &
+ (LPVT .AND. JLOOPT==1) .OR. &
+ (LPVKT .AND. JLOOPT==1) .OR. &
+ (LPVKT1 .AND. JLOOPT==1))THEN !!!!
+ IF(II == 1 .AND. .NOT.LICP .AND. IJ>1 .AND. IK>1)THEN
+ PRINT *,'DANS LE CAS CONSIDERE (CV // Y), si vous voulez ',&
+ 'la totalite de la coupe, METTEZ: '
+ PRINT '('' NIDEBCOU='',I5,'' NJDEBCOU='',I5,&
+ & '' NLMAX='',I6,'' NLANGLE= 90 '')',NIL,NJL,NJH-NJL+1
+ ENDIF
+ IF(IJ == 1 .AND. .NOT.LJCP .AND. II > 1 .AND. IK >1)THEN
+ PRINT *,' DANS LE CAS CONSIDERE (CV // X), si vous voulez ',&
+ &'la totalite de la coupe, METTEZ: '
+ PRINT '('' NIDEBCOU='',I5,'' NJDEBCOU='',I5,&
+ &'' NLMAX='',I6,'' NLANGLE= 0 '')',NIL,NJl,NIH-NIL+1
+ ENDIF
+ PRINT *,' VALEURS DES PARAMETRES DE DEFINITION DE LA COUPE',&
+& ' ou DU PROFIL :'
+ IF(XIDEBCOU == -999. .AND. XJDEBCOU == -999.)THEN
+ PRINT '('' NIDEBCOU:'',I5,'' NJDEBCOU:'',I5,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5,'' PROFILE: '',I5)',NIDEBCOU, &
+& NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ print *,' ( Pour le 1D, mettre Obligatoirement ',&
+& 'NLMAX=2 et LPOINTG=T )'
+ ELSE
+ PRINT '('' XIDEBCOU:'',F7.1,'' XJDEBCOU:'',F7.1,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5,'' PROFILE: '',I5)',XIDEBCOU, &
+& XJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ENDIF !!!!
+ ENDIF
+ ENDIF
+ IF((LPV.OR.LPVT.OR.LPVKT.OR.LPVKT1) .AND. NPROFILE > NLMAX)THEN
+ PRINT *,' PROFILE DOIT ETRE <= NLMAX '
+ print *,' NLMAX:',NLMAX,' PROFILE: ',NPROFILE
+ print *,' Valeur des autres informations utiles :'
+ PRINT '('' NIDEBCOU:'',I5,'' NJDEBCOU:'',I5, &
+& '' NLANGLE:'',I5)',NIDEBCOU, &
+& NJDEBCOU,NLANGLE
+ print *,' ( Pour le 1D, mettre Obligatoirement ',&
+& 'NLMAX=2 et LPOINTG=T )'
+ IF(ALLOCATED(ZWORK3D))THEN
+ DEALLOCATE(ZWORK3D)
+ LPBREAD=.TRUE.
+ ENDIF
+ RETURN
+ ENDIF
+ IF((LPV.OR.LPVT.OR.LPVKT.OR.LPVKT1) .AND. NPROFILE <= 0)THEN
+ PRINT *,' PROFILE DOIT ETRE DEFINI.',&
+ &'Sa valeur actuelle: ',NPROFILE
+ print *,' Valeur des autres informations utiles :'
+ PRINT '('' NIDEBCOU:'',I5,'' NJDEBCOU:'',I5,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5)',NIDEBCOU, &
+& NJDEBCOU,NLMAX,NLANGLE
+ print *,' ( Pour le 1D, mettre Obligatoirement ',&
+& 'NLMAX=2 et LPOINTG=T )'
+ IF(ALLOCATED(ZWORK3D))THEN
+ DEALLOCATE(ZWORK3D)
+ LPBREAD=.TRUE.
+ ENDIF
+ RETURN
+ ENDIF
+
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+ CALL VERIFLEN_FORDIACHRO
+ CALL MEMCV
+ ALLOCATE (ZTEMCV(NLMAX,1:IKU))
+ CALL PRECOU_FORDIACHRO(ZWORK3D,ZTEMCV)
+ IF(LPV)THEN
+ L1DT=.FALSE.
+! Janvier 2001
+ IF(LUMVM.OR.LUTVT.OR.LSUMVM.OR.LSUTVT.OR.&
+ LDIRWIND)THEN
+ ILENT=LEN_TRIM(CTITGAL)
+ ILENU=LEN_TRIM(CUNITGAL)
+ YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+ YTEXTE(ILENT+1:ILENT+1)=' '
+ YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRACEV_FORDIACHRO(ZTEMCV,KLOOP,YTEXTE(1: &
+ LEN_TRIM(YTEXTE)))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ELSE
+! Janvier 2001
+ ALLOCATE(ZTEM1D(IKU),ZWORKZ(IKU))
+! Modif AOUT 97
+ ZTEM1D(:)=XSPVAL; ZWORKZ(:)=0.
+! ZTEM1D(:)=0.; ZWORKZ(:)=0.
+ ZTEM1D(MAX(IKB,NKL):MIN(IKE,NKH))= &
+ ZTEMCV(NPROFILE,MAX(IKB,NKL):MIN(IKE,NKH))
+ ZWORKZ(:)=XWORKZ(NPROFILE,:,NMGRID)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRAPRO_FORDIACHRO(ZTEM1D,ZWORKZ,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+ ELSE IF(LPVT .OR. LPVKT.OR. LPVKT1)THEN
+ L1DT=.FALSE.
+ IF(JLOOPT == 1)THEN
+ ILENW=NBTIMEDIA(KLOOP,1)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ALLOCATE(ZTEM2D(1:IKU,ILENW))
+! Janvier 2001 LUMVM + LDIRWIND + LMUMVM
+!Fev 2002
+ IF(LUMVM .OR.LUTVT .OR.LSUMVM .OR.LSUTVT )THEN
+! IF(LUMVM .OR.LUTVT .OR.LSUMVM .OR.LSUTVT &
+! .OR.LDIRWIND)THEN
+!Fev 2002
+ IF(ALLOCATED(XTEM2D))DEALLOCATE(XTEM2D)
+ IF(ALLOCATED(XTEM2D2))DEALLOCATE(XTEM2D2)
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ ALLOCATE(XTEM2D2(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ XTEM2D2=XSPVAL
+ ENDIF
+! Janvier 2001 LUMVM + LDIRWIND + LMUMVM
+ ALLOCATE(ZWORKT(ILENW))
+ ALLOCATE(ZWORKZ2(IKU))
+ ZWORKZ2(:)=0.; ZWORKT(:)=0.; ZTEM2D(:,:)=0.
+ ZTEM2D=XSPVAL
+ ZWORKZ2(:)=XWORKZ(NPROFILE,:,NMGRID)
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(JLOOPT)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),JLOOPT)= &
+ ZTEMCV(NPROFILE,MAX(IKB,NKL):MIN(IKE,NKH))
+! Janvier 2001 LUMVM + LDIRWIND + LMUMVM
+!Fev 2002
+ IF(LUMVM .OR.LUTVT .OR.LSUMVM .OR.LSUTVT )THEN
+! IF(LUMVM .OR.LUTVT .OR.LSUMVM .OR.LSUTVT &
+! .OR.LDIRWIND)THEN
+!Fev 2002
+ XTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),JLOOPT)= &
+ ZTEMCV(NPROFILE,MAX(IKB,NKL):MIN(IKE,NKH))
+ XTEM2D2(MAX(IKB,NKL):MIN(IKE,NKH),JLOOPT)= &
+ XWCV(NPROFILE,MAX(IKB,NKL):MIN(IKE,NKH))
+ ENDIF
+! Janvier 2001 LUMVM + LDIRWIND + LMUMVM
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ XPVMIN=MINVAL(ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),:))
+ XPVMAX=MAXVAL(ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),:))
+ CALL VALMNMX(XPVMIN,XPVMAX)
+ IF(ABS(XPVMAX-XPVMIN) < 1.E-4)THEN
+ XPVMIN=XPVMIN-1.
+ XPVMAX=XPVMAX+1.
+ ENDIF
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(ZTEM2D,ZWORKT,ZWORKZ2)
+ IF(ALLOCATED(XTEM2D))DEALLOCATE(XTEM2D)
+ IF(ALLOCATED(XTEM2D2))DEALLOCATE(XTEM2D2)
+ ENDIF
+ ELSE
+ ILENT=LEN_TRIM(CTITGAL)
+ ILENU=LEN_TRIM(CUNITGAL)
+ YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+ YTEXTE(ILENT+1:ILENT+1)=' '
+ YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRACEV_FORDIACHRO(ZTEMCV,KLOOP,YTEXTE(1: &
+ LEN_TRIM(YTEXTE)))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+ IF((LCV .OR. LPV) .AND. .NOT. LPVT .AND. .NOT. LPVKT .AND. .NOT.LPVKT1)THEN
+!!Fev 2002
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ NIINF=IINF;NISUP=ISUP;NJINF=IJINF;NJSUP=IJSUP
+ ENDIF
+!!Fev 2002
+ CALL CLOSF(JLOOPT,NBTIMEDIA(KLOOP,1), &
+ ISEGD,ISEGM,KLOOP)
+
+ ENDIF
+
+ DEALLOCATE(ZTEMCV)
+ DEALLOCATE(XWORKZ,XWZ)
+ IF(ALLOCATED(ZTEM1D))THEN
+ DEALLOCATE(ZTEM1D)
+ ENDIF
+ IF(ALLOCATED(ZWORKZ))THEN
+ DEALLOCATE(ZWORKZ)
+ ENDIF
+
+ ENDIF
+ ENDDO
+ IF((LPVT.AND..NOT.LPBREAD) .OR. LPVKT .OR. LPVKT1)THEN
+! IF(KLOOP == NSUPERDIA)CALL FRAME
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+
+ ELSE
+
+! print *,' NBTIMEDIA(KLOOP,1) ',NBTIMEDIA(KLOOP,1)
+! print *,' NTIMEDIA(1 et 2,KLOOP,1) ',NTIMEDIA(1,KLOOP,1), &
+! NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle sur les temps (Formulation incrementale)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1), &
+ NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+ if(nverbia >0)then
+ print *,' **oper**B JLOOPT ',JLOOPT
+ endif
+
+ IF(LANIMT)THEN
+ IF(LPVT .OR. LPVKT .OR. LPVKT1)THEN
+ print *,' ANIMATION IMPOSSIBLE avec _PVT_ ou _PVKT_ ou _PVKT1_'
+ print *,' LANIMT remis a .FALSE. '
+ LANIMT=.FALSE.
+ ELSE IF(LPV .AND. NSUPERDIA>1)THEN
+ print *,' ANIMATION IMPOSSIBLE ', &
+ &'avec _PV_ et superpositions'
+ print *,' LANIMT remis a .FALSE. '
+ print *,' mais POSSIBLE sous la forme : ',&
+& 'GPE_PV__P_1 ou GPE_PV__P_1_T_300_TO_3600 '
+ print *,' PENSER a fournir les bornes dans ',&
+& 'XPVMIN_proc= et XPVMAX_proc= et a les activer ',&
+& 'avec LMNMXUSER=T '
+ print *,' Rappel : proc=nom du processus tel ',&
+& 'qu''il est enregistre '
+ LANIMT=.FALSE.
+ ELSE
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ CALL FMFREE(YBID,YBID,IRESP)
+ print *,' OPER FMFREE YBID IRESP ',YBID,IRESP
+ CALL FMATTR(YBID,YBID,IBID,IRESP)
+ CALL GOPWK(9,IBID,3)
+ ISEGM=ISEGM+1
+ ISEGD=ISEGM
+ CALL GFLAS1(ISEGM)
+ ITIMEND=NTIMEDIA(1,KLOOP,1) + &
+ (((NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1))*NTIMEDIA(3,KLOOP,1))
+ if(nverbia > 0)then
+ print *,' ITIMEND ',ITIMEND
+ endif
+ ELSE
+ ISEGM=ISEGM+1
+ CALL GFLAS1(ISEGM)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ CALL RESOLV_TIMES(JLOOPT)
+ if(nverbia > 0)then
+ print *,' **oper LULM LCH LMUMVM LDIRWM LDIRWIND lig 3088 ',LULM,LCH,LMUMVM,LDIRWM,LDIRWIND
+ endif
+ IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. &
+ LULMWM .OR. LULTWT .OR. LULM .OR. LULT .OR. &
+ LVTM .OR. LVTT .OR. LSUMVM .OR. LSUTVT .OR. &
+ LDIRWM .OR. LDIRWT .OR. &
+ LMLSUMVM .OR. LMLSUTVT)THEN
+ if(nverbia > 0)then
+ print *,' **oper ds test LULM LCH LMUMVM LDIRWM LDIRWIND lig 3096 ',LULM,LCH,LMUMVM,LDIRWM,LDIRWIND
+ endif
+ ZWORK3D=XU(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,JLOOPT,JLOOPN, &
+ NPROCDIA(JLOOPP,KLOOP))
+!!!!! Avril 99 Ajout ULM et VTM en CH
+ IF((LCH.AND.LULM).OR.(LCH.AND.LVTM).OR. &
+ (LCH.AND.LULT).OR.(LCH.AND.LVTT))THEN
+ ALLOCATE(ZWORK3V(SIZE(ZWORK3D,1), &
+ SIZE(ZWORK3D,2),SIZE(ZWORK3D,3)))
+ ALLOCATE(ZTEM1(IIU,IJU),ZTEMV(IIU,IJU))
+ ZTEM1=0.
+ ZTEMV=0.
+ ZWORK3V=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,JLOOPT,JLOOPN, &
+ NPROCDIA(JLOOPP,KLOOP))
+ DO JKLOOP=1,IKU
+ IF(JKLOOP < MAX(IKB,NKL) .OR. &
+ JKLOOP > MIN(IKE,NKH))THEN
+ ELSE
+ ZTEM1(NIINF:NISUP,NJINF:NJSUP)= &
+ ZWORK3D(:,:,JKLOOP-NKL+1)
+ ZTEMV(NIINF:NISUP,NJINF:NJSUP)= &
+ ZWORK3V(:,:,JKLOOP-NKL+1)
+ if(nverbia > 0)then
+ print *,'** oper ZTEM1(NIINF,NJINF),&
+ &ZTEM1(NISUP,NJSUP) av rota',&
+ ZTEM1(NIINF,NJINF),ZTEM1(NISUP,NJSUP)
+ print *,'** oper JKLOOP NKL ',&
+ JKLOOP,NKL
+ endif
+!!!!essai Nov 2001 pour prise en compte PH 29/11/2001 .. A suivre
+ CALL VERIFLEN_FORDIACHRO
+!!!!essai Nov 2001
+ CALL ROTA(ZTEM1,ZTEMV)
+ if(nverbia > 0)then
+ print *,'** oper ZTEM1(NIINF,NJINF),&
+ & ZTEM1(NISUP,NJSUP) ap rota',&
+ ZTEM1(NIINF,NJINF),ZTEM1(NISUP,NJSUP)
+ print *,'** oper JKLOOP NKL ',&
+ JKLOOP,NKL
+ endif
+ ZWORK3D(:,:,JKLOOP-NKL+1)=ZTEM1(NIINF:NISUP,NJINF:NJSUP)
+ ZWORK3V(:,:,JKLOOP-NKL+1)=ZTEMV(NIINF:NISUP,NJINF:NJSUP)
+ ENDIF
+ ENDDO
+ IF(LVTM .OR. LVTT)THEN
+ ZWORK3D=ZWORK3V
+ ENDIF
+ DEALLOCATE(ZWORK3V,ZTEM1,ZTEMV)
+ ENDIF
+!!!!! Avril 99 Ajout ULM et VTM en CH
+ ELSE
+ if(nverbia > 0)then
+ print *,' **oper lig 3149'
+ endif
+ ZWORK3D=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,JLOOPT,JLOOPN,NPROCDIA(JLOOPP,KLOOP))
+ ENDIF
+! WRITE(CLEGEND2(8:15),'(F8.0)')XTRAJT(JLOOPT,1)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(JLOOPT,1)
+
+!!!!!!!!!!!!!!!!!!!!!!!!! CH !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ if(nverbia > 0)then
+ print *,' **oper AV LCH lig 3166'
+ endif
+
+ IF(LCH)THEN
+
+ IF(NBLVLKDIA(KLOOP,1) == 0)THEN
+
+ IF(.NOT.LZINCRDIA(KLOOP))THEN
+ DO JLOOPZ=1,NBLVLZDIA(KLOOP)
+
+ IZ=XLVLZDIA(JLOOPZ,KLOOP)
+! Pour LANIMK
+!Mars 2000
+ XLOOPZ=XLVLZDIA(JLOOPZ,KLOOP)
+ if(nverbia > 0)then
+ print *,' ***oper XLOOPZ ',XLOOPZ
+ endif
+! XLOOPZ=IZ
+!Mars 2000
+ IF(LANIMK)THEN
+ IF(JLOOPZ == 1)THEN
+ CALL FMFREE(YBID,YBID,IRESP)
+ print *,' OPER FMFREE YBID IRESP ',YBID,IRESP
+ CALL FMATTR(YBID,YBID,IBID,IRESP)
+ CALL GOPWK(9,IBID,3)
+ ISEGM=ISEGM+1
+ ISEGD=ISEGM
+ CALL GFLAS1(ISEGM)
+ ELSE
+ ISEGM=ISEGM+1
+ CALL GFLAS1(ISEGM)
+ ENDIF
+ ENDIF
+! Pour LANIMK
+ IF(LPXT .OR. LPYT)THEN
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ IF(ALLOCATED(ZSTAB))THEN
+ DEALLOCATE(ZSTAB)
+ ENDIF
+ IX=NISUP-NIINF+1
+ IY=NJSUP-NJINF+1
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1)+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ITIMEND=NTIMEDIA(1,KLOOP,1)+(((NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1))*NTIMEDIA(3,KLOOP,1))
+ IF(IX /= 1 .AND. IY /= 1)THEN
+ IF(LPXT)THEN
+ print *,' _PXT_ --> Profil horizontal // X f(t) demande'
+ print *,' Definissez correctement NIINF,NISUP,NJINF,NJSUP. Valeurs actuelles :'
+ print *,' NIINF=',NIINF,' NISUP=',NISUP,' NJINF=',NJINF,' NJSUP=',NJSUP
+ ELSE IF(LPYT)THEN
+ print *,' _PYT_ --> Profil horizontal // Y f(t) demande'
+ print *,' Definissez correctement NIINF,NISUP,NJINF,NJSUP. Valeurs actuelles :'
+ print *,' NIINF=',NIINF,' NISUP=',NISUP,' NJINF=',NJINF,' NJSUP=',NJSUP
+
+ ENDIF
+
+ LPBREAD=.TRUE.
+ RETURN
+ ELSE IF(IY == 1 .AND. IX /= 1)THEN
+ ALLOCATE(ZTEM2D(IX,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ IJLT=0
+ ELSE IF(IX == 1 .AND. IY /= 1)THEN
+ ALLOCATE(ZTEM2D(IY,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ IJLT=0
+ ENDIF
+ ALLOCATE(ZSTAB(IX,IY))
+ ENDIF
+ CALL INTERP_FORDIACHRO(IZ,NKL,NKH,ZWORK3D,ZSTAB)
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(IJLT)=XTRAJT(NLOOPT,1)
+ IF(LPXT)THEN
+ ZTEM2D(:,IJLT)=ZSTAB(:,1)
+ ELSE IF(LPYT)THEN
+ ZTEM2D(:,IJLT)=ZSTAB(1,:)
+ ENDIF
+ IF(JLOOPT == ITIMEND)THEN
+ ILENU=LEN_TRIM(CUNITGAL)
+ ILENT=LEN(CUNITGAL)
+ IF(ILENT-ILENU-2+1 < 8)THEN
+ IF(NVERBIA > 0)THEN
+ print *,' CUNITGAL ILENT-ILENU-2+1 < 8 ',CUNITGAL
+ ENDIF
+ ELSE
+ IF(LEV)THEN
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A2,''='',I5)')'PV',IZ
+ ELSE IF(LSV3)THEN
+ IF(LXYZ00)THEN
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')CGROUPSV3(1:3),IZ
+! WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')'Z00',IZ
+ ELSE
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')'SV3',IZ
+ ENDIF
+ ELSE
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A1,''='',I5)')CTYPHOR,IZ
+ ENDIF
+ ENDIF
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ DEALLOCATE(ZWORKT,ZTEM2D,ZSTAB)
+ ENDIF
+ ENDIF
+ ELSE
+ if(nverbia > 0)then
+ print *,' **oper AP TRACEH4 IZ II,IJ,IK ',IZ,II,IJ,IK
+ endif
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRACEH_FORDIACHRO(IZ,ZWORK3D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ if(nverbia > 0)then
+ print *,' **oper AP TRACEH4 IZ II,IJ,IK ',IZ,II,IJ,IK
+ endif
+ ENDIF
+ IF(LCV .AND. JLOOPZ == NBLVLZDIA(KLOOP))THEN
+ IINFCV=NIINF; IISUPCV=NISUP; IJINFCV=NJINF; IJSUPCV=NJSUP
+ NIINF=IINF;NISUP=ISUP;NJINF=IJINF;NJSUP=IJSUP
+ IF(NVERBIA > 0)THEN
+ print *,' oper 4 NIINF,NISUP,NJINF,NJSUP ',NIINF,NISUP,NJINF,NJSUP
+ ENDIF
+ ENDIF
+
+ CALL CLOSF(JLOOPT,ITIMEND, &
+ ISEGD,ISEGM,KLOOP)
+ IF(LCV .AND. JLOOPZ == NBLVLZDIA(KLOOP))THEN
+ NIINF=IINFCV; NISUP=IISUPCV; NJINF=IJINFCV; NJSUP=IJSUPCV
+ ENDIF
+
+ ENDDO
+
+ ELSE
+
+!Mars 2000
+ XLOOPZ=XLVLZDIA(1,KLOOP)-XLVLZDIA(3,KLOOP)
+!Mars 2000
+ DO JLOOPZ=INT(XLVLZDIA(1,KLOOP)),INT(XLVLZDIA(2,KLOOP)), &
+ INT(XLVLZDIA(3,KLOOP))
+ IZ=JLOOPZ
+! Pour LANIMK
+!Mars 2000
+ XLOOPZ=XLOOPZ+XLVLZDIA(3,KLOOP)
+ if(nverbia > 0)then
+ print *,' ***oper XLOOPZ ',XLOOPZ
+ endif
+! XLOOPZ=IZ
+!Mars 2000
+ IF(LANIMK)THEN
+ IF(JLOOPZ == XLVLZDIA(1,KLOOP))THEN
+ CALL FMFREE(YBID,YBID,IRESP)
+ print *,' OPER FMFREE YBID IRESP ',YBID,IRESP
+ CALL FMATTR(YBID,YBID,IBID,IRESP)
+ CALL GOPWK(9,IBID,3)
+ ISEGM=ISEGM+1
+ ISEGD=ISEGM
+ CALL GFLAS1(ISEGM)
+ ELSE
+ ISEGM=ISEGM+1
+ CALL GFLAS1(ISEGM)
+ ENDIF
+ ENDIF
+! Pour LANIMK
+ IF(LPXT .OR. LPYT)THEN
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ IF(ALLOCATED(ZSTAB))THEN
+ DEALLOCATE(ZSTAB)
+ ENDIF
+ IX=NISUP-NIINF+1
+ IY=NJSUP-NJINF+1
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1)+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ITIMEND=NTIMEDIA(1,KLOOP,1)+(((NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1))*NTIMEDIA(3,KLOOP,1))
+ IF(IX /= 1 .AND. IY /= 1)THEN
+ IF(LPXT)THEN
+ print *,' _PXT_ --> Profil horizontal // X f(t) demande'
+ print *,' Definissez correctement NIINF,NISUP,NJINF,NJSUP. Valeurs actuelles :'
+ print *,' NIINF=',NIINF,' NISUP=',NISUP,' NJINF=',NJINF,' NJSUP=',NJSUP
+ ELSE IF(LPYT)THEN
+ print *,' _PYT_ --> Profil horizontal // Y f(t) demande'
+ print *,' Definissez correctement NIINF,NISUP,NJINF,NJSUP. Valeurs actuelles :'
+ print *,' NIINF=',NIINF,' NISUP=',NISUP,' NJINF=',NJINF,' NJSUP=',NJSUP
+
+ ENDIF
+
+ LPBREAD=.TRUE.
+ RETURN
+ ELSE IF(IY == 1 .AND. IX /= 1)THEN
+ ALLOCATE(ZTEM2D(IX,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ IJLT=0
+ ELSE IF(IX == 1 .AND. IY /= 1)THEN
+ ALLOCATE(ZTEM2D(IY,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ IJLT=0
+ ENDIF
+ ALLOCATE(ZSTAB(IX,IY))
+ ENDIF
+ CALL INTERP_FORDIACHRO(IZ,NKL,NKH,ZWORK3D,ZSTAB)
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(IJLT)=XTRAJT(NLOOPT,1)
+ IF(LPXT)THEN
+ ZTEM2D(:,IJLT)=ZSTAB(:,1)
+ ELSE IF(LPYT)THEN
+ ZTEM2D(:,IJLT)=ZSTAB(1,:)
+ ENDIF
+ IF(JLOOPT == ITIMEND)THEN
+ ILENU=LEN_TRIM(CUNITGAL)
+ ILENT=LEN(CUNITGAL)
+ IF(ILENT-ILENU-2+1 < 8)THEN
+ IF(NVERBIA > 0)THEN
+ print *,' CUNITGAL ILENT-ILENU-2+1 < 8 ',CUNITGAL
+ ENDIF
+ ELSE
+ IF(LEV)THEN
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A2,''='',I5)')'PV',IZ
+ ELSE IF(LSV3)THEN
+ IF(LXYZ00)THEN
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')CGROUPSV3(1:3),IZ
+! WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')'Z00',IZ
+ ELSE
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')'SV3',IZ
+ ENDIF
+ ELSE
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A1,''='',I5)')CTYPHOR,IZ
+ ENDIF
+ ENDIF
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ DEALLOCATE(ZWORKT,ZTEM2D,ZSTAB)
+ ENDIF
+ ENDIF
+
+ ELSE
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ CALL TRACEH_FORDIACHRO(IZ,ZWORK3D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ if(nverbia > 0)then
+ print *,' **oper AP TRACEH5 IZ II,IJ,IK,KLOOP ',IZ,II,IJ,IK,KLOOP
+ endif
+ ENDIF
+ IF(LCV .AND. JLOOPZ == NINT(XLVLZDIA(2,KLOOP)))THEN
+ IINFCV=NIINF; IISUPCV=NISUP; IJINFCV=NJINF; IJSUPCV=NJSUP
+ NIINF=IINF;NISUP=ISUP;NJINF=IJINF;NJSUP=IJSUP
+ IF(NVERBIA > 0)THEN
+ print *,' oper 5 NIINF,NISUP,NJINF,NJSUP ',NIINF,NISUP,NJINF,NJSUP
+ print *,' oper 5 JLOOPZ NINT(XLVLZDIA(2,KLOOP)) ',JLOOPZ,NINT(XLVLZDIA(2,KLOOP))
+ ENDIF
+ ENDIF
+
+ CALL CLOSF(JLOOPT,ITIMEND, &
+ ISEGD,ISEGM,KLOOP)
+ IF(LCV .AND. JLOOPZ == NINT(XLVLZDIA(2,KLOOP)))THEN
+ NIINF=IINFCV; NISUP=IISUPCV; NJINF=IJINFCV; NJSUP=IJSUPCV
+ ENDIF
+
+ ENDDO
+ ENDIF
+
+ ELSE
+
+ DO JLOOPK=1,NBLVLKDIA(KLOOP,1)
+! Pour LANIMK
+ NLOOPK=JLOOPK
+ IF(LANIMK)THEN
+ IF(JLOOPK == 1)THEN
+ CALL FMFREE(YBID,YBID,IRESP)
+ print *,' OPER FMFREE YBID IRESP ',YBID,IRESP
+ CALL FMATTR(YBID,YBID,IBID,IRESP)
+ CALL GOPWK(9,IBID,3)
+ ISEGM=ISEGM+1
+ ISEGD=ISEGM
+ CALL GFLAS1(ISEGM)
+ ELSE
+ ISEGM=ISEGM+1
+ CALL GFLAS1(ISEGM)
+ ENDIF
+ ENDIF
+! Pour LANIMK
+
+ IZ=NLVLKDIA(JLOOPK,KLOOP,1)
+ if(nverbia > 0)then
+ print *,' **oper Niveau K transmis a INTERP ',IZ
+ print *,' **oper LPR,LTK,LEV,LSV3 ',LPR,LTK,LEV,LSV3
+ endif
+
+ IF(LPXT .OR. LPYT)THEN
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ IF(ALLOCATED(ZSTAB))THEN
+ DEALLOCATE(ZSTAB)
+ ENDIF
+ IX=NISUP-NIINF+1
+ IY=NJSUP-NJINF+1
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1)+1
+ ITIMEND=NTIMEDIA(1,KLOOP,1)+(((NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1))*NTIMEDIA(3,KLOOP,1))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(IX /= 1 .AND. IY /= 1)THEN
+ IF(LPXT)THEN
+ print *,' _PXT_ --> Profil horizontal // X f(t) demande'
+ print *,' Definissez correctement NIINF,NISUP,NJINF,NJSUP. Valeurs actuelles :'
+ print *,' NIINF=',NIINF,' NISUP=',NISUP,' NJINF=',NJINF,' NJSUP=',NJSUP
+ ELSE IF(LPYT)THEN
+ print *,' _PYT_ --> Profil horizontal // Y f(t) demande'
+ print *,' Definissez correctement NIINF,NISUP,NJINF,NJSUP. Valeurs actuelles :'
+ print *,' NIINF=',NIINF,' NISUP=',NISUP,' NJINF=',NJINF,' NJSUP=',NJSUP
+
+ ENDIF
+
+ LPBREAD=.TRUE.
+ RETURN
+ ELSE IF(IY == 1 .AND. IX /= 1)THEN
+ ALLOCATE(ZTEM2D(IX,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ IJLT=0
+ ELSE IF(IX == 1 .AND. IY /= 1)THEN
+ ALLOCATE(ZTEM2D(IY,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZTEM2D=XSPVAL
+ IJLT=0
+ ENDIF
+ ALLOCATE(ZSTAB(IX,IY))
+ ENDIF
+ CALL INTERP_FORDIACHRO(IZ,NKL,NKH,ZWORK3D,ZSTAB)
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(IJLT)=XTRAJT(NLOOPT,1)
+ IF(LPXT)THEN
+ ZTEM2D(:,IJLT)=ZSTAB(:,1)
+ ELSE IF(LPYT)THEN
+ ZTEM2D(:,IJLT)=ZSTAB(1,:)
+ ENDIF
+ IF(JLOOPT == ITIMEND)THEN
+ ILENU=LEN_TRIM(CUNITGAL)
+ ILENT=LEN(CUNITGAL)
+ IF(ILENT-ILENU-2+1 < 8)THEN
+ IF(NVERBIA > 0)THEN
+ print *,' CUNITGAL ILENT-ILENU-2+1 < 8 ',CUNITGAL
+ ENDIF
+ ELSE
+ IF(LEV)THEN
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A2,''='',I5)')'PV',IZ
+ ELSE IF(LSV3)THEN
+ IF(LXYZ00)THEN
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')CGROUPSV3(1:3),IZ
+! WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')'Z00',IZ
+ ELSE
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A3,''='',I5)')'SV3',IZ
+ ENDIF
+ ELSE
+ WRITE(CUNITGAL(ILENU+2:ILENT),'(A1,''='',I5)')CTYPHOR,IZ
+ ENDIF
+ ENDIF
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ DEALLOCATE(ZWORKT,ZTEM2D,ZSTAB)
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRACEH_FORDIACHRO(NLVLKDIA(JLOOPK,KLOOP,1), &
+ ZWORK3D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ if(nverbia > 0)then
+ print *,' **oper AP TRACEH6 IZ II,IJ,IK,KLOOP ',NLVLKDIA(JLOOPK,KLOOP,1),II,IJ,IK,KLOOP
+ endif
+ ENDIF
+ IF(LCV .AND. JLOOPK == NBLVLKDIA(KLOOP,1))THEN
+ IINFCV=NIINF; IISUPCV=NISUP; IJINFCV=NJINF; IJSUPCV=NJSUP
+ NIINF=IINF;NISUP=ISUP;NJINF=IJINF;NJSUP=IJSUP
+ IF(NVERBIA > 0)THEN
+ print *,'oper 6 NIINF,NISUP,NJINF,NJSUP ',NIINF,NISUP,NJINF,NJSUP
+ ENDIF
+ ENDIF
+
+ CALL CLOSF(JLOOPT,ITIMEND, &
+ ISEGD,ISEGM,KLOOP)
+ IF(LCV .AND. JLOOPK == NBLVLKDIA(KLOOP,1))THEN
+ NIINF=IINFCV; NISUP=IISUPCV; NJINF=IJINFCV; NJSUP=IJSUPCV
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!!! CV !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ELSE IF(LCV)THEN
+ if(nverbia > 0)then
+ print *,' **oper AP LCV lig 3570'
+ endif
+
+ IF(.NOT.LDEFCV2CC)THEN !%%%%%%%%%%%%%%%%%%%%%%%%
+
+ IF(NLMAX <= 1 .OR. (NLANGLE<0 .OR. NLANGLE>360) .OR. &
+ (NIDEBCOU <=0 .AND. XIDEBCOU == -999.) .OR. &
+ (NJDEBCOU <=0 .AND. XJDEBCOU == -999.))THEN
+ PRINT *,' DEFINISSEZ D''ABORD NIDEBCOU, NJDEBCOU,',&
+& ' NLMAX, NLANGLE (Pour CV + PV), PROFILE (Pour PV)'
+ PRINT *,' ou XIDEBCOU, XJDEBCOU'
+ PRINT *,' PUIS RENTREZ A NOUVEAU VOTRE DIRECTIVE '
+ print *,' (Pour le 1D, mettre Obligatoirement ',&
+& 'NLMAX=2 et LPOINTG=T)'
+ PRINT *,' VALEURS ACTUELLES: '
+ PRINT '('' NIDEBCOU:'',I5,'' NJDEBCOU:'',I5,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5,'' PROFILE: '',I5)',NIDEBCOU, &
+& NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ IF(II == 1 .AND. .NOT.LICP .AND. IJ > 1 .AND. IK >1)THEN
+ PRINT *,' DANS LE CAS CONSIDERE (CV // Y), si vous voulez ',&
+ &'la totalite de la coupe, METTEZ: '
+ PRINT '('' NIDEBCOU='',I5,'' NJDEBCOU='',I5,&
+ &'' NLMAX='',I6,'' NLANGLE= 90 '')',NIL,NJl,NJH-NJL+1
+ ENDIF
+ IF(IJ == 1 .AND. .NOT.LJCP .AND. II > 1 .AND. IK >1)THEN
+ PRINT *,' DANS LE CAS CONSIDERE (CV // X), si vous voulez ',&
+ &'la totalite de la coupe, METTEZ: '
+ PRINT '('' NIDEBCOU='',I5,'' NJDEBCOU='',I5,&
+ &'' NLMAX='',I6,'' NLANGLE= 0 '')',NIL,NJl,NIH-NIL+1
+ ENDIF
+ IF(ALLOCATED(ZWORK3D))THEN
+ DEALLOCATE(ZWORK3D)
+ LPBREAD=.TRUE.
+ ENDIF
+ RETURN
+ ELSE
+ IF((.NOT.LPVT .AND. .NOT.LPVKT .AND. .NOT.LPVKT1) .OR. &
+ (LPVT .AND. JLOOPT==NTIMEDIA(1,KLOOP,1)) .OR. &
+ (LPVKT .AND. JLOOPT==NTIMEDIA(1,KLOOP,1)) .OR. &
+ (LPVKT1 .AND. JLOOPT==NTIMEDIA(1,KLOOP,1)))THEN !!!!
+ IF(II == 1 .AND. .NOT.LICP .AND. IJ > 1 .AND. IK >1)THEN
+ PRINT *,' DANS LE CAS CONSIDERE (CV // Y), si vous voulez ',&
+ &'la totalite de la coupe, METTEZ: '
+ PRINT '('' NIDEBCOU='',I5,'' NJDEBCOU='',I5,&
+ &'' NLMAX='',I6,'' NLANGLE= 90 '')',NIL,NJl,NJH-NJL+1
+ ENDIF
+ IF(IJ == 1 .AND. .NOT.LJCP .AND. II > 1 .AND. IK >1)THEN
+ PRINT *,' DANS LE CAS CONSIDERE (CV // X), si vous voulez ',&
+ &'la totalite de la coupe, METTEZ: '
+ PRINT '('' NIDEBCOU='',I5,'' NJDEBCOU='',I5,&
+ &'' NLMAX='',I6,'' NLANGLE= 0 '')',NIL,NJl,NIH-NIL+1
+ ENDIF
+ PRINT *,' VALEURS DES PARAMETRES DE DEFINITION DE LA COUPE',&
+& ' ou DU PROFIL :'
+ IF(XIDEBCOU == -999. .AND. XJDEBCOU == -999.)THEN
+ PRINT '('' NIDEBCOU:'',I5,'' NJDEBCOU:'',I5,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5,'' PROFILE: '',I5)',NIDEBCOU, &
+& NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ print *,' ( Pour le 1D, mettre Obligatoirement ',&
+& 'NLMAX=2 et LPOINTG=T )'
+ ELSE
+ PRINT '('' XIDEBCOU:'',F7.1,'' XJDEBCOU:'',F7.1,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5,'' PROFILE: '',I5)',XIDEBCOU, &
+& XJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ENDIF !!!!
+ ENDIF
+ ENDIF
+ if(nverbia > 0)then
+ print *,' **oper lig 3613'
+ endif
+ IF((LPV.OR.LPVT.OR.LPVKT .OR.LPVKT1) .AND. NPROFILE > NLMAX)THEN
+ PRINT *,' PROFILE DOIT ETRE <= NLMAX '
+ print *,' NLMAX:',NLMAX,' PROFILE: ',NPROFILE
+ print *,' Valeur des autres informations utiles :'
+ PRINT '('' NIDEBCOU:'',I5,'' NJDEBCOU:'',I5, &
+& '' NLANGLE:'',I5)',NIDEBCOU, &
+& NJDEBCOU,NLANGLE
+ print *,' ( Pour le 1D, mettre Obligatoirement ',&
+& 'NLMAX=2 et LPOINTG=T )'
+ IF(ALLOCATED(ZWORK3D))THEN
+ DEALLOCATE(ZWORK3D)
+ LPBREAD=.TRUE.
+ ENDIF
+ RETURN
+ ENDIF
+ IF((LPV.OR.LPVT.OR.LPVKT.OR.LPVKT1) .AND. NPROFILE <= 0)THEN
+ PRINT *,' PROFILE DOIT ETRE DEFINI.',&
+ &'Sa valeur actuelle: ',NPROFILE
+ print *,' Valeur des autres informations utiles :'
+ PRINT '('' NIDEBCOU:'',I5,'' NJDEBCOU:'',I5,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5)',NIDEBCOU, &
+& NJDEBCOU,NLMAX,NLANGLE
+ print *,' ( Pour le 1D, mettre Obligatoirement ',&
+& 'NLMAX=2 et LPOINTG=T )'
+ IF(ALLOCATED(ZWORK3D))THEN
+ DEALLOCATE(ZWORK3D)
+ LPBREAD=.TRUE.
+ ENDIF
+ RETURN
+ ENDIF
+
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ if(nverbia > 0)then
+ print *,' **oper lig 3649'
+ endif
+
+ CALL VERIFLEN_FORDIACHRO
+ CALL MEMCV
+ ALLOCATE (ZTEMCV(NLMAX,1:IKU))
+ CALL PRECOU_FORDIACHRO(ZWORK3D,ZTEMCV)
+ if(nverbia >0)THEN
+ print *,' ** oper appel imcou Ytexte ',YTEXTE(1:LEN_TRIM(YTEXTE))
+ endif
+! CALL IMCOU_FORDIACHRO(ZTEMCV,XDIAINT,CLEGEND,YTEXTE( &
+! 1:LEN_TRIM(YTEXTE)))
+
+ IF(LPV)THEN
+ L1DT=.FALSE.
+! Janvier 2001
+ IF(LUMVM.OR.LUTVT.OR.LSUMVM.OR.LSUTVT.OR.&
+ LDIRWIND)THEN
+ ILENT=LEN_TRIM(CTITGAL)
+ ILENU=LEN_TRIM(CUNITGAL)
+ YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+ YTEXTE(ILENT+1:ILENT+1)=' '
+ YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRACEV_FORDIACHRO(ZTEMCV,KLOOP,YTEXTE(1: &
+ LEN_TRIM(YTEXTE)))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ ELSE
+! Janvier 2001
+ ALLOCATE(ZTEM1D(IKU),ZWORKZ(IKU))
+! Modif AOUT 97
+ ZTEM1D(:)=XSPVAL; ZWORKZ(:)=0.
+! ZTEM1D(:)=0.; ZWORKZ(:)=0.
+ ZTEM1D(MAX(IKB,NKL):MIN(IKE,NKH))= &
+ ZTEMCV(NPROFILE,MAX(IKB,NKL):MIN(IKE,NKH))
+ ZWORKZ(:)=XWORKZ(NPROFILE,:,NMGRID)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRAPRO_FORDIACHRO(ZTEM1D,ZWORKZ,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+ ELSE IF(LPVT .OR. LPVKT.OR. LPVKT1)THEN
+ L1DT=.FALSE.
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/NTIMEDIA(3,KLOOP,1) +1
+ ITIMEND=NTIMEDIA(1,KLOOP,1) + &
+ (((NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1))*NTIMEDIA(3,KLOOP,1))
+! print *,' ITIMEND ',ITIMEND
+! Janvier 2001 LUMVM + LDIRWIND + LMUMVM
+!Fev 2002
+ IF(LUMVM .OR.LUTVT .OR.LSUMVM .OR.LSUTVT )THEN
+! IF(LUMVM .OR.LUTVT .OR.LSUMVM .OR.LSUTVT &
+! .OR.LDIRWIND)THEN
+!Fev 2002
+ IF(ALLOCATED(XTEM2D))DEALLOCATE(XTEM2D)
+ IF(ALLOCATED(XTEM2D2))DEALLOCATE(XTEM2D2)
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ ALLOCATE(XTEM2D2(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ XTEM2D2=XSPVAL
+ ENDIF
+! Janvier 2001 LUMVM + LDIRWIND + LMUMVM
+ ALLOCATE(ZTEM2D(1:IKU,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ALLOCATE(ZWORKZ2(IKU))
+ ZWORKZ2(:)=0.; ZWORKT(:)=0.; ZTEM2D(:,:)=0.
+ ZWORKZ2(:)=XWORKZ(NPROFILE,:,NMGRID)
+ ZTEM2D=XSPVAL
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IJLT=0
+ ENDIF
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(IJLT)=XTRAJT(JLOOPT,1)
+ ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),IJLT)= &
+ ZTEMCV(NPROFILE,MAX(IKB,NKL):MIN(IKE,NKH))
+! Janvier 2001 LUMVM + LDIRWIND + LMUMVM
+!Fev 2002
+ IF(LUMVM .OR.LUTVT .OR.LSUMVM .OR.LSUTVT )THEN
+! IF(LUMVM .OR.LUTVT .OR.LSUMVM .OR.LSUTVT &
+! .OR.LDIRWIND)THEN
+!Fev 2002
+ XTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),IJLT)= &
+ ZTEMCV(NPROFILE,MAX(IKB,NKL):MIN(IKE,NKH))
+ XTEM2D2(MAX(IKB,NKL):MIN(IKE,NKH),IJLT)= &
+ XWCV(NPROFILE,MAX(IKB,NKL):MIN(IKE,NKH))
+ ENDIF
+! Janvier 2001 LUMVM + LDIRWIND + LMUMVM
+! IF(JLOOPT == NTIMEDIA(2,KLOOP,1))THEN
+ IF(JLOOPT == ITIMEND)THEN
+ XPVMIN=MINVAL(ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),:))
+ XPVMAX=MAXVAL(ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),:))
+ CALL VALMNMX(XPVMIN,XPVMAX)
+ IF(ABS(XPVMAX-XPVMIN) < 1.E-4)THEN
+ XPVMIN=XPVMIN-1.
+ XPVMAX=XPVMAX+1.
+ ENDIF
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ print *,' **oper lig 3735 AP PVFCT '
+ DEALLOCATE(ZTEM2D,ZWORKT,ZWORKZ2)
+
+ IF(ALLOCATED(XTEM2D))DEALLOCATE(XTEM2D)
+ IF(ALLOCATED(XTEM2D2))DEALLOCATE(XTEM2D2)
+ ENDIF
+ ELSE
+ ILENT=LEN_TRIM(CTITGAL)
+ ILENU=LEN_TRIM(CUNITGAL)
+ YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+ YTEXTE(ILENT+1:ILENT+1)=' '
+ YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL TRACEV_FORDIACHRO(ZTEMCV,KLOOP,YTEXTE(1: &
+ LEN_TRIM(YTEXTE)))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+ IF((LCV .OR. LPV) .AND. .NOT. LPVT .AND. .NOT. LPVKT .AND. .NOT. LPVKT1)THEN
+!!Fev 2002
+ IF(JLOOPT == NTIMEDIA(2,KLOOP,1))THEN
+ NIINF=IINF;NISUP=ISUP;NJINF=IJINF;NJSUP=IJSUP
+ ENDIF
+!!Fev 2002
+ CALL CLOSF(JLOOPT,ITIMEND, &
+ ISEGD,ISEGM,KLOOP)
+
+ ENDIF
+ DEALLOCATE(ZTEMCV)
+ DEALLOCATE(XWORKZ,XWZ)
+ IF(ALLOCATED(ZTEM1D))THEN
+ DEALLOCATE(ZTEM1D)
+ ENDIF
+ IF(ALLOCATED(ZWORKZ))THEN
+ DEALLOCATE(ZWORKZ)
+ ENDIF
+
+
+ ENDIF
+ ENDDO
+ IF((LPVT.AND..NOT.LPBREAD) .OR. LPVKT .OR. LPVKT1)THEN
+! IF(KLOOP == NSUPERDIA)CALL FRAME
+ IF(KLOOP == NSUPERDIA)THEN
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDDO
+ IF(NVERBIA > 0)THEN
+ print *,' **oper lig 3779 bien AP PVFCT '
+ endif
+ IF(LCV)THEN
+ NIINF=IINF;NISUP=ISUP;NJINF=IJINF;NJSUP=IJSUP
+ IF(NVERBIA > 0)THEN
+ print *,'NIINF,NISUP,NJINF,NJSUP ',NIINF,NISUP,NJINF,NJSUP
+ ENDIF
+ ENDIF
+
+
+ ENDIF
+
+ ENDIF
+!*****************************************************************************
+!*****************************************************************************
+ CASE('MASK')
+
+ II=SIZE(XVAR,1)
+ IJ=SIZE(XVAR,2)
+ IK=SIZE(XVAR,3)
+ IKU=NKMAX+2*JPVEXT
+ IF(CSTORAGE_TYPE == 'PG' .OR. CSTORAGE_TYPE == 'SU')THEN
+ IKU=1
+ ENDIF
+ IKB=1+JPVEXT; IKE=IKU-JPVEXT
+ IINF=NIINF;ISUP=NISUP;IJINF=NJINF;IJSUP=NJSUP
+ IF(NVERBIA > 0)THEN
+ print *,'IINF,ISUP,IJINF,IJSUP ',IINF,ISUP,IJINF,IJSUP
+ ENDIF
+! print *,' MASK SIZ XVAR XMASK ',II,IJ,IK,SIZE(XVAR,4),SIZE(XVAR,5), &
+! SIZE(XVAR,6),SIZE(XMASK,1),SIZE(XMASK,2), &
+! SIZE(XMASK,3),SIZE(XMASK,4),SIZE(XMASK,5),SIZE(XMASK,6)
+
+ IF(LCN .OR. LCNCUM .OR. LCNSUM)THEN
+!
+! Traitement des masques proprement dits (Mot-cle _MASK_ dans la directive)
+!
+!
+! Determination des limites du masque
+!
+ IF(SIZE(XMASK,1) == NIMAX)THEN
+ IF(NIMAX == 1)THEN
+ NIINF=1; NISUP=1
+ NIL=1; NIH=1
+ ELSE
+ NIINF=1+JPHEXT
+ NISUP=NIINF+NIMAX-1
+ NIL=1+JPHEXT; NIH=NIMAX+NIL-1
+ ENDIF
+ ELSE IF(SIZE(XMASK,1) == NIMAX + 2*JPHEXT)THEN
+ NIINF=1+JPHEXT
+ NISUP=NIINF+NIMAX-1
+ NIL=1; NIH=NIMAX+2*JPHEXT
+ ELSE
+ print *,' Taille des masques en X differente de IIU OU IMAX ', &
+ SIZE(XMASK,1)
+ print *,' PAS DE TRACE '
+ RETURN
+ ENDIF
+ IF(SIZE(XMASK,2) == NJMAX)THEN
+ IF(NJMAX == 1)THEN
+ NJINF=1; NJSUP=1
+ NJL=1; NJH=1
+ ELSE
+ NJINF=1+JPHEXT
+ NJSUP=NJINF+NJMAX-1
+ NJL=1+JPHEXT; NJH=NJMAX+NJL-1
+ ENDIF
+ ELSE IF(SIZE(XMASK,2) == NJMAX + 2*JPHEXT)THEN
+ NJINF=1+JPHEXT
+ NJSUP=NJINF+NJMAX-1
+ NJL=1; NJH=NJMAX+2*JPHEXT
+ ELSE
+ print *,' Taille des masques en Y differente de IJU OU JMAX ', &
+ SIZE(XMASK,2)
+ print *,' PAS DE TRACE '
+ ENDIF
+ ALLOCATE(ZWORK3D(NISUP-NIINF+1,NJSUP-NJINF+1,1))
+ ZWORK3D=0.
+ CTYPHOR(1:LEN(CTYPHOR))=' '
+ CTYPHOR='K'
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ IF(LCN)THEN !!!!!!!!!!!!!!!!!!!!
+! *****************************************
+! Boucle externe sur les numeros de masques
+! *****************************************
+!
+ DO JLOOPN=1,NBNDIA(KLOOP) !......................1
+ NLOOPN=NNDIA(JLOOPN,KLOOP)
+ NMGRID=1
+ YC1=' '; YC2=' '
+ IF(NNDIA(JLOOPN,KLOOP) < 10)THEN
+ WRITE(YC1,'(I1)')NNDIA(JLOOPN,KLOOP)
+ CTITGAL='MASK'//YC1
+ ELSE
+ WRITE(YC2,'(I2)')NNDIA(JLOOPN,KLOOP)
+ CTITGAL='MASK'//YC2
+ ENDIF
+ CTITGAL=ADJUSTL(ADJUSTR(CTITGAL))
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+!
+! ***********************************************
+! Boucle sur les temps (Formulation sequentielle)
+! ***********************************************
+!
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1) !................2
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+! Juillet 2001
+ IF(LANIMT .AND. NISUP-NIINF /= 0 .AND. NJSUP-NJINF /= 0)THEN
+ IF(JLOOPT == 1)THEN
+ CALL FMFREE(YBID,YBID,IRESP)
+ print *,' OPER FMFREE YBID IRESP ',YBID,IRESP
+
+ CALL FMATTR(YBID,YBID,IBID,IRESP)
+ CALL GOPWK(9,IBID,3)
+! CALL GOPWK(9,20,3)
+ ISEGM=ISEGM+1
+ ISEGD=ISEGM
+ CALL GFLAS1(ISEGM)
+ ELSE
+ ISEGM=ISEGM+1
+ CALL GFLAS1(ISEGM)
+ ENDIF
+ ENDIF
+! Juillet 2001
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ZWORK3D(:,:,1)=XMASK(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1,1, &
+ NTIMEDIA(JLOOPT,KLOOP,1),NNDIA(JLOOPN,KLOOP),1)
+! Traitement cas 2D (--> masque filaire)
+ IF(NIINF == 1 .AND. NISUP == 1)THEN
+ CALL TRAMASK(ZWORK3D(1:1,:,1:1),KLOOP)
+ ELSE IF(NJINF == 1 .AND. NJSUP == 1)THEN
+ CALL TRAMASK(ZWORK3D(:,1:1,1:1),KLOOP)
+ ELSE
+! Traitement cas 3D (--> masque surfacique)
+ CALL TRACEH_FORDIACHRO(1,ZWORK3D,KLOOP)
+ ENDIF
+! Juillet 2001
+ IF(LANIMT .AND. NISUP-NIINF /= 0 .AND. NJSUP-NJINF /= 0)THEN
+ CALL GFLAS2
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ DO JJ=ISEGD,ISEGM
+ CALL GFLAS3(JJ)
+ ENDDO
+ CALL GCLWK(9)
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ELSE
+! Juillet 2001
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+! Juillet 2001
+ ENDIF
+! Juillet 2001
+ ENDDO !................2
+ ELSE
+!
+! ***********************************************
+! Boucle sur les temps (Formulation incrementale)
+! ***********************************************
+!
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)!.3
+ NLOOPT=JLOOPT
+! Juillet 2001
+ IF(LANIMT .AND. NJSUP-NJINF /= 0 .AND. NISUP-NIINF /=0)THEN
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ CALL FMFREE(YBID,YBID,IRESP)
+ if(nverbia >0)then
+ print *,' OPER FMFREE YBID IRESP ',YBID,IRESP
+ endif
+ CALL FMATTR(YBID,YBID,IBID,IRESP)
+ if(nverbia >0)then
+ print *,' OPER FMATTR YBID IBID IRESP ',YBID,IBID,IRESP
+ endif
+ CALL GOPWK(9,IBID,3)
+ ISEGM=ISEGM+1
+ ISEGD=ISEGM
+ CALL GFLAS1(ISEGM)
+ ITIMEND=NTIMEDIA(1,KLOOP,1) + &
+ (((NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1))*NTIMEDIA(3,KLOOP,1))
+ ELSE
+ ISEGM=ISEGM+1
+ print *,' OPER ISEGM ',ISEGM
+ CALL GFLAS1(ISEGM)
+ ENDIF
+ ENDIF
+! Juillet 2001
+ CALL RESOLV_TIMES(JLOOPT)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(JLOOPT,1)
+ ZWORK3D(:,:,1)=XMASK(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1,1,JLOOPT, &
+ NNDIA(JLOOPN,KLOOP),1)
+! Traitement cas 2D (--> masque filaire)
+ IF(NIINF == 1 .AND. NISUP == 1)THEN
+ CALL TRAMASK(ZWORK3D(1:1,:,1:1),KLOOP)
+ ELSE IF(NJINF == 1 .AND. NJSUP == 1)THEN
+ CALL TRAMASK(ZWORK3D(:,1:1,1:1),KLOOP)
+ ELSE
+! Traitement cas 3D (--> masque surfacique)
+ CALL TRACEH_FORDIACHRO(1,ZWORK3D,KLOOP)
+ ENDIF
+! Juillet 2001
+ IF(LANIMT .AND. NISUP-NIINF /= 0 .AND. NJSUP-NJINF /= 0)THEN
+ CALL GFLAS2
+ IF(JLOOPT == ITIMEND)THEN
+ DO JJ=ISEGD,ISEGM
+ CALL GFLAS3(JJ)
+ ENDDO
+ CALL GCLWK(9)
+ CALL NGPICT(1,1)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(INB > 1)CALL NGPICT(2,3)
+ ENDIF
+ ELSE
+! Juillet 2001
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+! Juillet 2001
+ ENDIF
+! Juillet 2001
+ ENDDO !.3
+ ENDIF
+ ENDDO !......................1
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ELSE IF(LCNCUM)THEN !!!!!!!!!!!!!!!!!!!!
+
+! *****************************************
+! Boucle externe sur les numeros de masques
+! *****************************************
+!
+ DO JLOOPN=1,NBNDIA(KLOOP) !......................1
+ NLOOPN=NNDIA(JLOOPN,KLOOP)
+ NMGRID=1
+ ZWORK3D=0.
+ YC1=' '; YC2=' '
+ IF(NNDIA(JLOOPN,KLOOP) < 10)THEN
+ WRITE(YC1,'(I1)')NNDIA(JLOOPN,KLOOP)
+ CTITGAL='MASK'//YC1
+ ELSE
+ WRITE(YC2,'(I2)')NNDIA(JLOOPN,KLOOP)
+ CTITGAL='MASK'//YC2
+ ENDIF
+ CTITGAL=ADJUSTL(ADJUSTR(CTITGAL))
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+!
+! ***********************************************
+! Boucle sur les temps (Formulation sequentielle)
+! ***********************************************
+!
+ IJLT=0
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1) !................2
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+ IJLT=IJLT+1
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ IF(IJLT < 9)THEN
+ WRITE(CTIMECS(8*IJLT:8*IJLT+7),'(F8.0)')XTRAJT( &
+ NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ELSE IF(IJLT == 9)THEN
+ CTIMECS(8*IJLT:8*IJLT+4)='.....'
+ ENDIF
+ ZWORK3D(:,:,1)=ZWORK3D(:,:,1) + XMASK(NIINF-NIL+1: &
+ NISUP-NIL+1,NJINF-NJL+1:NJSUP-NJL+1,1, &
+ NTIMEDIA(JLOOPT,KLOOP,1),NNDIA(JLOOPN,KLOOP),1)
+! print *,' JLOOPT JLOOPN ZWORK3D ',JLOOPT,JLOOPN
+! print *,ZWORK3D(:,:,1)
+ ENDDO !................2
+! Traitement cas 2D (--> masque filaire)
+ IF(NIINF == 1 .AND. NISUP == 1)THEN
+ CALL TRAMASK(ZWORK3D(1:1,:,1:1),KLOOP)
+ ELSE IF(NJINF == 1 .AND. NJSUP == 1)THEN
+ CALL TRAMASK(ZWORK3D(:,1:1,1:1),KLOOP)
+ CALL EZXY(XXX(NIINF:NISUP,NMGRID),ZWORK3D(:,1,1), &
+ NISUP-NIINF+1,0)
+ ELSE
+! Traitement cas 3D (--> masque surfacique)
+ CALL TRACEH_FORDIACHRO(1,ZWORK3D,KLOOP)
+ ENDIF
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ELSE
+!
+! ***********************************************
+! Boucle sur les temps (Formulation incrementale)
+! ***********************************************
+!
+ IJLT=0
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)!.3
+ NLOOPT=JLOOPT
+ IJLT=IJLT+1
+ CALL RESOLV_TIMES(JLOOPT)
+ IF(IJLT < 9)THEN
+ WRITE(CTIMECS(8*IJLT:8*IJLT+7),'(F8.0)')XTRAJT( &
+ JLOOPT,1)
+ ELSE IF(IJLT == 9)THEN
+ CTIMECS(8*IJLT:8*IJLT+4)='.....'
+ ENDIF
+ ZWORK3D(:,:,1)=ZWORK3D(:,:,1) + XMASK(NIINF-NIL+1: &
+ NISUP-NIL+1,NJINF-NJL+1:NJSUP-NJL+1,1,JLOOPT, &
+ NNDIA(JLOOPN,KLOOP),1)
+! print *,' JLOOPT JLOOPN ZWORK3D ',JLOOPT,JLOOPN
+! print *,ZWORK3D(:,:,1)
+ ENDDO !.3
+! Traitement cas 2D (--> masque filaire)
+ IF(NIINF == 1 .AND. NISUP == 1)THEN
+ CALL TRAMASK(ZWORK3D(1:1,:,1:1),KLOOP)
+ ELSE IF(NJINF == 1 .AND. NJSUP == 1)THEN
+ CALL TRAMASK(ZWORK3D(:,1:1,1:1),KLOOP)
+ ELSE
+! Traitement cas 3D (--> masque surfacique)
+ CALL TRACEH_FORDIACHRO(1,ZWORK3D,KLOOP)
+ ENDIF
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDIF
+ ENDDO !......................1
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ELSE IF(LCNSUM)THEN !!!!!!!!!!!!!!!!!!!!
+
+! *****************************************
+! Boucle externe sur les numeros de masques
+! *****************************************
+!
+ DO JLOOPN=1,NBNDIA(KLOOP) !......................1
+ NLOOPN=NNDIA(JLOOPN,KLOOP)
+ NMGRID=1
+ YC1=' '; YC2=' '
+ IF(NNDIA(JLOOPN,KLOOP) < 10)THEN
+ WRITE(YC1,'(I1)')NNDIA(JLOOPN,KLOOP)
+ CTITGAL='MASK'//YC1
+ ELSE
+ WRITE(YC2,'(I2)')NNDIA(JLOOPN,KLOOP)
+ CTITGAL='MASK'//YC2
+ ENDIF
+ CTITGAL=ADJUSTL(ADJUSTR(CTITGAL))
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+!
+! ***********************************************
+! Boucle sur les temps (Formulation sequentielle)
+! ***********************************************
+!
+ ALLOCATE(ZWORK1D(NBTIMEDIA(KLOOP,1)))
+ ALLOCATE(ZWORKT(NBTIMEDIA(KLOOP,1)))
+ IJLT=0
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1) !................2
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+ IJLT=IJLT+1
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ IF(IJLT < 9)THEN
+ WRITE(CTIMECS(8*IJLT:8*IJLT+7),'(F8.0)')XTRAJT( &
+ NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ELSE IF(IJLT == 9)THEN
+ CTIMECS(8*IJLT:8*IJLT+4)='.....'
+ ENDIF
+ ZWORK3D(:,:,1)=XMASK(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1,1,NTIMEDIA(JLOOPT,KLOOP,1), &
+ NNDIA(JLOOPN,KLOOP),1)
+ ZWORKT(JLOOPT)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ZWORK1D(JLOOPT)=SUM(ZWORK3D)
+ ENDDO !................2
+ LFT1=.TRUE.
+ CALL VARFCT(ZWORKT,ZWORK1D,1)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ELSE
+!
+! ***********************************************
+! Boucle sur les temps (Formulation incrementale)
+! ***********************************************
+!
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/NTIMEDIA(3,KLOOP,1)+1
+ ALLOCATE(ZWORKT(ILENW))
+ ALLOCATE(ZWORK1D(ILENW))
+ IJLT=0
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)!.3
+ NLOOPT=JLOOPT
+ IJLT=IJLT+1
+ CALL RESOLV_TIMES(JLOOPT)
+ IF(IJLT < 9)THEN
+ WRITE(CTIMECS(8*IJLT:8*IJLT+7),'(F8.0)')XTRAJT( &
+ JLOOPT,1)
+ ELSE IF(IJLT == 9)THEN
+ CTIMECS(8*IJLT:8*IJLT+4)='.....'
+ ENDIF
+ ZWORK3D(:,:,1)=XMASK(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1,1, &
+ JLOOPT,NNDIA(JLOOPN,KLOOP),1)
+! print *,' OPER OPER JLOOPT ZWORK3D ',JLOOPT
+! print *,ZWORK3D
+! Correction AOUT 2001
+ ZWORKT(IJLT)=XTRAJT(JLOOPT,1)
+ ZWORK1D(IJLT)=SUM(ZWORK3D)
+! ZWORKT(JLOOPT)=XTRAJT(JLOOPT,1)
+! ZWORK1D(JLOOPT)=SUM(ZWORK3D)
+ ENDDO !.3
+ LFT1=.TRUE.
+ CALL VARFCT(ZWORKT,ZWORK1D,1)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDIF
+ DEALLOCATE(ZWORKT,ZWORK1D)
+ ENDDO !......................1
+ ENDIF
+ DEALLOCATE(ZWORK3D)
+ ELSE
+!
+! Traitement des infos gerees par un masque: PV
+! Cas compression sur l'axe Z (Compressions en X et Y implicites)
+! ***************************************************************
+ DO JLOOPN=1,NBNDIA(KLOOP) !......................1
+ NLOOPN=NNDIA(JLOOPN,KLOOP)
+
+ IF(LPVKT .AND. NSUPERDIA>1)THEN
+ IF(NBPROCDIA(KLOOP)>1 .OR. NBLVLKDIA(KLOOP,1)>1 &
+ .OR. NBNDIA(KLOOP)>1)THEN
+ print *,' _PVKT_ SUPERPOSITIONS : '
+ print *,' On ne peut definir de part de d''autre '&
+ &'de _ON_ qu''1 seul processus, 1 seul niveau, 1 seule station '
+ print *,' Nb de niveaux demandes : ',NBLVLKDIA(KLOOP,1)
+ print *,' Nb de processus demandes : ',NBPROCDIA(KLOOP)
+ print *,' Nb de stations demandees : ',NBNDIA(KLOOP)
+ print *,' *** MODIFIEZ VOTRE DIRECTIVE *** '
+ EXIT
+ ENDIF
+ ENDIF
+
+ YTITGAL(1:LEN(YTITGAL))=' '
+ YC1=' '; YC2=' '
+ IF(NLOOPN < 10)THEN
+ WRITE(YC1,'(I1)')NNDIA(JLOOPN,KLOOP)
+ YTITGAL='MASK'//YC1
+ ELSE
+ WRITE(YC2,'(I2)')NNDIA(JLOOPN,KLOOP)
+ YTITGAL='MASK'//YC2
+ ENDIF
+ YTITGAL=ADJUSTL(ADJUSTR(YTITGAL))
+ IF(II == 1 .AND. IJ == 1 .AND. IK == 1)THEN
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+ ALLOCATE(ZWORKT(NBTIMEDIA(KLOOP,1)))
+ ALLOCATE(ZWORK1D(NBTIMEDIA(KLOOP,1)))
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+ NMGRID=NGRIDIA(NPROCDIA(JLOOPP,KLOOP))
+ IF(NGRIDIAM /= 0 .AND. (NMGRID /= NGRIDIAM))THEN
+ print *,' ****oper NMGRID Av modif ',NMGRID
+ NMGRID=NGRIDIAM
+ print *,' ****oper NMGRID mis volontairement a la valeur de NGRIDIAM ',NGRIDIAM
+ ENDIF
+ IF(NMGRID <1 .OR. NMGRID >7)THEN
+ PRINT *,' VALEUR NMGRID ABERRANTE: ',NMGRID, &
+ ' FORCEE A : 1'
+ NMGRID=1
+ ENDIF
+ CTITGAL(1:LEN(CTITGAL))=' '
+ CTITGAL=ADJUSTL(ADJUSTR(YTITGAL)//' '//ADJUSTL(CTITRE(NPROCDIA(JLOOPP,KLOOP))))
+ CUNITGAL=ADJUSTL(CUNITE(NPROCDIA(JLOOPP,KLOOP)))
+ CTITGAL=ADJUSTL(CTITGAL)
+! print *,' MASK PV JLOOPP, NPROCDIA CTITGAL ',JLOOPP,NPROCDIA(JLOOPP,KLOOP),' ',CTITGAL
+ CUNITGAL=ADJUSTL(CUNITGAL)
+ CUNITGAL(INDEX(CUNITGAL,' '):LEN(CUNITGAL))=' '
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ ZWORKT(JLOOPT)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ZWORK1D(JLOOPT)=XVAR(1,1,1,NTIMEDIA(JLOOPT,KLOOP,1), &
+ NNDIA(JLOOPN,KLOOP),NPROCDIA(JLOOPP,KLOOP))
+ ENDDO
+ CALL VARFCT(ZWORKT,ZWORK1D,1)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ DEALLOCATE(ZWORKT,ZWORK1D)
+ ENDDO
+ ELSE
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/NTIMEDIA(3,KLOOP,1)+1
+ ALLOCATE(ZWORKT(ILENW))
+ ALLOCATE(ZWORK1D(ILENW))
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+ NMGRID=NGRIDIA(NPROCDIA(JLOOPP,KLOOP))
+ IF(NGRIDIAM /= 0 .AND. (NMGRID /= NGRIDIAM))THEN
+ print *,' ****oper NMGRID Av modif ',NMGRID
+ NMGRID=NGRIDIAM
+ print *,' ****oper NMGRID mis volontairement a la valeur de NGRIDIAM ',NGRIDIAM
+ ENDIF
+ IF(NMGRID <1 .OR. NMGRID >7)THEN
+ PRINT *,' VALEUR NMGRID ABERRANTE: ',NMGRID, &
+ ' FORCEE A : 1'
+ NMGRID=1
+ ENDIF
+ CTITGAL(1:LEN(CTITGAL))=' '
+ CTITGAL=ADJUSTL(ADJUSTR(YTITGAL)//' '//ADJUSTL(CTITRE(NPROCDIA(JLOOPP,KLOOP))))
+ CUNITGAL=ADJUSTL(CUNITE(NPROCDIA(JLOOPP,KLOOP)))
+ CTITGAL=ADJUSTL(CTITGAL)
+ CUNITGAL=ADJUSTL(CUNITGAL)
+ CUNITGAL(INDEX(CUNITGAL,' '):LEN(CUNITGAL))=' '
+! print *,' MASK PV JLOOPP, NPROCDIA CTITGAL ',JLOOPP,NPROCDIA(JLOOPP,KLOOP),' ',CTITGAL
+ IJLT=0
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+ CALL RESOLV_TIMES(JLOOPT)
+ IJLT=IJLT+1
+ ZWORKT(IJLT)=XTRAJT(JLOOPT,1)
+ ZWORK1D(IJLT)=XVAR(1,1,1,JLOOPT,NNDIA(JLOOPN,KLOOP),NPROCDIA(JLOOPP,KLOOP))
+ ENDDO
+ CALL VARFCT(ZWORKT,ZWORK1D,1)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ DEALLOCATE(ZWORKT,ZWORK1D)
+ ENDDO
+ ENDIF
+ ELSE IF(II == 1 .AND. IJ == 1 .AND. IK /= 1)THEN
+! Pas de compression en Z
+! ***********************
+ L1DT=.TRUE.
+ ALLOCATE(ZTEM1D(IKU),ZWORKZ(IKU))
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+!!! Octobre 2001
+ IF(JLOOPP > 1 .AND. LUMVMPV .AND. LPV)EXIT
+!!! Octobre 2001
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+! Modif AOUT 97
+ ZTEM1D(:)=XSPVAL; ZWORKZ(:)=0.
+! ZTEM1D(:)=0.; ZWORKZ(:)=0.
+ NMGRID=NGRIDIA(NPROCDIA(JLOOPP,KLOOP))
+ IF(NGRIDIAM /= 0 .AND. (NMGRID /= NGRIDIAM))THEN
+ print *,' ****oper NMGRID Av modif ',NMGRID
+ NMGRID=NGRIDIAM
+ print *,' ****oper NMGRID mis volontairement a la valeur de NGRIDIAM ',NGRIDIAM
+ ENDIF
+ IF(NMGRID <1 .OR. NMGRID >7)THEN
+ PRINT *,' VALEUR NMGRID ABERRANTE: ',NMGRID, &
+ ' FORCEE A : 1'
+ NMGRID=1
+ ENDIF
+!!!!!!!!!!Octobre 2001
+ IF(LUMVMPV)THEN
+ NMGRID=1
+ ENDIF
+!!!!!!!!!!Octobre 2001
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+ CTITGAL(1:LEN(CTITGAL))=' '
+ CTITGAL=ADJUSTL(ADJUSTR(YTITGAL)//' '//ADJUSTL(CTITRE(NPROCDIA(JLOOPP,KLOOP))))
+! CTITGAL=ADJUSTL(CTITRE(NPROCDIA(JLOOPP,KLOOP)))
+ CUNITGAL=ADJUSTL(CUNITE(NPROCDIA(JLOOPP,KLOOP)))
+ CTITGAL=ADJUSTL(CTITGAL)
+! print *,' MASK PV JLOOPP, NPROCDIA CTITGAL ',JLOOPP,NPROCDIA(JLOOPP,KLOOP),' ',CTITGAL
+! print *,' MASK CTITRE ',CTITRE(NPROCDIA(JLOOPP,KLOOP))
+ CUNITGAL=ADJUSTL(CUNITGAL)
+ CUNITGAL(INDEX(CUNITGAL,' '):LEN(CUNITGAL))=' '
+! Expression temps non incrementale
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ CTIMEC(16:16)='s'
+ ZTEM1D(NKL:NKH)=XVAR(1,1,: &
+ ,NTIMEDIA(JLOOPT,KLOOP,1),NNDIA(JLOOPN,KLOOP),&
+ NPROCDIA(JLOOPP,KLOOP))
+ ZWORKZ(:)=XXZ(:,NMGRID)
+! print *,' ZTEM1D '
+! print *,ZTEM1D
+!!!!!!!!!!Octobre 2001
+
+!!!!!!!!!!Octobre 2001
+ IF(LPV)THEN
+!!!!!!!!!!Octobre 2001
+ IF(LUMVMPV)THEN
+ LPV=.FALSE. ; LPVT=.TRUE.
+ IF(JLOOPP == 1)THEN
+ ILENW=1
+ ALLOCATE(ZTEM2D(1:IKU,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZWORKT=NLOOPT
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ ALLOCATE(XTEM2D2(1:IKU,ILENW))
+ XTEM2D2=XSPVAL
+ XTEM2D(:,1)=ZTEM1D
+ XTEM2D2(NKL:NKH,1)=XVAR(1,1,: &
+ ,NTIMEDIA(JLOOPT,KLOOP,1),NNDIA(JLOOPN,KLOOP),NPROCDIA(JLOOPP+1,KLOOP))
+ IF(NBPROCDIA(KLOOP) == 3)THEN
+ ZTEM2D=XSPVAL
+ ZTEM2D(NKL:NKH,1)=XVAR(1,1,: &
+ ,NTIMEDIA(JLOOPT,KLOOP,1),NNDIA(JLOOPN,KLOOP),NPROCDIA(JLOOPP+2,KLOOP))
+ CALL COLVECT(IKU,ZTEM2D)
+ ENDIF
+
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LUMVMPV)THEN
+ LPV=.TRUE. ; LPVT=.FALSE.
+ ENDIF
+ DEALLOCATE(ZTEM2D,ZWORKT)
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ LCOLPVT=.FALSE.
+ ENDIF
+ ELSE
+!!!!!!!!!!Octobre 2001
+ CALL TRAPRO_FORDIACHRO(ZTEM1D,ZWORKZ,KLOOP)
+!!!!!!!!!!Octobre 2001
+ ENDIF
+!!!!!!!!!!Octobre 2001
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ELSE IF(LPVT .OR. LPVKT)THEN
+ IF(JLOOPT == 1)THEN
+ ILENW=NBTIMEDIA(KLOOP,1)
+ IF(ALLOCATED(ZTEM2D))THEN
+ DEALLOCATE(ZTEM2D)
+ ENDIF
+ IF(ALLOCATED(ZWORKT))THEN
+ DEALLOCATE(ZWORKT)
+ ENDIF
+ ALLOCATE(ZTEM2D(1:IKU,ILENW))
+ ZTEM2D=XSPVAL
+ ALLOCATE(ZWORKT(ILENW))
+!!!!!!!!!!Octobre 2001
+ IF(LUMVM)THEN
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ ENDIF
+ IF(LUMVMPV .AND. JLOOPP == 1)THEN
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ ALLOCATE(XTEM2D2(1:IKU,ILENW))
+ XTEM2D2=XSPVAL
+ ENDIF
+!!!!!!!!!!Octobre 2001
+ ENDIF
+ ZWORKT(JLOOPT)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ZTEM2D(NKL:NKH,NTIMEDIA(JLOOPT,KLOOP,1))= &
+ XVAR(1,1,:, &
+ NTIMEDIA(JLOOPT,KLOOP,1),NNDIA(JLOOPN,KLOOP),NPROCDIA(JLOOPP,KLOOP))
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+ XPVMIN=MINVAL(ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),:))
+ XPVMAX=MAXVAL(ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),:))
+ CALL VALMNMX(XPVMIN,XPVMAX)
+ IF(ABS(XPVMAX-XPVMIN) < 1.E-4)THEN
+ XPVMIN=XPVMIN-1.
+ XPVMAX=XPVMAX+1.
+ ENDIF
+!!!!!!!!!!Octobre 2001
+ IF(LUMVMPV)THEN
+ IF(JLOOPP == 1)THEN
+! Memorisation de U
+ XTEM2D=ZTEM2D
+ CYCLE
+ ELSEIF(JLOOPP == 2)THEN
+ IF(JLOOPP == NBPROCDIA(KLOOP))THEN
+ XTEM2D2=ZTEM2D
+ ELSE
+ XTEM2D2=ZTEM2D
+ CYCLE
+ ENDIF
+ ELSEIF(JLOOPP == 3)THEN
+ CALL COLVECT(IKU,ZTEM2D)
+ ENDIF
+ ENDIF
+
+!!!!!!!!!!Octobre 2001
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ DEALLOCATE(ZTEM2D,ZWORKT)
+!!!!!!!!!!Octobre 2001
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ LCOLPVT=.FALSE.
+
+!!!!!!!!!!Octobre 2001
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ELSE
+! Expression temps incrementale
+! print *,'NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1) ', &
+! NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+! print *,XTIMEDIA(1,KLOOP,1),XTIMEDIA(2,KLOOP,1),XTIMEDIA(3,KLOOP,1)
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+ CALL RESOLV_TIMES(JLOOPT)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(JLOOPT,1)
+ ZTEM1D(NKL:NKH)=XVAR(1,1,: &
+ ,JLOOPT,NNDIA(JLOOPN,KLOOP),NPROCDIA(JLOOPP,KLOOP))
+ ZWORKZ(:)=XXZ(:,NMGRID)
+! print *,' ZTEM1D '
+! print *,ZTEM1D
+
+ IF(LPV)THEN
+!!! Octobre 2001
+ IF(LUMVMPV)THEN
+ LPV=.FALSE. ; LPVT=.TRUE.
+ IF(JLOOPP == 1)THEN
+ ILENW=1
+ ALLOCATE(ZTEM2D(1:IKU,ILENW))
+ ALLOCATE(ZWORKT(ILENW))
+ ZWORKT=NLOOPT
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ ALLOCATE(XTEM2D2(1:IKU,ILENW))
+ XTEM2D2=XSPVAL
+ XTEM2D(:,1)=ZTEM1D
+ XTEM2D2(NKL:NKH,1)=XVAR(1,1,: &
+ ,JLOOPT,NNDIA(JLOOPN,KLOOP),NPROCDIA(JLOOPP+1,KLOOP))
+ IF(NBPROCDIA(KLOOP) == 3)THEN
+ ZTEM2D=XSPVAL
+ ZTEM2D(NKL:NKH,1)=XVAR(1,1,: &
+ ,JLOOPT,NNDIA(JLOOPN,KLOOP),NPROCDIA(JLOOPP+2,KLOOP))
+
+ CALL COLVECT(IKU,ZTEM2D)
+ ENDIF
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ IF(LUMVMPV)THEN
+ LPV=.TRUE. ; LPVT=.FALSE.
+ ENDIF
+ DEALLOCATE(ZTEM2D,ZWORKT)
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ LCOLPVT=.FALSE.
+ ENDIF
+
+ ELSE
+!!! Octobre 2001
+ CALL TRAPRO_FORDIACHRO(ZTEM1D,ZWORKZ,KLOOP)
+!!! Octobre 2001
+ ENDIF
+!!! Octobre 2001
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+
+ ELSE IF(LPVT .OR. LPVKT)THEN
+
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/NTIMEDIA(3,KLOOP,1) +1
+ ITIMEND=NTIMEDIA(1,KLOOP,1) + &
+ (((NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1))*NTIMEDIA(3,KLOOP,1))
+ IF(NVERBIA > 0)THEN
+ print *,' ITIMEND ',ITIMEND
+ ENDIF
+ IF(ALLOCATED(ZTEM2D))THEN
+ DEALLOCATE(ZTEM2D)
+ ENDIF
+ IF(ALLOCATED(ZWORKT))THEN
+ DEALLOCATE(ZWORKT)
+ ENDIF
+
+ ALLOCATE(ZTEM2D(1:IKU,ILENW))
+ ZTEM2D=XSPVAL
+ ALLOCATE(ZWORKT(ILENW))
+ IJLT=0
+!!!!!!!!!!Octobre 2001
+ IF(LUMVMPV .AND. JLOOPP == 1)THEN
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ ALLOCATE(XTEM2D(1:IKU,ILENW))
+ XTEM2D=XSPVAL
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ ALLOCATE(XTEM2D2(1:IKU,ILENW))
+ XTEM2D2=XSPVAL
+ ENDIF
+
+!!!!!!!!!!Octobre 2001
+ ENDIF
+ IJLT=IJLT+1
+ ZWORKT(IJLT)=XTRAJT(JLOOPT,1)
+ ZTEM2D(NKL:NKH,IJLT)= &
+ XVAR(1,1,:, &
+ JLOOPT,NNDIA(JLOOPN,KLOOP),NPROCDIA(JLOOPP,KLOOP))
+
+! IF(JLOOPT == NTIMEDIA(2,KLOOP,1))THEN
+ IF(JLOOPT == ITIMEND)THEN
+ XPVMIN=MINVAL(ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),:))
+ XPVMAX=MAXVAL(ZTEM2D(MAX(IKB,NKL):MIN(IKE,NKH),:))
+ CALL VALMNMX(XPVMIN,XPVMAX)
+ IF(ABS(XPVMAX-XPVMIN) < 1.E-4)THEN
+ XPVMIN=XPVMIN-1.
+ XPVMAX=XPVMAX+1.
+ ENDIF
+!!!!!!!!!!Octobre 2001
+ IF(LUMVMPV)THEN !llllllllllllllllllll
+
+ IF(JLOOPP == 1)THEN !kkkkkkkkkkkkkkkkkkkkkkk
+! Memorisation de U
+ XTEM2D=ZTEM2D
+ CYCLE
+ ELSEIF(JLOOPP == 2)THEN !kkkkkkkkkkkkkkkkkkkkk
+ IF(JLOOPP == NBPROCDIA(KLOOP))THEN
+ XTEM2D2=ZTEM2D
+ ELSE
+ XTEM2D2=ZTEM2D
+ CYCLE
+ ENDIF
+ ELSEIF(JLOOPP == 3)THEN !kkkkkkkkkkkkkkkkkkkkk
+ CALL COLVECT(IKU,ZTEM2D)
+ ENDIF !kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk
+ ENDIF !llllllllllllllllllllllllllllllllll
+
+
+
+!!!!!!!!!!Octobre 2001
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ DEALLOCATE(ZTEM2D,ZWORKT)
+!!!!!!!!!!Octobre 2001
+ IF(ALLOCATED(XTEM2D))THEN
+ DEALLOCATE(XTEM2D)
+ ENDIF
+ IF(ALLOCATED(XTEM2D2))THEN
+ DEALLOCATE(XTEM2D2)
+ ENDIF
+ LCOLPVT=.FALSE.
+
+!!!!!!!!!!Octobre 2001
+
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+ DEALLOCATE(ZTEM1D,ZWORKZ)
+ ELSE
+ ENDIF
+ ENDDO
+ ENDIF
+ NIINF=IINF;NISUP=ISUP;NJINF=IJINF;NJSUP=IJSUP
+ IF(NVERBIA > 0)THEN
+ print *,'NIINF,NISUP,NJINF,NJSUP ',NIINF,NISUP,NJINF,NJSUP
+ ENDIF
+
+!*****************************************************************************
+!*****************************************************************************
+ CASE('SSOL')
+!
+! ******************************************
+! Boucle externe sur les numeros de stations
+! ******************************************
+!
+ L1DT=.TRUE.
+ DO JLOOPN=1,NBNDIA(KLOOP)
+ NLOOPN=NNDIA(JLOOPN,KLOOP)
+
+ IF(LPVKT .AND. NSUPERDIA>1)THEN
+ IF(NBPROCDIA(KLOOP)>1 .OR. NBLVLKDIA(KLOOP,1)>1 &
+ .OR. NBNDIA(KLOOP)>1)THEN
+ print *,' _PVKT_ SUPERPOSITIONS : '
+ print *,' On ne peut definir de part de d''autre '&
+ &'de _ON_ qu''1 seul processus, 1 seul niveau, 1 seul masque'
+ print *,' Nb de niveaux demandes : ',NBLVLKDIA(KLOOP,1)
+ print *,' Nb de processus demandes : ',NBPROCDIA(KLOOP)
+ print *,' Nb de masques demandes : ',NBNDIA(KLOOP)
+ print *,' *** MODIFIEZ VOTRE DIRECTIVE *** '
+ EXIT
+ ENDIF
+ ENDIF
+ IK=SIZE(XVAR,3)
+ ALLOCATE(ZTEM1D(IK),ZWORKZ(IK))
+!
+! Controle ordre des niveaux demandes. Eventuellement remise dans l'ordre
+! croissant
+!
+ INBK=NBLVLKDIA(KLOOP,NLOOPN)
+ NKH=INBK
+ IF(INBK > 1)THEN
+ DO JLOOPK=1,INBK-1
+ INUMK=NLVLKDIA(JLOOPK,KLOOP,NLOOPN)
+ DO JLOOPK1=JLOOPK+1,INBK
+ INUMK1=NLVLKDIA(JLOOPK1,KLOOP,NLOOPN)
+ IF(INUMK < INUMK1)THEN
+ CYCLE
+ ELSE
+ NLVLKDIA(JLOOPK,KLOOP,NLOOPN)=INUMK1
+ NLVLKDIA(JLOOPK1,KLOOP,NLOOPN)=INUMK
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+!
+! Altitudes enregistees du niv 1 a n dans l'ordre croissant --> GINVZ=.FALSE.
+! Altitudes enregistees du niv n a 1 dans l'ordre decroissant --> GINVZ=.TRUE.
+!
+ IF(XTRAJZ(NLVLKDIA(1,KLOOP,NLOOPN),1,NNDIA(JLOOPN,KLOOP)) < &
+ XTRAJZ(NLVLKDIA(INBK,KLOOP,NLOOPN),1,NNDIA(JLOOPN,KLOOP)))THEN
+ GINVZ=.FALSE.
+ ELSE
+ GINVZ=.TRUE.
+! Remise des niveaux dans un ordre tel que les altitudes soient croissantes
+! (/indices croissants)
+ NLVLKDIA(1:INBK,KLOOP,NLOOPN)=NLVLKDIA(INBK:1:-1,KLOOP,NLOOPN)
+ ENDIF
+
+!
+! ************************
+! Boucle sur les processus
+! ************************
+!
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+
+ CALL LOADUNITIT(JLOOPP,KLOOP)
+
+ ZTEM1D(:)=0.; ZWORKZ(:)=0.
+
+ INDN=NNDIA(JLOOPN,KLOOP)
+
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN !----------------------- Tps
+!
+! Expression temps non incrementale
+!
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ZTEM1D(1:IK)=XVAR(1,1,: &
+ ,NTIMEDIA(JLOOPT,KLOOP,1),NNDIA(JLOOPN,KLOOP),NPROCDIA(JLOOPP,KLOOP))
+ ZWORKZ(:)=XTRAJZ(:,1,NNDIA(JLOOPN,KLOOP))
+
+
+ IF(LPV)THEN !---LPV(KT)(1)-----
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+! PENSER A EXTRAIRE LES DIFFERENTS NIVEAUX
+
+ ALLOCATE(ZTE(INBK),ZWO(INBK))
+
+ DO JLOOPK=1,NBLVLKDIA(KLOOP,NLOOPN)
+ ZTE(JLOOPK)=ZTEM1D(NLVLKDIA(JLOOPK,KLOOP,NLOOPN))
+ ZWO(JLOOPK)=ZWORKZ(NLVLKDIA(JLOOPK,KLOOP,NLOOPN))
+ ENDDO
+ DEALLOCATE(ZTEM1D,ZWORKZ)
+ ALLOCATE(ZTEM1D(SIZE(ZTE)))
+ ALLOCATE(ZWORKZ(SIZE(ZWO)))
+ ZTEM1D=ZTE; ZWORKZ=ZWO
+ DEALLOCATE(ZTE,ZWO)
+
+ CALL TRAPRO_FORDIACHRO(ZTEM1D,ZWORKZ,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+
+ ELSE IF(LPVT .OR. LPVKT .OR. LPVKT1)THEN !---LPV(KT)(1)-----
+
+ IF(JLOOPT == 1)THEN
+ ILENW=NBTIMEDIA(KLOOP,1)
+ ALLOCATE(ZTEM2D(1:IK,ILENW))
+ ZTEM2D=XSPVAL
+ ALLOCATE(ZWORKT(ILENW))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(JLOOPT)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ ZTEM2D(1:IK,JLOOPT)= &
+ XVAR(1,1,:, &
+ NTIMEDIA(JLOOPT,KLOOP,1),NNDIA(JLOOPN,KLOOP), &
+ NPROCDIA(JLOOPP,KLOOP))
+
+ IF(JLOOPT == NBTIMEDIA(KLOOP,1))THEN
+! PENSER A EXTRAIRE LES DIFFERENTS NIVEAUX
+
+ IF(ALLOCATED(XZSOL))THEN
+ DEALLOCATE(XZSOL)
+ ENDIF
+ ALLOCATE(ZTE2(INBK,ILENW),XZSOL(INBK))
+
+ DO JLOOPK=1,NBLVLKDIA(KLOOP,NLOOPN)
+ ZTE2(JLOOPK,:)=ZTEM2D(NLVLKDIA(JLOOPK,KLOOP,NLOOPN),:)
+ XZSOL(JLOOPK)=XTRAJZ(NLVLKDIA(JLOOPK,KLOOP,NLOOPN),1, &
+ NNDIA(JLOOPN,KLOOP))
+ ENDDO
+
+ DEALLOCATE(ZTEM2D)
+ ALLOCATE(ZTEM2D(SIZE(ZTE2,1),SIZE(ZTE2,2)))
+ ZTEM2D=ZTE2
+ DEALLOCATE(ZTE2)
+
+ XPVMIN=MINVAL(ZTEM2D)
+ XPVMAX=MAXVAL(ZTEM2D)
+ CALL VALMNMX(XPVMIN,XPVMAX)
+
+ IF(ABS(XPVMAX-XPVMIN) < 1.E-4)THEN
+ XPVMIN=XPVMIN-1.
+ XPVMAX=XPVMAX+1.
+ ENDIF
+
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ DEALLOCATE(ZTEM2D,ZWORKT)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDIF
+ ENDIF
+
+ ENDIF !---LPV(KT)(1)-----
+
+ ENDDO ! Fin Boucle Temps (Non incremental)
+
+ ELSE !----------------------- Tps
+
+! Expression temps incrementale
+
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+ CALL RESOLV_TIMES(JLOOPT)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(JLOOPT,1)
+ ZTEM1D(1:IK)=XVAR(1,1,: &
+ ,JLOOPT,INDN,NPROCDIA(JLOOPP,KLOOP))
+ ZWORKZ(:)=XTRAJZ(:,1,INDN)
+
+ IF(LPV)THEN !---LPV(KT)(1)-----
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,1))
+ CALL LOAD_XPRDAT(1,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+! PENSER A EXTRAIRE LES DIFFERENTS NIVEAUX
+
+ ALLOCATE(ZTE(INBK),ZWO(INBK))
+
+ DO JLOOPK=1,NBLVLKDIA(KLOOP,NLOOPN)
+ ZTE(JLOOPK)=ZTEM1D(NLVLKDIA(JLOOPK,KLOOP,NLOOPN))
+ ZWO(JLOOPK)=ZWORKZ(NLVLKDIA(JLOOPK,KLOOP,NLOOPN))
+ ENDDO
+
+ DEALLOCATE(ZTEM1D,ZWORKZ)
+ ALLOCATE(ZTEM1D(SIZE(ZTE)))
+ ALLOCATE(ZWORKZ(SIZE(ZWO)))
+ ZTEM1D=ZTE; ZWORKZ=ZWO
+ DEALLOCATE(ZTE,ZWO)
+
+ CALL TRAPRO_FORDIACHRO(ZTEM1D,ZWORKZ,KLOOP)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+
+ ELSE IF(LPVT .OR. LPVKT .OR.LPVKT1)THEN !---LPV(KT)(1)-----
+
+ IF(JLOOPT == NTIMEDIA(1,KLOOP,1))THEN
+ ILENW=(NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/NTIMEDIA(3,KLOOP,1) +1
+ IF(NVERBIA > 0)THEN
+ print *,' OPER NTIMEDIA(2,KLOOP,1) NTIMEDIA(1,KLOOP,1) NTIMEDIA(3,KLOOP,1) ILENW ', &
+ NTIMEDIA(2,KLOOP,1),NTIMEDIA(1,KLOOP,1),NTIMEDIA(3,KLOOP,1), &
+ ILENW, &
+ XTIMEDIA(2,KLOOP,1),XTIMEDIA(1,KLOOP,1),XTIMEDIA(3,KLOOP,1)
+ ENDIF
+ ITIMEND=NTIMEDIA(1,KLOOP,1) + &
+ (((NTIMEDIA(2,KLOOP,1)-NTIMEDIA(1,KLOOP,1))/ &
+ NTIMEDIA(3,KLOOP,1))*NTIMEDIA(3,KLOOP,1))
+ if(nverbia > 0)then
+ print *,' ITIMEND B ',ITIMEND
+ endif
+ IF(ALLOCATED(ZTEM2D))THEN
+ DEALLOCATE(ZTEM2D)
+ ENDIF
+ ALLOCATE(ZTEM2D(1:IK,ILENW))
+ ZTEM2D=XSPVAL
+ IF(ALLOCATED(ZWORKT))THEN
+ DEALLOCATE(ZWORKT)
+ ENDIF
+ ALLOCATE(ZWORKT(ILENW))
+ IJLT=0
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(IJLT)=XTRAJT(JLOOPT,1)
+ ZTEM2D(1:IK,IJLT)= &
+ XVAR(1,1,:, &
+ JLOOPT,INDN,NPROCDIA(JLOOPP,KLOOP))
+
+! IF(JLOOPT == NTIMEDIA(2,KLOOP,1))THEN
+ IF(JLOOPT == ITIMEND)THEN
+! PENSER A EXTRAIRE LES DIFFERENTS NIVEAUX
+
+ IF(ALLOCATED(XZSOL))THEN
+ DEALLOCATE(XZSOL)
+ ENDIF
+ IF(ALLOCATED(ZTE2))THEN
+ DEALLOCATE(ZTE2)
+ ENDIF
+ ALLOCATE(ZTE2(INBK,ILENW),XZSOL(INBK))
+
+ DO JLOOPK=1,NBLVLKDIA(KLOOP,NLOOPN)
+ ZTE2(JLOOPK,:)=ZTEM2D(NLVLKDIA(JLOOPK,KLOOP,NLOOPN),:)
+ XZSOL(JLOOPK)=XTRAJZ(NLVLKDIA(JLOOPK,KLOOP,NLOOPN),1, &
+ NNDIA(JLOOPN,KLOOP))
+ ENDDO
+
+ DEALLOCATE(ZTEM2D)
+ ALLOCATE(ZTEM2D(SIZE(ZTE2,1),SIZE(ZTE2,2)))
+ ZTEM2D=ZTE2
+ DEALLOCATE(ZTE2)
+ XPVMIN=MINVAL(ZTEM2D)
+ XPVMAX=MAXVAL(ZTEM2D)
+ CALL VALMNMX(XPVMIN,XPVMAX)
+
+ IF(ABS(XPVMAX-XPVMIN) < 1.E-4)THEN
+ XPVMIN=XPVMIN-1.
+ XPVMAX=XPVMAX+1.
+ ENDIF
+
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ DEALLOCATE(ZTEM2D,ZWORKT)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDIF
+
+ ENDIF
+
+ ENDIF !---LPV(KT)(1)-----
+
+ ENDDO ! Fin Boucle Temps (Incremental)
+
+ ENDIF !----------------------- Tps
+
+ ENDDO ! Fin Boucle Processus
+
+ DEALLOCATE(ZTEM1D,ZWORKZ)
+
+ ENDDO ! Fin Boucle Num station
+
+
+
+!*****************************************************************************
+!*****************************************************************************
+ CASE('SPXY')
+
+ if(nverbia > 0)then
+ print *,' **oper AV SUBSPXY '
+ ENDIF
+ CALL SUBSPXY(KLOOP)
+ if(nverbia > 0)then
+ print *,' **oper AP SUBSPXY '
+ ENDIF
+!*****************************************************************************
+!*****************************************************************************
+ CASE('DRST','RAPL')
+
+ L1DT=.TRUE.
+ DO JLOOPN=1,NBNDIA(KLOOP)
+
+ NLOOPN=NNDIA(JLOOPN,KLOOP)
+
+! Controle ordre des niveaux demandes. Eventuellement remise dans l'ordre
+! croissant pour verifier si les altitudes sont en ordre croissant ou
+! decroissant (/aux indices croissant)
+!
+ INBK=NBLVLKDIA(KLOOP,NLOOPN)
+ NKH=INBK
+ IF(INBK > 1)THEN
+ DO JLOOPK=1,INBK-1
+ INUMK=NLVLKDIA(JLOOPK,KLOOP,NLOOPN)
+ DO JLOOPK1=JLOOPK+1,INBK
+ INUMK1=NLVLKDIA(JLOOPK1,KLOOP,NLOOPN)
+ IF(INUMK < INUMK1)THEN
+ CYCLE
+ ELSE
+ NLVLKDIA(JLOOPK,KLOOP,NLOOPN)=INUMK1
+ NLVLKDIA(JLOOPK1,KLOOP,NLOOPN)=INUMK
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDIF
+ !
+ ! Altitudes enregistees du niv 1 a n dans l'ordre croissant --> GINVZ=.FALSE.
+ ! Altitudes enregistees du niv n a 1 dans l'ordre decroissant --> GINVZ=.TRUE.
+ !
+ IF(XTRAJZ(NLVLKDIA(1,KLOOP,NLOOPN),1,NNDIA(JLOOPN,KLOOP)) < &
+ XTRAJZ(NLVLKDIA(INBK,KLOOP,NLOOPN),1,NNDIA(JLOOPN,KLOOP)))THEN
+ GINVZ=.FALSE.
+ ELSE
+ GINVZ=.TRUE.
+! Remise des niveaux dans un ordre tel que les altitudes soient croissantes
+ NLVLKDIA(1:INBK,KLOOP,NLOOPN)=NLVLKDIA(INBK:1:-1,KLOOP,NLOOPN)
+ ENDIF
+
+!
+
+ IF(.NOT.LTINCRDIA(KLOOP,NLOOPN))THEN
+ ILENW=NBTIMEDIA(KLOOP,NLOOPN)
+ ELSE
+ ILENW=(NTIMEDIA(2,KLOOP,NLOOPN)-NTIMEDIA(1,KLOOP,NLOOPN))/ &
+ NTIMEDIA(3,KLOOP,NLOOPN)+1
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(LZT .OR. LPV .OR. LPVT .OR. LPVKT .OR. LPVKT1)THEN
+
+
+ IF(LZT)THEN
+ LPVKT1=.TRUE.
+ JLOOPPF=1
+ ELSE
+ JLOOPPF=NBPROCDIA(KLOOP)
+ ENDIF
+
+! Boucle sur les processus
+
+ DO JLOOPP = 1,JLOOPPF
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+ if(nverbia >0)then
+ print *, '***OPEROPER NLOOPP,JLOOPPF ', NLOOPP,JLOOPPF
+ endif
+
+ CALL LATLONGRID
+
+ IK=NBLVLKDIA(KLOOP,NLOOPN)
+ ALLOCATE (ZTEM2D(1:IK,ILENW),ZWORKT(ILENW),ZWORKZ(IK))
+ IJLT=0
+
+ IF(LZT)THEN
+ CTITGAL='Altitude'
+ CUNITGAL='(M)'
+ ELSE
+ CTITGAL=ADJUSTL(CTITRE(NPROCDIA(JLOOPP,KLOOP)))
+ CUNITGAL=ADJUSTL(CUNITE(NPROCDIA(JLOOPP,KLOOP)))
+ ENDIF
+ CTITGAL=ADJUSTL(CTITGAL)
+ CUNITGAL=ADJUSTL(CUNITGAL)
+ CUNITGAL(INDEX(CUNITGAL,' '):LEN(CUNITGAL))=' '
+ !
+
+ IF(.NOT.LTINCRDIA(KLOOP,NLOOPN))THEN
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,NLOOPN)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,NLOOPN)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,NLOOPN)
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,NLOOPN))
+ ZWORKT(JLOOPT)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,NLOOPN), &
+ NLOOPN)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NTIMEDIA(JLOOPT,KLOOP,NLOOPN), &
+ NLOOPN)
+ DO JLOOPK=1,NBLVLKDIA(KLOOP,NLOOPN)
+
+ IF(LZT)THEN
+
+ ZTEM2D(JLOOPK,JLOOPT)=XTRAJZ(NLVLKDIA(JLOOPK,KLOOP, &
+ NLOOPN),NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN)
+ ELSE
+ ZTEM2D(JLOOPK,JLOOPT)=XVAR(1,1,NLVLKDIA(JLOOPK, &
+ KLOOP, &
+ NLOOPN),NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN,NLOOPP)
+ if(nverbia > 0)then
+ print *,' **OPER modif JLOOPP en NLOOPPP '
+ endif
+!ERRJD NLOOPN),NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN,JLOOPP)
+ IF(LPV)THEN
+ ZWORKZ(JLOOPK)=XTRAJZ(NLVLKDIA(JLOOPK,KLOOP,NLOOPN), &
+ NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN)
+ ENDIF
+
+ ENDIF
+
+ ENDDO
+
+ IF(LPV)THEN
+ ALLOCATE(ZTEM1D(SIZE(ZTEM2D,1)))
+ ZTEM1D(:)=ZTEM2D(:,JLOOPT)
+ CALL TRAPRO_FORDIACHRO(ZTEM1D,ZWORKZ,KLOOP)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ DEALLOCATE(ZTEM1D)
+ ENDIF
+
+ ENDDO
+
+ ELSE
+
+ DO JLOOPT=NTIMEDIA(1,KLOOP,NLOOPN),NTIMEDIA(2,KLOOP, &
+ NLOOPN),NTIMEDIA(3,KLOOP,NLOOPN)
+ NLOOPT=JLOOPT
+
+ CALL RESOLV_TIMES(JLOOPT)
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,JLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ZWORKT(IJLT)=XTRAJT(JLOOPT,NLOOPN)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(JLOOPT,NLOOPN)
+
+ DO JLOOPK=1,NBLVLKDIA(KLOOP,NLOOPN)
+
+ IF(LZT)THEN
+ ZTEM2D(JLOOPK,IJLT)=XTRAJZ(NLVLKDIA(JLOOPK,KLOOP, &
+ NLOOPN),JLOOPT,NLOOPN)
+ ELSE
+ ZTEM2D(JLOOPK,IJLT)=XVAR(1,1,NLVLKDIA(JLOOPK,KLOOP,&
+ NLOOPN),JLOOPT,NLOOPN,NLOOPP)
+!ERRJD NLOOPN),JLOOPT,NLOOPN,JLOOPP)
+ IF(LPV)THEN
+ ZWORKZ(JLOOPK)=XTRAJZ(NLVLKDIA(JLOOPK,KLOOP,NLOOPN), &
+ JLOOPT,NLOOPN)
+ ENDIF
+ ENDIF
+
+ ENDDO
+
+ IF(LPV)THEN
+ ALLOCATE(ZTEM1D(SIZE(ZTEM2D,1)))
+ ZTEM1D(:)=ZTEM2D(:,IJLT)
+ CALL TRAPRO_FORDIACHRO(ZTEM1D,ZWORKZ,KLOOP)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ DEALLOCATE(ZTEM1D)
+ ENDIF
+
+ ENDDO
+
+ ENDIF
+
+ XPVMIN=MINVAL(ZTEM2D)
+ XPVMAX=MAXVAL(ZTEM2D)
+ CALL VALMNMX(XPVMIN,XPVMAX)
+
+ IF(ABS(XPVMAX-XPVMIN) < 1.E-4)THEN
+ XPVMIN=XPVMIN-1.
+ XPVMAX=XPVMAX+1.
+ ENDIF
+
+ IF(.NOT.LPV)THEN
+ CALL PVFCT(ZWORKT,ZTEM2D,KLOOP)
+ DEALLOCATE(ZTEM2D,ZWORKT)
+ IF(.NOT.LPBREAD)THEN
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDIF
+ ENDIF
+
+ IF(ALLOCATED(ZTEM2D))THEN
+ DEALLOCATE(ZTEM2D)
+ ENDIF
+ IF(ALLOCATED(ZWORKT))THEN
+ DEALLOCATE(ZWORKT)
+ ENDIF
+ IF(ALLOCATED(ZWORKZ))THEN
+ DEALLOCATE(ZWORKZ)
+ ENDIF
+
+ ENDDO ! Fin Boucle processus
+
+ ELSE IF(LZTPVKT1)THEN
+ ELSE IF(LXT .OR. LYT .OR. LXYDIA)THEN
+
+ ALLOCATE(ZWORKT(ILENW),ZWORKY(ILENW))
+ YTITX(1:LEN(YTITX))=' '
+ YTITY(1:LEN(YTITY))=' '
+ IJLT=0
+ ILOOPP=NLOOPP
+ NLOOPP=1
+ CALL LATLONGRID
+ NLOOPP=ILOOPP
+
+ IF(.NOT.LTINCRDIA(KLOOP,NLOOPN))THEN
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,NLOOPN)
+!! Octobre 2001
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,NLOOPN)
+!! Octobre 2001
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,NLOOPN)
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(LXT .OR. LYT)THEN
+ ZWORKT(JLOOPT)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN)
+ YTITX='TIME (sec)'
+ ELSE IF(LXYDIA)THEN
+ ZWORKT(JLOOPT)=XTRAJX(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN)
+
+ CALL CONV2XY(ZWORKT(JLOOPT), &
+ XTRAJY(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN),ZX,ZY,11)
+
+ YTITX='X'
+ ENDIF
+ YTITX=ADJUSTL(YTITX)
+
+ IF(LXT)THEN
+ ZWORKY(JLOOPT)=XTRAJX(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN)
+
+ CALL CONV2XY(ZWORKY(JLOOPT), &
+ XTRAJY(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN),ZX,ZY,11)
+
+ YTITY='X'
+ ELSE IF(LXYDIA .OR. LYT)THEN
+ ZWORKY(JLOOPT)=XTRAJY(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN)
+
+ CALL CONV2XY(XTRAJX(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN), &
+ ZWORKY(JLOOPT),ZX,ZY,22)
+! IF(LCONV2XY .AND. NLATLON /= 0)THEN
+! CALL SM_XYHAT_S(XLATORI,XLONORI, &
+! XTRAJX(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN),ZWORKY(JLOOPT),ZX,ZY)
+! ZWORKY(JLOOPT)=ZY
+! ENDIF
+ YTITY='Y'
+ ENDIF
+ YTITY=ADJUSTL(YTITY)
+
+ ENDDO
+
+ ZTIMED=XTRAJT(NTIMEDIA(1,KLOOP,NLOOPN),NLOOPN)
+ ZTIMEF=XTRAJT(NTIMEDIA(NBTIMEDIA(KLOOP,NLOOPN),KLOOP,NLOOPN),NLOOPN)
+
+ ELSE
+
+ DO JLOOPT=NTIMEDIA(1,KLOOP,NLOOPN),NTIMEDIA(2,KLOOP, &
+ NLOOPN),NTIMEDIA(3,KLOOP,NLOOPN)
+!! Octobre 2001
+ NLOOPT=JLOOPT
+!! Octobre 2001
+
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,JLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(LXT .OR. LYT)THEN
+ ZWORKT(IJLT)=XTRAJT(JLOOPT,NLOOPN)
+ YTITX='TIME (sec)'
+ ELSE IF(LXYDIA)THEN
+ ZWORKT(IJLT)=XTRAJX(1,JLOOPT,NLOOPN)
+ CALL CONV2XY(ZWORKT(IJLT), &
+ XTRAJY(1,JLOOPT,NLOOPN),ZX,ZY,11)
+! IF(LCONV2XY .AND. NLATLON /= 0)THEN
+! CALL SM_XYHAT_S(XLATORI,XLONORI,ZWORKT(IJLT), &
+! XTRAJY(1,JLOOPT,NLOOPN),ZX,ZY)
+! ZWORKT(IJLT)=ZX
+! ENDIF
+ YTITX='X'
+ ENDIF
+
+ IF(LXT)THEN
+ ZWORKY(IJLT)=XTRAJX(1,JLOOPT,NLOOPN)
+ CALL CONV2XY(ZWORKY(IJLT), &
+ XTRAJY(1,JLOOPT,NLOOPN),ZX,ZY,11)
+! IF(LCONV2XY .AND. NLATLON /= 0)THEN
+! CALL SM_XYHAT_S(XLATORI,XLONORI,ZWORKY(IJLT), &
+! XTRAJY(1,JLOOPT,NLOOPN),ZX,ZY)
+! ZWORKY(IJLT)=ZX
+! ENDIF
+ YTITY='X'
+ ELSE IF(LXYDIA .OR. LYT)THEN
+ ZWORKY(IJLT)=XTRAJY(1,JLOOPT,NLOOPN)
+ CALL CONV2XY(XTRAJX(1,JLOOPT,NLOOPN), &
+ ZWORKY(IJLT),ZX,ZY,22)
+! IF(LCONV2XY .AND. NLATLON /= 0)THEN
+! CALL SM_XYHAT_S(XLATORI,XLONORI, &
+! XTRAJX(1,JLOOPT,NLOOPN),ZWORKY(IJLT),ZX,ZY)
+! ZWORKY(IJLT)=ZY
+! ENDIF
+ YTITY='Y'
+ ENDIF
+
+ ENDDO
+
+ ZTIMED=XTRAJT(NTIMEDIA(1,KLOOP,NLOOPN),NLOOPN)
+ ZTIMEF=XTRAJT(NTIMEDIA(2,KLOOP,NLOOPN),NLOOPN)
+
+ ENDIF
+
+ CALL TRAXY(ZWORKT,ZWORKY,KLOOP,YTITX,YTITY,ZTIMED,ZTIMEF)
+
+ DEALLOCATE(ZWORKT,ZWORKY)
+ IF(KLOOP == NSUPERDIA)THEN
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ CALL FRAME
+ ENDIF
+
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ ENDDO ! Fin Boucle Numeros DRST
+
+!*****************************************************************************
+!*****************************************************************************
+ CASE('RSPL')
+
+ DO JLOOPN=1,NBNDIA(KLOOP)
+
+ NLOOPN=NNDIA(JLOOPN,KLOOP)
+
+! Traitement des RS
+! *****************
+ IF(LRS .OR. LRS1)THEN
+!
+! Cas LRS ou LRS1 et KLOOP = 1 --> Allocation de tableaux pour memoriser
+! les infos utiles
+!
+! LRS : pas de superpositions ; donc KLOOP=NSUPERDIA=1 . Boucle externe sur le
+! Num. des RS (que l'on peut ou non preciser dans les directives) . Boucle
+! interne sur les temps (que l'on peut ou non preciser) avant appel TSOUND.
+!
+! LRS1 : superpositions ; KLOOP varie . De part et d'autre de _ON_ on ne
+! donne qu'1 station . Donc JLOOPN tjrs = 1
+!
+ IF(.NOT.LTINCRDIA(KLOOP,NLOOPN))THEN
+ ILENW=NBTIMEDIA(KLOOP,NLOOPN)
+ ELSE
+ ILENW=(NTIMEDIA(2,KLOOP,NLOOPN)-NTIMEDIA(1,KLOOP,NLOOPN))/ &
+ NTIMEDIA(3,KLOOP,NLOOPN)+1
+ ENDIF
+
+ NST(KLOOP)=ILENW
+ IF(KLOOP == 1)THEN
+!
+! SIZE(XVAR,3) = normalement 1
+!
+ ALLOCATE(XTRS(SIZE(XVAR,3)*NSUPERDIA,ILENW))
+ ALLOCATE(XPRS(SIZE(XVAR,3)*NSUPERDIA,ILENW))
+ ALLOCATE(XURS(SIZE(XVAR,3)*NSUPERDIA,ILENW))
+ ALLOCATE(XVRS(SIZE(XVAR,3)*NSUPERDIA,ILENW))
+ ALLOCATE(XRVRS(SIZE(XVAR,3)*NSUPERDIA,ILENW))
+ ALLOCATE(XTIMRS2(SIZE(XVAR,3)*NSUPERDIA,ILENW))
+ ALLOCATE(NST(SIZE(XVAR,3)*NSUPERDIA))
+ ALLOCATE(NNST(SIZE(XVAR,3)*NSUPERDIA))
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ ENDIF
+
+ IF(KLOOP > 1 .AND. LRS1)THEN
+ IF(ILENW > SIZE(XTRS,2))THEN
+ ALLOCATE(ZWORKRS(SIZE(XTRS,1),SIZE(XTRS,2)))
+ ZWORKRS(:,:)=XTRS(:,:)
+ DEALLOCATE(XTRS)
+ ALLOCATE(XTRS(SIZE(ZWORKRS,1),ILENW))
+ XTRS(:,1:SIZE(ZWORKRS,2))=ZWORKRS(:,:)
+ DEALLOCATE(ZWORKRS)
+ ALLOCATE(ZWORKRS(SIZE(XPRS,1),SIZE(XPRS,2)))
+ ZWORKRS(:,:)=XPRS(:,:)
+ DEALLOCATE(XPRS)
+ ALLOCATE(XPRS(SIZE(ZWORKRS,1),ILENW))
+ XPRS(:,1:SIZE(ZWORKRS,2))=ZWORKRS(:,:)
+ DEALLOCATE(ZWORKRS)
+ ALLOCATE(ZWORKRS(SIZE(XURS,1),SIZE(XURS,2)))
+ ZWORKRS(:,:)=XURS(:,:)
+ DEALLOCATE(XURS)
+ ALLOCATE(XURS(SIZE(ZWORKRS,1),ILENW))
+ XURS(:,1:SIZE(ZWORKRS,2))=ZWORKRS(:,:)
+ DEALLOCATE(ZWORKRS)
+ ALLOCATE(ZWORKRS(SIZE(XVRS,1),SIZE(XVRS,2)))
+ ZWORKRS(:,:)=XVRS(:,:)
+ DEALLOCATE(XVRS)
+ ALLOCATE(XVRS(SIZE(ZWORKRS,1),ILENW))
+ XVRS(:,1:SIZE(ZWORKRS,2))=ZWORKRS(:,:)
+ DEALLOCATE(ZWORKRS)
+ ALLOCATE(ZWORKRS(SIZE(XRVRS,1),SIZE(XRVRS,2)))
+ ZWORKRS(:,:)=XRVRS(:,:)
+ DEALLOCATE(XRVRS)
+ ALLOCATE(XRVRS(SIZE(ZWORKRS,1),ILENW))
+ XRVRS(:,1:SIZE(ZWORKRS,2))=ZWORKRS(:,:)
+ DEALLOCATE(ZWORKRS)
+ ALLOCATE(ZWORKRS(SIZE(XTIMRS2,1),SIZE(XTIMRS2,2)))
+ ZWORKRS(:,:)=XTIMRS2(:,:)
+ DEALLOCATE(XTIMRS2)
+ ALLOCATE(XTIMRS2(SIZE(ZWORKRS,1),ILENW))
+ XTIMRS2(:,1:SIZE(ZWORKRS,2))=ZWORKRS(:,:)
+ DEALLOCATE(ZWORKRS)
+ ENDIF
+ ENDIF
+
+ NNST(KLOOP)=NLOOPN
+
+! Dans XVAR PROC1=TCelsius PROC2=PRES(Pls) PROC3=U PROC4=V PROC5=RCM
+
+ IF(.NOT.LTINCRDIA(KLOOP,NLOOPN))THEN
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,NLOOPN)
+
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,NLOOPN)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ XTRS(KLOOP,JLOOPT)=XVAR(1,1,1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN), &
+ NLOOPN,1)+XTT
+ XPRS(KLOOP,JLOOPT)=XVAR(1,1,1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN), &
+ NLOOPN,2)
+ XURS(KLOOP,JLOOPT)=XVAR(1,1,1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN), &
+ NLOOPN,3)
+ XVRS(KLOOP,JLOOPT)=XVAR(1,1,1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN), &
+ NLOOPN,4)
+ XRVRS(KLOOP,JLOOPT)=XVAR(1,1,1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),&
+ NLOOPN,5)
+ XTIMRS2(KLOOP,JLOOPT)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN)
+ ENDDO
+
+ ELSE
+
+ II=0
+ DO JLOOPT=NTIMEDIA(1,KLOOP,NLOOPN),NTIMEDIA(2,KLOOP,NLOOPN),NTIMEDIA(3,KLOOP,NLOOPN)
+!! Octobre 2001
+ NLOOPT=JLOOPT
+!! Octobre 2001
+ II=II+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(II,JLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ XTRS(KLOOP,II)=XVAR(1,1,1,JLOOPT,NLOOPN,1)+273.16
+ XPRS(KLOOP,II)=XVAR(1,1,1,JLOOPT,NLOOPN,2)
+ XTIMRS2(KLOOP,II)=XTRAJT(JLOOPT,NLOOPN)
+ XURS(KLOOP,II)=XVAR(1,1,1,JLOOPT,NLOOPN,3)
+ XVRS(KLOOP,II)=XVAR(1,1,1,JLOOPT,NLOOPN,4)
+ XRVRS(KLOOP,II)=XVAR(1,1,1,JLOOPT,NLOOPN,5)
+ ENDDO
+
+ ENDIF
+
+ GMXRAT=.TRUE.
+
+ CLEGEND(104:106)='U-V'
+! YTEXTE(1:5)='U-V'
+ WRITE(YTEXTE,'(''I='',I2,'' J='',I2)')NIRS,NJRS
+ CALL TABCOL_FORDIACHRO
+ CALL GSTXFP(-13,2)
+
+ IF(LRS)THEN
+
+ IF(.NOT.LTINCRDIA(KLOOP,NLOOPN))THEN
+ IF(NVERBIA > 0)THEN
+ print *,' KLOOP,LRS,JLOOPT,NTIMEDIA(1,KLOOP,NLOOPN) ', &
+ KLOOP,LRS,JLOOPT,NTIMEDIA(1,KLOOP,NLOOPN)
+ ENDIF
+ CALL RESOLV_TIMES(NTIMEDIA(1,KLOOP,NLOOPN))
+ ELSE
+ II=NTIMEDIA(1,KLOOP,NLOOPN)
+ CALL RESOLV_TIMES(II)
+ ENDIF
+! CTIMEC(S) est determine ds OPER pour LRS et ds TSOUND pour LRS1
+ CTIMECS(1:LEN(CTIMECS))=' '
+ CTIMECS(1:3)=' ('
+ WRITE(CTIMECS(4:11),'(F8.0)')XTIMRS2(1,1)
+ CTIMECS(LEN_TRIM(CTIMECS)+1:LEN_TRIM(CTIMECS)+1)='-'
+ YTEM(1:LEN(YTEM))=' '
+ WRITE(YTEM(1:8),'(F8.0)')XTIMRS2(1,ILENW)
+ YTEM=ADJUSTL(YTEM)
+ IN=LEN_TRIM(CTIMECS)
+ II=LEN_TRIM(YTEM)
+ IN=IN+1
+ CTIMECS(IN:IN+II-1)=YTEM(1:II)
+ IN=IN+1
+ CTIMECS(IN:IN+1)='s)'
+
+ GMXRAT=.TRUE.
+
+ DO J=1,SIZE(XRVRS,2)
+ IF(XRVRS(1,J) <=0.)print *,' No dew point line drawn as nil or' &
+ ,' negative water values were found'
+ ENDDO
+
+ CALL GSCLIP(0)
+ CALL TSOUND_FORDIACHRO(XPRS(1,:),XTRS(1,:), &
+ XRVRS(1,:),XURS(1,:), &
+ XVRS(1,:),SIZE(XPRS,2),CLEGEND,YTEXTE,GMXRAT,.TRUE.&
+ ,.FALSE.,.FALSE.)
+ CALL GSCLIP(1)
+ CALL FRAME
+
+ DEALLOCATE(XTRS,XPRS,XURS,XVRS,XRVRS,XTIMRS2,NST,NNST)
+
+ ELSE IF(LRS1 .AND. KLOOP == NSUPERDIA)THEN
+
+ GMXRAT=.TRUE.
+! On met la date courante du 1er temps demande de la 1ere superposition
+ CALL RESOLV_TIMES(NTIMEDIA(1,1,NLOOPN))
+ CALL GSCLIP(0)
+! Dans OPER on ne transmet que le 1er temps et les autres son charges dans
+! TSOUND
+ CALL TSOUND_FORDIACHRO(XPRS(1,:),XTRS(1,:), &
+ XRVRS(1,:),XURS(1,:), &
+ XVRS(1,:),NST(1),CLEGEND,YTEXTE,GMXRAT,.TRUE.&
+ ,.FALSE.,.FALSE.)
+ CALL GSCLIP(1)
+ CALL FRAME
+ DEALLOCATE(XTRS,XPRS,XURS,XVRS,XRVRS,XTIMRS2,NST,NNST)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ ENDIF
+
+! Infos autres que RS
+! *******************
+
+ ELSE
+
+ IF(.NOT.LTINCRDIA(KLOOP,NLOOPN))THEN
+ ILENW=NBTIMEDIA(KLOOP,NLOOPN)
+ ELSE
+ ILENW=(NTIMEDIA(2,KLOOP,NLOOPN)-NTIMEDIA(1,KLOOP,NLOOPN))/ &
+ NTIMEDIA(3,KLOOP,NLOOPN)+1
+ ENDIF
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ IF(ALLOCATED(XPRDAT))DEALLOCATE(XPRDAT)
+ ALLOCATE(XPRDAT(16,ILENW))
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(LFT .OR. LFT1)THEN
+
+ ALLOCATE(ZWORKT(ILENW),ZWORK1D(ILENW))
+
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+
+ CALL LATLONGRID
+
+ CTITGAL=ADJUSTL(CTITRE(NPROCDIA(JLOOPP,KLOOP)))
+ CUNITGAL=ADJUSTL(CUNITE(NPROCDIA(JLOOPP,KLOOP)))
+ CTITGAL=ADJUSTL(CTITGAL)
+ CUNITGAL=ADJUSTL(CUNITGAL)
+ CUNITGAL(INDEX(CUNITGAL,' '):LEN(CUNITGAL))=' '
+
+ IF(.NOT. LTINCRDIA(KLOOP,NLOOPN))THEN
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,NLOOPN)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,NLOOPN)
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(JLOOPT == 1)CALL RESOLV_TIMES(NLOOPT)
+ ZWORKT(JLOOPT)=XTRAJT(NLOOPT,NLOOPN)
+ ZWORK1D(JLOOPT)=XVAR(1,1,1,NLOOPT,NLOOPN,NPROCDIA(JLOOPP, &
+ KLOOP))
+ ENDDO
+ ELSE
+ IJLT=0
+ DO JLOOPT=NTIMEDIA(1,KLOOP,NLOOPN),NTIMEDIA(2,KLOOP,NLOOPN), &
+ NTIMEDIA(3,KLOOP,NLOOPN)
+ NLOOPT=JLOOPT
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(IJLT == 1)CALL RESOLV_TIMES(NLOOPT)
+ ZWORKT(IJLT)=XTRAJT(NLOOPT,NLOOPN)
+ ZWORK1D(IJLT)=XVAR(1,1,1,NLOOPT,NLOOPN,NPROCDIA(JLOOPP, &
+ KLOOP))
+ ENDDO
+
+ ENDIF
+
+ CALL VARFCT(ZWORKT,ZWORK1D,1)
+ if(nverbia > 0)then
+ print *,' ** oper RSPL AP VARFCT KLOOP NSUPERDIA ',KLOOP,&
+ NSUPERDIA
+ endif
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+
+ ENDDO
+
+ DEALLOCATE(ZWORKT,ZWORK1D)
+
+ ELSE IF(LZT .OR. LXT .OR. LYT .OR. LXYDIA)THEN
+
+ ALLOCATE(ZWORKT(ILENW),ZWORKY(ILENW))
+ YTITX(1:LEN(YTITX))=' '
+ YTITY(1:LEN(YTITY))=' '
+ IJLT=0
+
+ ILOOPP=NLOOPP
+ NLOOPP=1
+ CALL LATLONGRID
+ NLOOPP=ILOOPP
+
+ IF(.NOT.LTINCRDIA(KLOOP,NLOOPN))THEN
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,NLOOPN)
+!! Octobre 2001
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,NLOOPN)
+!! Octobre 2001
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,NLOOPN)
+ CALL LOAD_XPRDAT(JLOOPT,NLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+
+ IF(LZT .OR. LXT .OR. LYT)THEN
+ ZWORKT(JLOOPT)=XTRAJT(NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN)
+ YTITX='TIME (sec)'
+ ELSE IF(LXYDIA)THEN
+ ZWORKT(JLOOPT)=XTRAJX(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN)
+ IF(LCONV2XY .AND. NLATLON /= 0)THEN
+ CALL SM_XYHAT_S(XLATORI,XLONORI,ZWORKT(JLOOPT), &
+ XTRAJY(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN),&
+ ZX,ZY)
+ ZWORKT(JLOOPT)=ZX
+ ENDIF
+ YTITX='X'
+ ENDIF
+ YTITX=ADJUSTL(YTITX)
+
+ IF(LZT)THEN
+ ZWORKY(JLOOPT)=XTRAJZ(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN)
+ YTITY='Z'
+ ELSE IF(LXT)THEN
+ ZWORKY(JLOOPT)=XTRAJX(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN)
+ IF(LCONV2XY .AND. NLATLON /= 0)THEN
+ CALL SM_XYHAT_S(XLATORI,XLONORI,ZWORKY(JLOOPT), &
+ XTRAJY(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN),&
+ ZX,ZY)
+ ZWORKY(JLOOPT)=ZX
+ ENDIF
+ YTITY='X'
+ ELSE IF(LXYDIA .OR. LYT)THEN
+ ZWORKY(JLOOPT)=XTRAJY(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN)
+ IF(LCONV2XY .AND. NLATLON /= 0)THEN
+ CALL SM_XYHAT_S(XLATORI,XLONORI, &
+ XTRAJX(1,NTIMEDIA(JLOOPT,KLOOP,NLOOPN),NLOOPN),ZWORKY(JLOOPT),&
+ ZX,ZY)
+ ZWORKY(JLOOPT)=ZY
+ ENDIF
+ YTITY='Y'
+ ENDIF
+ YTITY=ADJUSTL(YTITY)
+
+ ENDDO
+
+ ZTIMED=XTRAJT(NTIMEDIA(1,KLOOP,NLOOPN),NLOOPN)
+ ZTIMEF=XTRAJT(NTIMEDIA(NBTIMEDIA(KLOOP,NLOOPN),KLOOP,NLOOPN),NLOOPN)
+
+ ELSE
+
+ DO JLOOPT=NTIMEDIA(1,KLOOP,NLOOPN),NTIMEDIA(2,KLOOP, &
+ NLOOPN),NTIMEDIA(3,KLOOP,NLOOPN)
+
+!! Octobre 2001
+ NLOOPT=JLOOPT
+!! Octobre 2001
+ IJLT=IJLT+1
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ CALL LOAD_XPRDAT(IJLT,JLOOPT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ IF(LZT .OR. LXT .OR. LYT)THEN
+ ZWORKT(IJLT)=XTRAJT(JLOOPT,NLOOPN)
+ YTITX='TIME (sec)'
+ ELSE IF(LXYDIA)THEN
+ ZWORKT(IJLT)=XTRAJX(1,JLOOPT,NLOOPN)
+ IF(LCONV2XY .AND. NLATLON /= 0)THEN
+ CALL SM_XYHAT_S(XLATORI,XLONORI,ZWORKT(IJLT), &
+ XTRAJY(1,JLOOPT,NLOOPN),ZX,ZY)
+ ZWORKT(IJLT)=ZX
+ ENDIF
+ YTITX='X'
+ ENDIF
+ YTITX=ADJUSTL(YTITX)
+
+ IF(LZT)THEN
+ ZWORKY(IJLT)=XTRAJZ(1,JLOOPT,NLOOPN)
+ YTITY='Z'
+ ELSE IF(LXT)THEN
+ ZWORKY(IJLT)=XTRAJX(1,JLOOPT,NLOOPN)
+ IF(LCONV2XY .AND. NLATLON /= 0)THEN
+ CALL SM_XYHAT_S(XLATORI,XLONORI,ZWORKY(IJLT), &
+ XTRAJY(1,JLOOPT,NLOOPN),ZX,ZY)
+ ZWORKY(IJLT)=ZX
+ ENDIF
+ YTITY='X'
+ ELSE IF(LXYDIA .OR. LYT)THEN
+ ZWORKY(IJLT)=XTRAJY(1,JLOOPT,NLOOPN)
+ IF(LCONV2XY .AND. NLATLON /= 0)THEN
+ CALL SM_XYHAT_S(XLATORI,XLONORI, &
+ XTRAJX(1,JLOOPT,NLOOPN),ZWORKY(IJLT),ZX,ZY)
+ ZWORKY(IJLT)=ZY
+ ENDIF
+ YTITY='Y'
+ ENDIF
+ YTITY=ADJUSTL(YTITY)
+
+ ENDDO
+
+ ZTIMED=XTRAJT(NTIMEDIA(1,KLOOP,NLOOPN),NLOOPN)
+ ZTIMEF=XTRAJT(NTIMEDIA(2,KLOOP,NLOOPN),NLOOPN)
+
+ ENDIF
+
+ CALL TRAXY(ZWORKT,ZWORKY,KLOOP,YTITX,YTITY,ZTIMED,ZTIMEF)
+ if(nverbia > 0)then
+ print *,' ** oper RSPL AP TRAXY KLOOP NSUPERDIA ',KLOOP,&
+ NSUPERDIA
+ endif
+
+ DEALLOCATE(ZWORKT,ZWORKY)
+ IF(KLOOP == NSUPERDIA)THEN
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ CALL FRAME
+ ENDIF
+
+ ENDIF
+
+ IF(LPRDAT)THEN ! Juin 2001 Ajout des dates ds FICVAL
+ DEALLOCATE(XPRDAT)
+ ENDIF ! Juin 2001 Ajout des dates ds FICVAL
+ ENDIF
+
+ ENDDO ! Fin boucle N. RS ou avions
+
+!*****************************************************************************
+!*****************************************************************************
+! CASE('RAPL')
+
+
+END SELECT
+
+IF(ALLOCATED(ZWORK3D))THEN
+ DEALLOCATE(ZWORK3D)
+ENDIF
+IF(ALLOCATED(ZWORK1D))THEN
+ DEALLOCATE(ZWORK1D)
+ENDIF
+IF(ALLOCATED(ZWORKT))THEN
+ DEALLOCATE(ZWORKT)
+ENDIF
+IF(ALLOCATED(ZWORKZ))THEN
+ DEALLOCATE(ZWORKZ)
+ENDIF
+IF(ALLOCATED(ZWORKZ2))THEN
+ DEALLOCATE(ZWORKZ2)
+ENDIF
+IF(ALLOCATED(ZWORKRS))THEN
+ DEALLOCATE(ZWORKRS)
+ENDIF
+IF(ALLOCATED(ZWORKY))THEN
+ DEALLOCATE(ZWORKY)
+ENDIF
+IF(ALLOCATED(ZTEMCV))THEN
+ DEALLOCATE(ZTEMCV)
+ENDIF
+IF(ALLOCATED(ZTEM2D))THEN
+ DEALLOCATE(ZTEM2D)
+ENDIF
+IF(ALLOCATED(ZTEM1D))THEN
+ DEALLOCATE(ZTEM1D)
+ENDIF
+IF(ALLOCATED(ZTE))THEN
+ DEALLOCATE(ZTE)
+ENDIF
+IF(ALLOCATED(ZTE2))THEN
+ DEALLOCATE(ZTE2)
+ENDIF
+IF(ALLOCATED(ZWO))THEN
+ DEALLOCATE(ZWO)
+ENDIF
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+if(nverbia > 0)then
+ print *,' **oper sortie LPRESY,XHMIN,XHMAX ',LPRESY,XHMIN,XHMAX
+endif
+RETURN
+END SUBROUTINE OPER_PROCESS
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/precou_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/precou_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0b605580fba7ee54cf48fba9043bd65c516c37bd
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/precou_fordiachro.f90
@@ -0,0 +1,651 @@
+! ######spl
+ MODULE MODI_PRECOU_FORDIACHRO
+! #############################
+!
+INTERFACE
+!
+SUBROUTINE PRECOU_FORDIACHRO(PWORK3D,PTEMCV)
+REAL,DIMENSION(:,:,:) :: PWORK3D
+REAL,DIMENSION(:,:) :: PTEMCV
+END SUBROUTINE PRECOU_FORDIACHRO
+!
+END INTERFACE
+!
+END MODULE MODI_PRECOU_FORDIACHRO
+
+ SUBROUTINE PRECOU_FORDIACHRO(PWORK3D,PTEMCV)
+! ############################################
+!
+!!**** *PRECOU_FORDIACHRO* - Preliminary calculation for vertical cross-sections of
+!!**** basis set prognostic Meso-NH variables
+!!
+!! PURPOSE
+!! -------
+!!
+! When a verical cross-section is requested, this routine allocates
+! 2D work arrays to to store the interpolated fields produced by the
+! COUPE routine.
+!
+!!** METHOD
+!! ------
+!! Array allocation and call to the COUPE vertical plane interpolator
+!!
+!! WARNING: This program section is exceptionally boring,
+!! I fell asleep twice updating it.
+!!
+!! EXTERNAL
+!! --------
+!! COUPE : interpolates the model data onto the vertical
+!! cross-section plane requested by the user.
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODN_PARA: Defines NAM_DOMAIN_POS namelist (former PARA common)
+!! NLMAX : Number of points horizontally along
+!! the vertical section
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NKMAX : z array dimension
+!!
+!! Module MODD_CVERT: Declares work arrays for vertical cross-sections
+!! XWORKZ : working array for true altitude storage (all grids)
+!! XWZ : working array for topography (all grids)
+!!
+!! Module MODD_OUT : Defines a log. unit for printing
+!! NIMAXT : Size of the displayed window within a
+!! NJMAXT : MESO-NH field arrays
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!! JPVEXT : Vertical external points number
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 15/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+! modules MesoNH
+USE MODD_CONF, ONLY: L2D
+USE MODD_DIM1, ONLY: NIMAX,NJMAX,NKMAX,NIINF,NISUP,NJINF,NJSUP
+USE MODD_GRID1, ONLY: XZZ
+! modules diaprog
+USE MODN_PARA
+USE MODD_TYPE_AND_LH
+USE MODD_NMGRID
+USE MODN_NCAR
+USE MODD_CVERT
+USE MODD_NMGRID
+USE MODD_PARAMETERS
+USE MODD_RESOLVCAR
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_PVT
+USE MODD_MEMGRIUV
+USE MODI_COMPUTEDIR
+
+IMPLICIT NONE
+!
+!* 0.1 Interface declarations
+!
+INTERFACE
+ SUBROUTINE COUPE_FORDIACHRO(PTABI,PTABO,K)
+ REAL,DIMENSION(:,:) :: PTABI
+ REAL,DIMENSION(:) :: PTABO
+ INTEGER :: K
+ END SUBROUTINE COUPE_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE ROTA(PTEM1,PTEMV)
+ REAL, DIMENSION(:,:), INTENT(INOUT) :: PTEM1
+ REAL, DIMENSION(:,:), INTENT(INOUT) :: PTEMV
+ END SUBROUTINE ROTA
+END INTERFACE
+INTERFACE
+ SUBROUTINE COUPEUW_FORDIACHRO(PTABI,PTABO,K,KCOMP)
+ REAL,DIMENSION(:,:) :: PTABI
+ REAL,DIMENSION(:) :: PTABO
+ INTEGER :: K
+ INTEGER :: KCOMP
+ END SUBROUTINE COUPEUW_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE ROTAUW(PTEM1,PTEMV)
+ REAL, DIMENSION(:), INTENT(INOUT) :: PTEM1
+ REAL, DIMENSION(:), INTENT(INOUT) :: PTEMV
+ END SUBROUTINE ROTAUW
+END INTERFACE
+!
+COMMON/TEMH/XZZX,XZZY,NIIMAX,NIJMAX
+#include "big.h"
+REAL,DIMENSION(N2DVERTX) :: XZZX
+REAL,DIMENSION(N2DVERTX) :: XZZY
+INTEGER :: NIIMAX, NIJMAX
+
+!
+!* 0.12 Dummy arguments
+!
+REAL,DIMENSION(:,:,:) :: PWORK3D
+REAL,DIMENSION(:,:) :: PTEMCV
+!
+!* 0.2 Local variables
+!
+INTEGER :: IIU,IJU,IKU, JKLOOP, IKB, IKE, IWKU
+INTEGER :: IUI, IUJ
+INTEGER :: ITER, JTER, IUB1, IUB2, ISKIP
+INTEGER,SAVE :: IPRESM, ITPRESY
+!
+!
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: ZWORK3D, ZWORK3W
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZTEM1, ZTEMV, ZTEMW
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZTEM2, ZTEMVR, ZTEMWR
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZX
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZZY
+!
+!-----------------------------------------------------------------------------
+!
+!* 1. SETS ARRAY SIZES AND ALLOCATES ARRAYS
+! -------------------------------------
+!
+IIU=NIMAX+2*JPHEXT
+IJU=NJMAX+2*JPHEXT
+IKU=NKMAX+2*JPVEXT
+IKB=1+JPVEXT
+IKE=IKU-JPVEXT
+IWKU=SIZE(PWORK3D,3)
+!
+! Dedicated work arrays for vertical cross sections; last index is
+! NMGRID grid selector.
+! XWORZ contains true altitudes, for all grids
+! XWZ contains topography, for all grids
+!
+if(nverbia > 0)then
+ print *,' **precou IKU AV ALLOCATE(XWORKZ NLMAX ',IKU,NLMAX
+endif
+IF(ALLOCATED(XWORKZ))THEN
+ IF (SIZE(XWORKZ,1) /= NLMAX)THEN
+ DEALLOCATE(XWORKZ)
+ ALLOCATE(XWORKZ(NLMAX,IKU,7))
+ ENDIF
+ELSEIF(.NOT.ALLOCATED(XWORKZ))THEN
+!ELSE
+ ALLOCATE(XWORKZ(NLMAX,IKU,7))
+if(nverbia > 0)then
+ print *,' **precou IKU AP ALLOCATE(XWORKZ NLMAX ',IKU,NLMAX
+endif
+ENDIF
+if(nverbia > 0)then
+ print *,' **precou IKU AV ALLOCATE(XWZ NLMAX ',IKU,NLMAX
+! print *,' **precou ALLOCATE(XWZ size(XWZ,1)et 2 ',size(XWZ,1),size(XWZ,2)
+endif
+IF(ALLOCATED(XWZ))THEN
+ IF(SIZE(XWZ,1) /= NLMAX)THEN
+ DEALLOCATE(XWZ)
+ ALLOCATE(XWZ(NLMAX,7))
+ ENDIF
+ELSE IF(.NOT.ALLOCATED(XWZ))THEN
+ ALLOCATE(XWZ(NLMAX,7))
+ENDIF
+! Oct 2000 prise en compte PH issus du 2D horiz.
+! Volontairement place apres ALLOCATE XWORKZ sinon pb
+IF(IWKU == 1)THEN
+ IKB=1; IKE=1; IKU=1
+if(nverbia > 0)then
+ print *,' **precou IKU AP ALLOCATE(XWORKZ NLMAX ',IKU,NLMAX
+ print *,' **precou sizePTEMCV ',size(PTEMCV,1),size(PTEMCV,2)
+endif
+ENDIF
+!
+! Local work arrays
+!
+ALLOCATE(ZTEM1(1:IIU,1:IJU))
+!ALLOCATE(ZTEM1(1:NIH-NIL+1,1:NJH-NJL+1))
+ALLOCATE(ZTEM2(NLMAX))
+! Janvier 2001 + LDIRWIND et LUMVM et LUTVT et LSUMVM et LSUTVT
+IF(LULM .OR. LULT .OR.LVTM .OR. LVTT .OR. LULMWM .OR. LULTWT .OR. &
+ LMUMVM .OR. LMUTVT .OR. LMLSUMVM .OR. LMLSUTVT .OR. LDIRWIND .OR. &
+ !LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT)THEN
+ LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. &
+ (LDIRWT .AND. .NOT.LDIRWIND).OR.(LDIRWM .AND. .NOT.LDIRWIND) )THEN
+ ALLOCATE(ZWORK3D(SIZE(PWORK3D,1),SIZE(PWORK3D,2),SIZE(PWORK3D,3)))
+ ALLOCATE(ZTEMV(1:IIU,1:IJU))
+ENDIF
+IF(LULMWM .OR. LULTWT)THEN
+ ALLOCATE(ZWORK3W(SIZE(PWORK3D,1),SIZE(PWORK3D,2),SIZE(PWORK3D,3)))
+ ALLOCATE(ZTEMW(1:IIU,1:IJU))
+ ALLOCATE(ZTEMVR(NLMAX),ZTEMWR(NLMAX))
+ IF(ALLOCATED(XWCV))DEALLOCATE(XWCV)
+ ALLOCATE(XWCV(SIZE(PTEMCV,1),SIZE(PTEMCV,2)))
+ENDIF
+! Janvier 2001 + LDIRWIND et LUMVM et LUTVT et LSUMVM et LSUTVT
+!IF(LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. LDIRWIND)THEN
+IF(LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. LDIRWIND .OR. &
+ (LDIRWT .AND. .NOT.LDIRWIND).OR.(LDIRWM .AND. .NOT.LDIRWIND) )THEN
+ ALLOCATE(ZTEMVR(NLMAX))
+ IF(ALLOCATED(XWCV))DEALLOCATE(XWCV)
+ ALLOCATE(XWCV(SIZE(PTEMCV,1),SIZE(PTEMCV,2)))
+ENDIF
+!
+!------------------------------------------------------------------------------
+
+XWORKZ(:,:,:)=0.
+XWZ(:,:)=0.
+PTEMCV=XSPVAL
+IF(ALLOCATED(XWCV))THEN
+ XWCV=XSPVAL
+ENDIF
+!
+!* 2. GETS VERTICAL CROSS-SECTION DATA THROUGH INTERPOLTATION
+! -------------------------------------------------------
+! Prise en compte du 2D horizontal NON je prefere allouer correctement XWORKZ
+!IF(IKU /= 1)THEN
+CALL COMPCOORD_FORDIACHRO(NMGRID)
+!ENDIF
+IF(NVERBIA > 0)THEN
+ print *,' ** PRECOU AP COMPCOORD_FORDIACHRO NMGRID ',NMGRID
+ print *,' ** PRECOU Entree NPROFILE ',NPROFILE
+ENDIF
+print*, LUMVM,LDIRWIND,LDIRWM,LDIRWT
+
+IF(LPRESY)THEN
+ IF(NMGRID /= 1 .AND. SIZE(XPRES,1) /= 1 .AND. SIZE(XPRES,2) /= 1 .AND. &
+ SIZE(XPRES,3) /= 1)THEN
+ LPRESYT=.TRUE.
+ print *,' ** PRECOU Appel volontaire INTERP_GRIDS NMGRID courant ',NMGRID,' IGRID de PR = 1 '
+ CALL INTERP_GRIDS(0)
+ LPRESYT=.FALSE.
+ ENDIF
+ XZZ(:,:,:)=XPRES(:,:,:,NLOOPT,1,1)
+ print *,' ** PRECOU Remplacement volontaire de XZZ par XPRES(:,:,:,NLOOPT,1,1)'
+! XZZ(:,:,:)=ALOG10(XZZ(:,:,:))
+ IF(LPVT)THEN
+ IF(.NOT.LTINCRDIA(NLOOPSUPER,1))THEN
+ IF(NLOOPT == NTIMEDIA(1,NLOOPSUPER,1))THEN
+ IF(ALLOCATED(XPRESM))THEN
+ DEALLOCATE(XPRESM)
+ ENDIF
+ ALLOCATE(XPRESM(NBTIMEDIA(NLOOPSUPER,1),IKU))
+ ITPRESY=0
+ ELSE IF(NLOOPT == NTIMEDIA(NBTIMEDIA(NLOOPSUPER,1),NLOOPSUPER,1))THEN
+ ENDIF
+ ELSE
+ IF(NLOOPT == NTIMEDIA(1,NLOOPSUPER,1))THEN
+ IF(ALLOCATED(XPRESM))THEN
+ DEALLOCATE(XPRESM)
+ ENDIF
+ IPRESM=(NTIMEDIA(2,NLOOPSUPER,1)-NTIMEDIA(1,NLOOPSUPER,1))/ &
+ NTIMEDIA(3,NLOOPSUPER,1)+1
+ ALLOCATE(XPRESM(IPRESM,IKU))
+ ITPRESY=0
+ ELSEIF(NLOOPT == NTIMEDIA(2,NLOOPSUPER,1))THEN
+ ENDIF
+ ENDIF
+ ENDIF
+ENDIF
+
+!!!essai nov 2001
+IF((LULM .OR. LULT .OR.LVTM .OR. LVTT) .AND. .NOT.(LCH .AND.LCV))THEN
+!IF(LULM .OR. LULT .OR.LVTM .OR. LVTT)THEN
+!!!essai nov 2001
+
+ ZWORK3D=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,NLOOPT,1,1)
+ DO JKLOOP=1,IKU
+ ZTEM1(:,:)=0.
+ ZTEMV(:,:)=0.
+
+ IF(JKLOOP <MAX(IKB,NKL) .OR. JKLOOP> MIN(NKH,IKE))THEN
+ ELSE
+ ZTEM1(NIL:NIH,NJL:NJH)=PWORK3D(:,:,JKLOOP-NKL+1)
+ ZTEMV(NIL:NIH,NJL:NJH)=ZWORK3D(:,:,JKLOOP-NKL+1)
+ CALL ROTA(ZTEM1,ZTEMV)
+
+ IF(LULM .OR. LULT)THEN
+ CALL COUPE_FORDIACHRO(ZTEM1,ZTEM2,JKLOOP)
+ ELSE
+ CALL COUPE_FORDIACHRO(ZTEMV,ZTEM2,JKLOOP)
+ ENDIF
+
+ PTEMCV(:,JKLOOP)=ZTEM2(:)
+! IF(LULM)THEN
+! print *,'LULM ZTEM2 JKLOOP ',JKLOOP
+! print *,ZTEM2
+! ENDIF
+ ENDIF
+
+ ENDDO
+
+ELSE IF(LULMWM .OR. LULTWT)THEN
+
+ NMGRID=1
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+! CALL COMPCOORD_FORDIACHRO(1)
+
+ ZWORK3D=XV(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,NLOOPT,1,1)
+ ZWORK3W=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,NLOOPT,1,1)
+! On place la composante W aux points de masse
+ ZWORK3W(:,:,1:IWKU-1)=.5*(ZWORK3W(:,:,1:IWKU-1)+ZWORK3W(:,:,2:IWKU))
+ ZWORK3W(:,:,IWKU)=2.*ZWORK3W(:,:,IWKU-1)-ZWORK3W(:,:,IWKU-2)
+
+ DO JKLOOP=1,IKU
+ ZTEM1(:,:)=0.
+ ZTEMV(:,:)=0.
+ ZTEMW(:,:)=0.
+
+ IF(JKLOOP <MAX(IKB,NKL) .OR. JKLOOP> MIN(NKH,IKE))THEN
+ ELSE
+
+ ZTEM1(NIL:NIH,NJL:NJH)=PWORK3D(:,:,JKLOOP-NKL+1)
+ ZTEMV(NIL:NIH,NJL:NJH)=ZWORK3D(:,:,JKLOOP-NKL+1)
+ ZTEMW(NIL:NIH,NJL:NJH)=ZWORK3W(:,:,JKLOOP-NKL+1)
+
+ CALL COUPEUW_FORDIACHRO(ZTEM1,ZTEM2,JKLOOP,1)
+
+! Janvier 2001 ..PROVISOIRE
+! L2D=.FALSE.
+ IF(L2D)THEN
+! 2D // axe X
+ ZTEMVR=ZTEMV(NIDEBCOU:NIDEBCOU+NLMAX-1,NJDEBCOU)
+ ELSE
+ CALL COUPEUW_FORDIACHRO(ZTEMV,ZTEMVR,JKLOOP,2)
+ ENDIF
+
+ CALL ROTAUW(ZTEM2,ZTEMVR)
+ PTEMCV(:,JKLOOP)=ZTEM2
+
+ CALL COUPEUW_FORDIACHRO(ZTEMW,ZTEMWR,JKLOOP,3)
+ XWCV(:,JKLOOP)=ZTEMWR
+
+ ENDIF
+ ENDDO
+
+! Janvier 2001 + LDIRWIND et LUMVM et LUTVT et LSUMVM et LSUTVT
+!ELSE IF(LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. LDIRWIND)THEN
+!! essai nov 2001
+ELSE IF(LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. &
+!(LDIRWIND .AND. .NOT.(LCV .AND.LCH)))THEN
+(LDIRWIND .AND. .NOT.(LCV .AND.LCH)) .OR. &
+(LDIRWM .AND. .NOT.LDIRWIND) .OR. &
+(LDIRWT .AND. .NOT.LDIRWIND) )THEN
+
+ ZWORK3D=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,NLOOPT,1,1)
+! On positionne les 2 composantes aux points de masse
+
+ IUI=SIZE(PWORK3D,1)
+ IUJ=SIZE(PWORK3D,2)
+print*, NGRIU,NGRIV,IKU,IUI,IUJ
+!! Nov 2001 sauf si ce n'est deja fait
+ IF(NGRIU == 1 .AND. NGRIV == 1)THEN
+ print *,' ** Precou NGRIU=',NGRIU,' NGRIV=',NGRIV,' pas de repositionnement sur la grille de masse (deja fait) GRP=',CGROUP
+ ELSE
+!! Nov 2001 sauf si ce n'est deja fait
+ PWORK3D(1:IUI-1,:,:)=0.5*(PWORK3D(2:IUI,:,:)+PWORK3D(1:IUI-1,:,:))
+ PWORK3D(IUI,:,:)=2*PWORK3D(IUI-1,:,:)-PWORK3D(IUI-2,:,:)
+ ZWORK3D(:,1:IUJ-1,:)=0.5*(ZWORK3D(:,2:IUJ,:)+ZWORK3D(:,1:IUJ-1,:))
+ ZWORK3D(:,IUJ,:)=2*ZWORK3D(:,IUJ-1,:)-ZWORK3D(:,IUJ-2,:)
+!! Nov 2001 sauf si ce n'est deja fait
+ ENDIF
+!! Nov 2001 sauf si ce n'est deja fait
+ DO JKLOOP=1,IKU
+ ZTEM1(:,:)=0.
+ ZTEMV(:,:)=0.
+
+ IF(JKLOOP <MAX(IKB,NKL) .OR. JKLOOP> MIN(NKH,IKE))THEN
+ ELSE
+
+ ZTEM1(NIL:NIH,NJL:NJH)=PWORK3D(:,:,JKLOOP-NKL+1)
+ ZTEMV(NIL:NIH,NJL:NJH)=ZWORK3D(:,:,JKLOOP-NKL+1)
+ if(nverbia > 5)then
+ print*,'** PRECOU Composante U av coupe'
+ endif
+
+ CALL COUPE_FORDIACHRO(ZTEM1,ZTEM2,JKLOOP)
+! CALL COUPEUW_FORDIACHRO(ZTEM1,ZTEM2,JKLOOP,1)
+ PTEMCV(:,JKLOOP)=ZTEM2
+ if(nverbia > 0)then
+ print *,' ** PRECOU Composante U ap coupe, K= ',JKLOOP
+ endif
+
+! Janvier 2001 ..PROVISOIRE
+! L2D=.FALSE.
+ IF(L2D)THEN
+! 2D // axe X
+ ZTEMVR=ZTEMV(NIDEBCOU:NIDEBCOU+NLMAX-1,NJDEBCOU)
+ ELSE
+ if(nverbia > 5)then
+ print *,' ** PRECOU Composante V AV coupe'
+ endif
+ CALL COUPE_FORDIACHRO(ZTEMV,ZTEMVR,JKLOOP)
+! CALL COUPEUW_FORDIACHRO(ZTEMV,ZTEMVR,JKLOOP,2)
+ if(nverbia > 0)then
+ print *,' ** PRECOU Composante V ap coupe, K= ',JKLOOP
+ endif
+ ENDIF
+
+ XWCV(:,JKLOOP)=ZTEMVR
+ ENDIF
+ ENDDO
+!! 30 nov 2001
+! IF(LDIRWIND)THEN
+ IF(LDIRWIND .OR. &
+ (LDIRWM .AND. .NOT.LDIRWIND) .OR. &
+ (LDIRWT .AND. .NOT.LDIRWIND) ) THEN
+ IUB1=SIZE(XWCV,1)
+ IUB2=SIZE(XWCV,2)
+ ISKIP=1
+ ITER=IUB1; JTER=IUB2
+ IF(ALLOCATED(ZX))THEN
+ DEALLOCATE(ZX)
+ ENDIF
+ IF(ALLOCATED(ZZY))THEN
+ DEALLOCATE(ZZY)
+ ENDIF
+ ALLOCATE(ZX(ITER,1),ZZY(JTER))
+ ZX(:,1)=XZZX(1:IUB1:ISKIP)
+ ZZY=XZZY(1:IUB2:ISKIP)
+!! DEc 2001
+!!Fev 2002
+ IF(LDIRWIND .AND. (LCH .OR. LFT .OR. LPVKT ))THEN
+! IF(LCH .OR. LFT .OR. LPVKT)THEN
+!!Fev 2002
+!! DEc 2001
+ CALL COMPUTEDIR(ITER,JTER,IUB1,IUB2,ISKIP,PTEMCV,XWCV)
+ PTEMCV(:,:)=XWCV(:,:)
+!! DEc 2001
+ ENDIF
+!! DEc 2001
+ IF ( (LDIRWM .AND. .NOT.LDIRWIND) .OR. &
+ (LDIRWT .AND. .NOT.LDIRWIND) )THEN
+ print*,'precou av dd ',MINVAL(PTEMCV),MAXVAL(PTEMCV),MINVAL(XWCV),MAXVAL(XWCV)
+ CALL COMPUTEDIR(ITER,JTER,IUB1,IUB2,ISKIP,PTEMCV,XWCV)
+ PTEMCV(:,:)=XWCV(:,:)
+ print*,'precou ap dd ',MINVAL(PTEMCV),MAXVAL(PTEMCV)
+ ENDIF
+ ENDIF
+!! 30 nov 2001
+
+!!essai Nov 2001 -> PH traites ds traceh_fordiachro
+ELSE IF((LMUMVM .OR. LMUTVT .OR. LMLSUMVM .OR. LMLSUTVT) .AND. &
+ (.NOT.(LCH.AND.LCV)))THEN
+!ELSE IF(LMUMVM .OR. LMUTVT .OR. LMLSUMVM .OR. LMLSUTVT)THEN
+!!essai Nov 2001
+
+
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+ ZWORK3D=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,NLOOPT,1,1)
+
+! On positionne les 2 composantes aux points de masse
+
+ if(nverbia > 0 .AND. size(PWORK3D,1) >= 12 .AND. &
+ size(PWORK3D,2) >= 7 .AND. size(PWORK3D,3) >= 9)THEN
+ print *,' ***PRECOU IK=9 I=8A12 J=3A7 U Grid 2 et V GRID 3 '
+ print *,PWORK3D(8:12,3,9)
+ print *,PWORK3D(8:12,4,9)
+ print *,PWORK3D(8:12,5,9)
+ print *,PWORK3D(8:12,6,9)
+ print *,PWORK3D(8:12,7,9),' *******'
+ print *,ZWORK3D(8:12,3,9)
+ print *,ZWORK3D(8:12,4,9)
+ print *,ZWORK3D(8:12,5,9)
+ print *,ZWORK3D(8:12,6,9)
+ print *,ZWORK3D(8:12,7,9),' *******'
+ endif
+ IUI=SIZE(PWORK3D,1)
+ IUJ=SIZE(PWORK3D,2)
+!! Nov 2001 sauf si ce n'est deja fait
+ IF(NGRIU == 1 .AND. NGRIV == 1)THEN
+ print *,' ** Precou NGRIU=',NGRIU,' NGRIV=',NGRIV,' pas de repositionnement sur la grille de masse (deja fait) GRP=',CGROUP
+ ELSE
+!! Nov 2001 sauf si ce n'est deja fait
+ PWORK3D(1:IUI-1,:,:)=0.5*(PWORK3D(2:IUI,:,:)+PWORK3D(1:IUI-1,:,:))
+ PWORK3D(IUI,:,:)=2*PWORK3D(IUI-1,:,:)-PWORK3D(IUI-2,:,:)
+ ZWORK3D(:,1:IUJ-1,:)=0.5*(ZWORK3D(:,2:IUJ,:)+ZWORK3D(:,1:IUJ-1,:))
+ ZWORK3D(:,IUJ,:)=2*ZWORK3D(:,IUJ-1,:)-ZWORK3D(:,IUJ-2,:)
+!! Nov 2001 sauf si ce n'est deja fait
+ ENDIF
+!! Nov 2001 sauf si ce n'est deja fait
+ if(nverbia > 0 .AND. size(PWORK3D,1) >= 12 .AND. &
+ size(PWORK3D,2) >= 7 .AND. size(PWORK3D,3) >= 9)THEN
+ print *,' ***PRECOU IK=9 I=8A12 J=3A7 U et V Grille 1 '
+ print *,PWORK3D(8:12,3,9)
+ print *,PWORK3D(8:12,4,9)
+ print *,PWORK3D(8:12,5,9)
+ print *,PWORK3D(8:12,6,9)
+ print *,PWORK3D(8:12,7,9),' *******'
+ print *,ZWORK3D(8:12,3,9)
+ print *,ZWORK3D(8:12,4,9)
+ print *,ZWORK3D(8:12,5,9)
+ print *,ZWORK3D(8:12,6,9)
+ print *,ZWORK3D(8:12,7,9),' *******'
+ endif
+ PWORK3D=PWORK3D*PWORK3D
+ ZWORK3D=ZWORK3D*ZWORK3D
+ PWORK3D=SQRT(PWORK3D+ZWORK3D)
+
+ DO JKLOOP=1,IKU
+ ZTEM1(:,:)=0.
+ IF(JKLOOP <MAX(IKB,NKL) .OR. JKLOOP> MIN(NKH,IKE))THEN
+ ELSE
+ ZTEM1(NIL:NIH,NJL:NJH)=PWORK3D(:,:,JKLOOP-NKL+1)
+ ! ZTEM1(:,:)=PWORK3D(:,:,JKLOOP-NKL+1)
+ ENDIF
+ CALL COUPE_FORDIACHRO(ZTEM1,ZTEM2,JKLOOP)
+ PTEMCV(:,JKLOOP)=ZTEM2(:)
+
+ !print *,' JKLOOP NKL NKH ',JKLOOP,NKL,NKH,' ZTEM2'
+ !print *,ZTEM2
+ ENDDO
+
+ELSE
+IF(NVERBIA > 0)THEN
+ print *,' ** PRECOU AV DO JKLOOP=1,IKU'
+ENDIF
+
+DO JKLOOP=1,IKU
+ ZTEM1(:,:)=0.
+! Ajout Avril 2001
+
+!!Nov 2001
+ IF(IKU == 1 )THEN
+! IF(IKU == 1 .AND. LKCP)THEN
+!!Nov 2001
+
+ ZTEM1(NIL:NIH,NJL:NJH)=PWORK3D(:,:,1)
+ IF(NVERBIA > 5)THEN
+ print *,' ** PRECOU LKCP=',LKCP,' IKU=',IKU,' ZTEM1(NIL:NIH,NJL:NJH)'
+ print *,ZTEM1(NIL:NIH,NJL:NJH)
+ ENDIF
+
+ ELSE
+
+ IF(JKLOOP <MAX(IKB,NKL) .OR. JKLOOP> MIN(NKH,IKE))THEN
+ ELSE
+ ZTEM1(NIL:NIH,NJL:NJH)=PWORK3D(:,:,JKLOOP-NKL+1)
+! ZTEM1(:,:)=PWORK3D(:,:,JKLOOP-NKL+1)
+ ENDIF
+IF(NVERBIA > 5)THEN
+ IF(JKLOOP == MAX(2,NKL) .OR. IKU == 1)THEN
+ print *,' ** PRECOU DS DO JKLOOP=1,IKU AV COUPE, JKLOOP',JKLOOP
+ print *,' ** PRECOU AV COUPE, ZTEM2 ',ZTEM2
+ ENDIF
+ENDIF
+
+ ENDIF
+
+ CALL COUPE_FORDIACHRO(ZTEM1,ZTEM2,JKLOOP)
+ PTEMCV(:,JKLOOP)=ZTEM2(:)
+
+IF(NVERBIA > 5)THEN
+ IF(JKLOOP == MAX(2,NKL) .OR. IKU == 1)THEN
+print *,' JKLOOP NKL NKH ',JKLOOP,NKL,NKH,' ZTEM2'
+print *,ZTEM2
+ ENDIF
+ENDIF
+ENDDO
+IF(NVERBIA > 0)THEN
+ print *,' **Sortie PRECOU (XWORKZ) ',SIZE(XWORKZ,1),SIZE(XWORKZ,2),&
+ SIZE(XWORKZ,3)
+! print *,' **Sortie PRECOU XWORKZ(NPROFILE,:,NMGRID) ',XWORKZ(NPROFILE,:,NMGRID)
+ENDIF
+IF(LPRESY .AND. LPVT)THEN
+ ITPRESY=ITPRESY+1
+ XPRESM(ITPRESY,:)=XWORKZ(NPROFILE,:,NMGRID)
+ENDIF
+
+ENDIF
+
+!print *,' ** precou AV DEALLOCATE(ZTEM1,ZTEM2) '
+DEALLOCATE(ZTEM1,ZTEM2)
+!print *,' ** precou AP DEALLOCATE(ZTEM1,ZTEM2) '
+IF(ALLOCATED(ZTEMWR))THEN
+ DEALLOCATE(ZTEMWR)
+ENDIF
+IF(ALLOCATED(ZTEMVR))THEN
+ DEALLOCATE(ZTEMVR)
+ENDIF
+IF(ALLOCATED(ZTEMW))THEN
+ DEALLOCATE(ZTEMW)
+ENDIF
+IF(ALLOCATED(ZWORK3W))THEN
+ DEALLOCATE(ZWORK3W)
+ENDIF
+IF(ALLOCATED(ZTEMV))THEN
+ DEALLOCATE(ZTEMV)
+ENDIF
+IF(ALLOCATED(ZWORK3D))THEN
+ DEALLOCATE(ZWORK3D)
+ENDIF
+if(nverbia > 0)then
+ print *,' ** precou FIN'
+endif
+!
+!----------------------------------------------------------------------------
+!
+!* 3. EXIT
+! ----
+!
+END SUBROUTINE PRECOU_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/prints.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/prints.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0c84925b502dc39fd713adaab76080e9c0a042a0
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/prints.f90
@@ -0,0 +1,979 @@
+! #############################
+ MODULE MODI_PRINTS
+! #############################
+!
+INTERFACE
+!
+SUBROUTINE PRINTS(HCARIN)
+CHARACTER(LEN=*) :: HCARIN
+END SUBROUTINE PRINTS
+!
+END INTERFACE
+END MODULE MODI_PRINTS
+! ######spl
+ SUBROUTINE PRINTS(HCARIN)
+! #########################
+!
+!!**** *PRINTS* - Gestion des impressions temps reel
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_TITLE
+USE MODD_DEFCV
+USE MODD_MEMCV
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_FILES_DIACHRO
+USE MODN_NCAR
+USE MODD_DIM1
+USE MODD_TYPE_AND_LH
+USE MODD_PARAMETERS
+USE MODN_PARA
+USE MODI_REALLOC_AND_LOAD
+USE MODD_SEVERAL_RECORDS
+USE MODD_CTL_AXES_AND_STYL
+USE MODI_VERIF_GROUP
+USE MODI_FMREAD
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+!
+CHARACTER(LEN=*) :: HCARIN
+!
+!* 0.2 local variables
+!
+
+INTEGER :: INDGRPS, INDGRP, INDPRI, INDFIL, INDVPT
+INTEGER :: INDIM, INDPROC, INDTIME, INDNAM, INDVAL
+INTEGER :: INDMNMX, INDNITV, INDIR
+INTEGER :: IND, INDN
+INTEGER :: INDPAR1, INDPAR2
+INTEGER :: J, JM, JJ, JA, J2, JB, JC
+INTEGER :: JLOOPI, JLOOPJ, JLOOPK, JLOOPT, JLOOPN, JLOOPP
+INTEGER :: ILOOP, IDEB, IFIN, II
+INTEGER :: ILENG, ILENCH, IGRID, ILENDIM, IT, IM
+INTEGER :: IRESPDIA, IRESP, INUM
+INTEGER :: IGROUP=0, ICOMPT
+INTEGER :: IDI, IEI, IDJ, IEJ, IDK, IEK
+INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE
+INTEGER,DIMENSION(:),ALLOCATABLE :: ITABCHAR
+INTEGER,DIMENSION(5) :: IMN, IMX
+INTEGER,DIMENSION(12) :: ITEM
+
+REAL :: ZMN, ZMX, ZMOY
+
+LOGICAL :: GPRIGRP
+LOGICAL, DIMENSION(:,:,:,:),ALLOCATABLE :: GMASK
+
+CHARACTER(LEN=16) :: YGROUP2
+CHARACTER(LEN=17),DIMENSION(10) :: YTIME2
+CHARACTER(LEN=8),DIMENSION(20) :: YTIMES
+CHARACTER(LEN=8),DIMENSION(50) :: YMASK
+CHARACTER(LEN=1) :: YC1
+CHARACTER(LEN=2) :: YC2
+CHARACTER(LEN=3) :: YC3
+CHARACTER(LEN=4) :: YC4
+CHARACTER(LEN=5) :: YC5
+CHARACTER(LEN=6) :: YC6
+CHARACTER(LEN=16) :: YRECFM
+CHARACTER(LEN=40) :: YTEM
+! Aout 99 Longueur YCOMMENT passee de 20 A 100
+CHARACTER(LEN=100) :: YCOMMENT
+CHARACTER(LEN=16),DIMENSION(5000),SAVE :: YGROUP
+!
+!-------------------------------------------------------------------------------
+IIB=1+JPHEXT; IIE=NIMAX+JPHEXT
+IJB=1+JPHEXT; IJE=NJMAX+JPHEXT
+IKB=1+JPVEXT; IKE=NKMAX+JPVEXT
+
+ICOMPT=0
+ITEM(:)=1
+YTEM(1:LEN(YTEM))=' '
+
+GPRIGRP=.FALSE.
+INDIR =INDEX(HCARIN,'DIRCUR')
+INDGRPS=INDEX(HCARIN,'GROUP')
+INDIM =INDEX(HCARIN,'DIM')
+INDPROC=INDEX(HCARIN,'PROC')
+INDTIME=INDEX(HCARIN,'TIME')
+INDPRI =INDEX(HCARIN,'PRINT')
+INDFIL =INDEX(HCARIN,'FILE')
+INDNAM =INDEX(HCARIN,'NAM')
+INDVAL =INDEX(HCARIN,'VAL')
+INDMNMX =INDEX(HCARIN,'MNMX')
+IF(INDMNMX == 0)THEN
+ INDMNMX =INDEX(HCARIN,'MINMAX')
+ENDIF
+INDNITV =INDEX(HCARIN,'NITV')
+INDVPT =INDEX(HCARIN,'VPTCUR')
+INDPAR1=INDEX(HCARIN,'(')
+INDPAR2=INDEX(HCARIN,')')
+
+YGROUP(1:LEN(YGROUP))=' '
+!
+! Impression de la directive courante
+!
+IF(INDIR /= 0)THEN
+ PRINT*, CDIRPREC
+ RETURN
+ENDIF
+
+!
+! Impression limites de la fenetre du dessin qui vient d etre trace
+!
+IF(INDVPT /= 0)THEN
+ print *,' **Limites, en coord. normalisees, de la fenetre du dernier graphique**'
+ IF(XCURVPTL== 0. .AND. XCURVPTR == 0. .AND. XCURVPTB == 0. .AND. XCURVPTT == 0.)THEN
+ print *,' Non initialisees. Besoin de generer le dessin dont vous voulez les limites '
+ ELSE
+ print *,' XMIN,XMAX,YMIN,YMAX= ',XCURVPTL,XCURVPTR,XCURVPTB,XCURVPTT
+ ENDIF
+ RETURN
+ENDIF
+!
+! Impression du nb d'intervalles sur les axes X et Y definissant
+! les graduations majeures et mineures
+!
+IF(INDNITV /= 0)THEN
+ PRINT '(1X,''Controle des graduations Majeures et mineures par definition du nb '')'
+ PRINT '(1X,''d intervalles sur les axes X et Y. VALEURS ACTUELLES :'')'
+ PRINT '(1X,78(1H*))'
+ PRINT '(1X,''CH Cartesien _K_ _Z_ _PR_ _TK_'')'
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''NCHITVXMJ:'',I4,2X,''NCHITVXMN:'',I4,2X,''NCHITVYMJ:'',I4,2X, &
+& ''NCHITVYMN:'',I4)',NCHITVXMJ,NCHITVXMN,NCHITVYMJ,NCHITVYMN
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''CH Projection cartographique _K_ _Z_ _PR_ _TK_ _EV_'')'
+ IF(NCHPCITVXMJ == 0 .AND. NCHPCITVXMN == 0 .AND. NCHPCITVYMJ == 0 .AND. &
+ NCHPCITVYMN == 0)THEN
+ PRINT '(1X,''NCHPCITVXMJ: 1 NCHPCITVXMN:NISUP-NIINF NCHPCITVYMJ: 1 &
+ &NCHPCITVYMN:NJSUP-NJINF '')'
+ ELSE
+ PRINT '(1X,''NCHPCITVXMJ:'',I4,2X,''NCHPCITVXMN:'',I4,2X,''NCHPCITVYMJ:'',I4,2X, &
+& ''NCHPCITVYMN:'',I4)',NCHPCITVXMJ,NCHPCITVXMN,NCHPCITVYMJ,NCHPCITVYMN
+ ENDIF
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''CV _CV_ _PVT_'')'
+ PRINT '(1X,''NCVITVXMJ:'',I4,2X,''NCVITVXMN:'',I4,2X,''NCVITVYMJ:'',I4,2X, &
+& ''NCVITVYMN:'',I4)',NCVITVXMJ,NCVITVXMN,NCVITVYMJ,NCVITVYMN
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''PV _PV_ '')'
+ PRINT '(1X,''NPVITVXMJ:'',I4,2X,''NPVITVXMN:'',I4,2X,''NPVITVYMJ:'',I4,2X, &
+& ''NPVITVYMN:'',I4)',NPVITVXMJ,NPVITVXMN,NPVITVYMJ,NPVITVYMN
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''FT _FT_ _PVKT_'')'
+ PRINT '(1X,''NFTITVXMJ:'',I4,2X,''NFTITVXMN:'',I4,2X,''NFTITVYMJ:'',I4,2X, &
+& ''NFTITVYMN:'',I4)',NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''FT1 _FT1_ '')'
+ PRINT '(1X,''NFT1ITVXMJ:'',I4,2X,''NFT1ITVXMN:'',I4,2X,''NFT1ITVYMJ:'',I4,2X, &
+& ''NFT1ITVYMN:'',I4)',NFT1ITVXMJ,NFT1ITVXMN,NFT1ITVYMJ,NFT1ITVYMN
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''MASK _MASK_ '')'
+ PRINT '(1X,''NMASKITVXMJ:'',I4,2X,''NMASKITVXMN:'',I4,2X,''NMASKITVYMJ:'',I4,2X, &
+& ''NMASKITVYMN:'',I4)',NMASKITVXMJ,NMASKITVXMN,NMASKITVYMJ,NMASKITVYMN
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''XY _XY_ '')'
+ PRINT '(1X,''NXYITVXMJ:'',I4,2X,''NXYITVXMN:'',I4,2X,''NXYITVYMJ:'',I4,2X, &
+& ''NXYITVYMN:'',I4)',NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN
+ PRINT '(1X,78(1H.))'
+ RETURN
+ENDIF
+
+!
+! Impression des parametres de namelist
+!
+IF(INDNAM /= 0)THEN
+ PRINT '(1X,''NIINF:'',I4,6X,''NISUP:'',I4,6X,''NJINF:'',I4,6X,''NJSUP:'',I4,6X,''LGEOG:'',L1)', &
+ NIINF,NISUP,NJINF,NJSUP,LGEOG
+ PRINT '(1X,''XSZTITXL:'',F5.3,4X,''XSZTITXM:'',F5.3,4X,''XSZTITXR:'',F5.3)',&
+ XSZTITXL,XSZTITXM,XSZTITXR
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''NIDEBCOU:'',I4,3X,''NJDEBCOU:'',I4,3X,''NLANGLE:'',I3,5X, &
+& ''NLMAX:'',I4)',NIDEBCOU,NJDEBCOU,NLANGLE,NLMAX
+ PRINT '(1X,''XIDEBCOU:'',F6.0,1X,''XJDEBCOU:'',F6.0,1X,''XHMIN:'',F6.0,4X, &
+& ''XHMAX:'',F6.0)',XIDEBCOU,XJDEBCOU,XHMIN,XHMAX
+ PRINT '(1X,''LDEFCV2:'',L1,7X,''LDEFCV2LL:'',L1,5X,''LDEFCV2IND:'',L1,2X,''LTRACECV:'',L1)',LDEFCV2,LDEFCV2LL,LDEFCV2IND,LTRACECV
+ PRINT '(1X,''XIDEBCV:'',F8.0,2X,''XJDEBCV:'',F8.0,2X,''XIFINCV:'',F8.0,2X, &
+& ''XJFINCV:'',F8.0)',XIDEBCV,XJDEBCV,XIFINCV,XJFINCV
+ PRINT '(1X,''XIDEBCVLL'',F10.5,1X,''XJDEBCVLL'',F10.5,1X,''XIFINCVLL'',F10.5,1X, &
+& ''XJFINCVLL'',F10.5)',XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL
+ PRINT '(1X,''NIDEBCV:'',I4,4X,''NJDEBCV:'',I4,4X,''NIFINCV:'',I4,4X, &
+& ''NJFINCV:'',I4)',NIDEBCV,NJDEBCV,NIFINCV,NJFINCV
+ PRINT '(1X,''PROFILE:'',I4,4X,''LMNMXUSER:'',L2,4X,''LCOLUSER:'', &
+& L2)',NPROFILE,LMNMXUSER,LCOLUSER
+ IF(NBFTMN /= 0)THEN
+! PRINT '(1X,''NBFTMN:'',I4,''NBFTMX:'',I4)
+ IF(NBFTMN == NBFTMX)THEN
+ PRINT '(11X,''PROC'',11X,''* XPV(ou FT ou PVKT)MIN_ *'', &
+& ''* XPV(ou FT ou PVKT)MAX_'')'
+ PRINT '(1X,78(1H*))'
+ DO J=1,NBFTMN
+ PRINT '(1X,A25,''*'',E15.8,10X,''*'',E15.8)',CFTMN(J),XFTMN(J),XFTMX(J)
+ ENDDO
+ ELSE
+ PRINT '(11X,''PROC'',11X,''* XPV(ou FT ou PVKT)MIN_'')'
+ PRINT '(1X,51(1H*))'
+ DO J=1,NBFTMN
+ PRINT '(1X,A25,''*'',E15.8)',CFTMN(J),XFTMN(J)
+ ENDDO
+ IF(NBFTMX /= 0)THEN
+ PRINT '(11X,''PROC'',11X,''* XPV(ou FT ou PVKT)MAX_ '')'
+ PRINT '(1X,51(1H*))'
+ DO J=1,NBFTMX
+ PRINT '(1X,A25,''*'',E15.8)',CFTMX(J),XFTMX(J)
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDIF
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''NDOT:'',I7,4X,''NHI:'',I4,8X,''NIOFFD:'',I4,5X, &
+& ''NIFDC:'',I4,6X,''NIGRNC:'',I4)',NDOT,NHI,NIOFFD,NIFDC,NIGRNC
+ PRINT '(1X,''NULBLL:'',I5,4X,''XSPVAL:'',F11.3,14X,''LSPVALT:'',L1,7X, &
+& ''XSPVALT:'',F11.3)',NULBLL,XSPVAL,LSPVALT,XSPVALT
+ PRINT '(1X,''NIMNMX:'',I3,6X,''XISOMIN:'',F10.3,3X,''XISOMAX:'',F10.3,3X, &
+& ''XDIAINT:'',F10.3)',NIMNMX,XISOMIN,XISOMAX,XDIAINT
+ DO J=SIZE(XISOLEV),1,-1
+ IF(XISOLEV(J) /= 9999.)THEN
+ JM=J
+ EXIT
+ ENDIF
+ JM=J
+ ENDDO
+ IF(XISOLEV(JM) == 9999.)THEN
+ JM=JM-1
+ ENDIF
+ !PRINT '(17X,''XISOLEV:'',4(F10.3,3X))',(XISOLEV(J),J=1,JM)
+ PRINT '(17X,''XISOREF:'',F10.3,3X,''XISOLEV:'',4(F10.3,3X))',&
+ XISOREF,(XISOLEV(J),J=1,JM)
+ IF(NLPCAR /= 0)THEN
+ PRINT '(1X,''NLPCAR:'',I3,6X,''XLATCAR:'',6F7.2)',NLPCAR,(XLATCAR(J),J=1,NLPCAR)
+ PRINT '(17X,''XLONCAR:'',6F7.2)',(XLONCAR(J),J=1,NLPCAR)
+ ENDIF
+ IF(NIJCAR /= 0)THEN
+ PRINT '(1X,''NIJCAR:'',I3,6X,''XICAR:'',6F7.2)',NIJCAR,(XICAR(J),J=1,NIJCAR)
+ PRINT '(17X,''XJCAR:'',6F7.2)',(XJCAR(J),J=1,NIJCAR)
+ ENDIF
+ PRINT '(1X,''LCOLAREA:'',L1,6X,''LCOLAREASEL:'',L1,3X,''LCOLINE:'',L1,7X, &
+& ''LCOLINESEL:'',L1)',LCOLAREA,LCOLAREASEL,LCOLINE,LCOLINESEL
+ PRINT '(1X,''LCOLBR:'',L1,8X,''LISO:'',L1,10X,''LISOWHI:'',L1,7X, &
+& ''LTABCOLDEF:'',L1)',LCOLBR,LISO,LISOWHI,LTABCOLDEF
+ PRINT '(1X,''LMINMAX:'',L1,7X,''LDATFILE:'',L1,6X,''LMNMXLOC:'',L1)',LMINMAX,LDATFILE,LMNMXLOC
+ PRINT '(1X,''LXY:'',L1,11X,''LXZ:'',L1,11X,''LPRINT:'',L1,8X,''LPRINTXY:'',L1)',LXY,LXZ,LPRINT,LPRINTXY
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''LVECTMNMX:'',L1,5X,''XVHC:'',F7.3,4X,''XVRL:'',F7.3, &
+& 4X,''XVLC:'',F7.3,4X,''NISKIP:'',I3)', &
+ LVECTMNMX,XVHC,XVRL,XVLC,NISKIP
+ PRINT '(1X,''LULMVTMOLD:'',L1,4X,''LDIRWIND:'',L1,6X,''XANGULVT:'',F7.3)', &
+ LULMVTMOLD,LDIRWIND,XANGULVT
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''NIRS:'',I4,7X,''NJRS:'',I4,7X,''XIRS:'',F4.0,7X,''XJRS:'',F4.0)',&
+ NIRS,NJRS,XIRS,XJRS
+ PRINT '(1X,78(1H.))'
+ PRINT '(1X,''LFT1STYLUSER:'',L1,2X,''LFTSTYLUSER:'',L1,3X,''LTITFTUSER:'',L1)',LFT1STYLUSER,LFTSTYLUSER,LTITFTUSER
+
+ RETURN
+ENDIF
+DO J=1,NBFILES
+ IF(NUMFILES(J) == NUMFILECUR)THEN
+ JM=J
+ ENDIF
+ENDDO
+!
+! Impression des fichiers
+!
+IF(INDFIL /=0)THEN
+
+IF(NUMFILECUR <10)THEN
+ WRITE(YC1,'(I1)')NUMFILECUR
+ PRINT *,' CURRENT FILE(S): _FILE'//YC1,'_',CFILEDIAS(JM)
+ELSE
+ WRITE(YC2,'(I2)')NUMFILECUR
+ PRINT *,' CURRENT FILE(S): _FILE'//YC2,'_',CFILEDIAS(JM)
+ENDIF
+IF(LFIC1)THEN
+ELSE
+ DO J=2,NBSIMULT
+ IF(NUMFILES(NINDFILESIMULT(J)) <10)THEN
+ WRITE(YC1,'(I1)')NUMFILES(NINDFILESIMULT(J))
+ PRINT *,' : _FILE'//YC1,'_',CFILEDIAS(NINDFILESIMULT(J))
+ ELSE
+ WRITE(YC2,'(I2)')NUMFILES(NINDFILESIMULT(J))
+ PRINT *,' : _FILE'//YC2,'_',CFILEDIAS(NINDFILESIMULT(J))
+ ENDIF
+ ENDDO
+
+ENDIF
+RETURN
+ENDIF
+!
+! Impression des groupes
+!
+IF(INDGRPS /=0)THEN
+ ILENDIM=1
+ YRECFM='MENU_BUDGET.DIM'
+ CALL FMREAD(CFILEDIAS(JM),YRECFM,CLUOUTDIAS(JM),ILENDIM,ILENG, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ ALLOCATE(ITABCHAR(ILENG))
+ YRECFM='MENU_BUDGET'
+ CALL FMREAD(CFILEDIAS(JM),YRECFM,CLUOUTDIAS(JM),ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IGROUP=ILENG/16
+ DO JJ=1,IGROUP
+ DO J=1,16
+ YGROUP(JJ)(J:J)=CHAR(ITABCHAR(16*(JJ-1)+J))
+ ENDDO
+ ENDDO
+ print *,'************************************ GROUPS ************************************'
+!fuji print 100,(ADJUSTL(ADJUSTR(YGROUP(J))),J=1,IGROUP)
+print 100,(YGROUP(J),J=1,IGROUP)
+100 FORMAT(1X,5A15)
+DEALLOCATE(ITABCHAR)
+ENDIF
+IF(INDIM + INDPROC + INDTIME + INDVAL + INDMNMX + INDPAR1 +INDPAR2 == 0)THEN
+ RETURN
+ENDIF
+DO JJ=INDPRI+5,LEN(HCARIN)
+ IF(HCARIN(JJ:JJ) /= ' ')THEN
+ INDGRP=JJ
+ EXIT
+ ENDIF
+ENDDO
+DO JJ=INDGRP,LEN(HCARIN)
+ IF(HCARIN(JJ:JJ) == ' ')EXIT
+ENDDO
+YGROUP2=HCARIN(INDGRP:JJ-1)
+CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP2)
+IF(LGROUP)THEN
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP2)
+ELSE
+ IF(LPBREAD)THEN
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ LPBREAD=.FALSE.
+ RETURN
+ ENDIF
+ENDIF
+IF(.NOT.LFIC1)THEN
+ CALL REALLOC_AND_LOAD(YGROUP2)
+ENDIF
+
+!
+! Impression d'une matrice partielle
+!
+IF(INDPAR1 /= 0 .AND. INDPAR2 /= 0)THEN
+! Suppression des ()
+ YTEM(1: INDPAR2-INDPAR1-1)=HCARIN(INDPAR1+1:INDPAR2-1)
+ YTEM=ADJUSTL(YTEM)
+! Extraction des limites du domaine demande
+! JA -> position a un instant donne de : ou ,
+! J2 -> compteur de valeurs
+ JA=0 ; J2=0
+
+ DO J=1,LEN_TRIM(YTEM)
+ IF(YTEM(J:J) == ':')THEN
+ J2=J2+1
+ READ(YTEM(JA+1:J-1),*)ITEM(J2)
+ JA=J
+ ELSE IF(YTEM(J:J) == ',')THEN
+ J2=J2+1
+ READ(YTEM(JA+1:J-1),*)ITEM(J2)
+ IF(MOD(J2,2) /= 0)THEN
+ J2=J2+1
+ ITEM(J2)=ITEM(J2-1)
+ ENDIF
+ JA=J
+ ELSE
+ IF(J == LEN_TRIM(YTEM))THEN
+ J2=J2+1
+ READ(YTEM(JA+1:J),*)ITEM(J2)
+ IF(MOD(J2,2) /= 0)THEN
+ J2=J2+1
+ ITEM(J2)=ITEM(J2-1)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDDO
+ print *,' ** print Limites du domaine demande en impression ',ITEM
+ DO J=ITEM(11),ITEM(12)
+ DO JA=ITEM(9),ITEM(10)
+ IF(ITEM(12)-ITEM(11) /= 0 .OR. ITEM(10)-ITEM(9) /=0)THEN
+ print *,' INDICES P et N ',J,' ',JA
+ ENDIF
+
+ DO JB=ITEM(7),ITEM(8)
+ IF(ITEM(8)-ITEM(7) /= 0)THEN
+ print *,' INDICE T ',JB
+ ENDIF
+ DO JC=ITEM(5),ITEM(6)
+ print *,' INDICE K= ',JC
+ ILOOP=MAX(1,(ITEM(2)-ITEM(1)+1)/5)
+ IF(ILOOP * 5 < (ITEM(2)-ITEM(1)+1))ILOOP=ILOOP+1
+ PRINT '(1X,78(1H*))'
+! print "(1X,78(''*''))"
+ DO JLOOPI=1,ILOOP
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=5
+ IDEB=IDEB+ITEM(1)-1; IFIN=IFIN+MIN(ITEM(1),SIZE(XVAR,1))-1
+ IFIN=MIN(IFIN,ITEM(2))
+ ELSE
+ IDEB=IFIN+1; IFIN=MIN(IFIN+5,ITEM(2))
+ ENDIF
+ print '('' J I-> '',3X,I4,6X,3(6X,I4,6X),(6X,I4,2X))',(/(II,II=IDEB,IFIN)/)
+ print '(1X,78(1H*))'
+ DO JLOOPJ=ITEM(4),ITEM(3),-1
+ print '(I4,2X,5(1X,E14.7))',JLOOPJ,(XVAR(II,JLOOPJ,JC,JB,JA,J),II=IDEB,IFIN)
+ ENDDO
+ ENDDO
+ print '(1X,78(1H*))'
+ ENDDO
+ ENDDO
+
+ ENDDO
+ ENDDO
+ENDIF
+!
+! Impression des dimensions
+!
+IF(INDIM /=0)THEN
+ SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ PRINT *,' ******** GROUP: ',YGROUP2,' ******* TYPE: ',CTYPE,' ******* '
+ PRINT '(1X,78(1H*))'
+ GPRIGRP=.TRUE.
+ PRINT '(1X,''NIMAX='',I4,4X,''NJMAX='',I4,4X,''NKMAX='',I4,4X,''JPHEXT='', &
+& I2,5X,''JPVEXT='',I2)',NIMAX,NJMAX,NKMAX,JPHEXT,JPVEXT
+ PRINT '(1X,''NIL='',I4,4X,''NIH='',I4,4X,''NJL='',I4,4X,''NJH='',I4,4X &
+& ,''NKL='',I4,4X,''NKH='',I4)',NIL,NIH,NJL,NJH,NKL,NKH
+ PRINT '(1X,''LICP='',L1,18X,''LJCP='',L1,18X,''LKCP='',L1)', &
+ LICP,LJCP,LKCP
+ PRINT '(1X,''('',I4,'','',I4,'','',I4,'','',I4,'','',I1,'','',I2,'') ('',I4,'','',I1,'') ('', &
+ & I2,'') ('',I2,'') ('',I2,'') ('',I1,'') ('',I2,'','',I4,'')'')', &
+ SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4),SIZE(XVAR,5),SIZE(XVAR,6), &
+ SIZE(XTRAJT,1),SIZE(XTRAJT,2), SIZE(CTITRE),SIZE(CUNITE),SIZE(CCOMMENT), &
+ SIZE(NGRIDIA),SIZE(XDATIME,1),SIZE(XDATIME,2)
+ IF(CTYPE == 'MASK')THEN
+ PRINT '(1X,''('',I4,'','',I4,'','',I1,'','',I4,'','',I2,'','',I1,'')'')', &
+ SIZE(XMASK,1),SIZE(XMASK,2),SIZE(XMASK,3),SIZE(XMASK,4), &
+ SIZE(XMASK,5),SIZE(XMASK,6)
+ ENDIF
+ PRINT '(1X,78(1H*))'
+ IF(CTYPE == 'MASK')THEN
+! Juillet 2001
+ YMASK(:)(1:LEN(YMASK))=' '
+ DO J=1,9
+ WRITE(YC1,'(I1)')J
+ YMASK(J)(2:6)='MASK'//YC1
+ ENDDO
+ IM=SIZE(XVAR,5)
+ IF(IM > 9)THEN
+ DO J=10,IM
+ WRITE(YC2,'(I2)')J
+ YMASK(J)(2:7)='MASK'//YC2
+ ENDDO
+ ENDIF
+ PRINT '(10(1X,8(A8,''*''),/))',(YMASK(J),J=1,IM)
+ PRINT '(1X,78(1H*))'
+ ENDIF
+ CASE DEFAULT
+ PRINT *,' ******** GROUP: ',YGROUP2,' ******* TYPE: ',CTYPE,' ******* '
+ PRINT '(1X,78(1H*))'
+ GPRIGRP=.TRUE.
+ PRINT '(1X,''('',I4,'','',I4,'','',I4,'','',I6,'','',I2,'','',I2,'') ('',I6,'','',I2,'') ('', &
+ & I2,'','',I6,'','',I4,'')'')', &
+ SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4),SIZE(XVAR,5),SIZE(XVAR,6), &
+ SIZE(XTRAJT,1),SIZE(XTRAJT,2), SIZE(XTRAJX,1),SIZE(XTRAJX,2), &
+ SIZE(XTRAJX,3)
+ PRINT '(1X,''('',I4,'','',I6,'','',I4,'') ('',I4,'','',I6,'','',I4, &
+& '') ('',I4,'') ('',I4,'') ('',I4,'') ('',I4,'') ('',I2,'','',I6,'')'')',&
+ SIZE(XTRAJY,1),SIZE(XTRAJY,2),SIZE(XTRAJY,3), &
+ SIZE(XTRAJZ,1),SIZE(XTRAJZ,2),SIZE(XTRAJZ,3), &
+ SIZE(CTITRE),SIZE(CUNITE),SIZE(CCOMMENT), &
+ SIZE(NGRIDIA),SIZE(XDATIME,1),SIZE(XDATIME,2)
+ IF(SIZE(XVAR,5) > 1)THEN
+ PRINT '(1X,78(1H*))'
+ DO JLOOPN=1,SIZE(XVAR,5) ! Boucle sur les stations
+ IF(CTYPE == 'SSOL')THEN
+ INDN=1
+ ELSE
+ INDN=JLOOPN
+ ENDIF
+ YC5(1:LEN(YC5))=' '
+ WRITE(YC5,'(I5)')JLOOPN
+ IEK=SIZE(XVAR,3)
+ DO JA=1,1000000
+ IF(XTRAJZ(IEK,1,JLOOPN) == -1.E-15)THEN
+ IF(IEK == 1)THEN
+ EXIT
+ ELSE
+ IEK=IEK-1
+ ENDIF
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ IT=SIZE(XVAR,4)
+ DO JA=1,1000000
+ IF(XTRAJT(IT,INDN) == -1.E-15)THEN
+ IF(IT == 1)THEN
+ EXIT
+ ELSE
+ IT=IT-1
+ ENDIF
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ print '(1X,A4,'' N:'',A5,'' * XVAR('',I4,I4,I4,I6,'' ,,'',I4,'' )'')',CTYPE,YC5, &
+& SIZE(XVAR,1),SIZE(XVAR,2),IEK,IT,SIZE(XVAR,6)
+ ENDDO
+ PRINT '(1X,78(1H*))'
+ ENDIF
+ END SELECT
+ENDIF
+
+DO JLOOPN=1,SIZE(XVAR,5) ! Boucle sur les stations
+
+IF(INDPROC + INDTIME /= 0)THEN
+ IF(SIZE(XVAR,5) /= 1)THEN
+ YC5(1:LEN(YC5))=' '
+ WRITE(YC5,'(I5)')JLOOPN
+ print *,' ++++++++ ',CTYPE,' N:',YC5
+ PRINT '(1X,78(1H*))'
+ ENDIF
+ENDIF
+!
+! Impression des processus
+!
+IF(INDPROC /=0)THEN
+ IF(CTYPE == 'MASK' .AND. JLOOPN >1)THEN
+ ELSE
+
+ IF(.NOT.GPRIGRP)THEN
+ PRINT *,' ******** GROUP: ',YGROUP2,' ******* TYPE: ',CTYPE,' ******* '
+ PRINT '(1X,78(1H*))'
+ GPRIGRP=.TRUE.
+ ENDIF
+ PRINT '(1X,''g'',6X,''*'',7X,''TITRE'',7X,''*'',7X,''UNITE'',8X,''*'',10X,''COMMENT.'')'
+! PRINT '(8X,''*'',7X,''TITRE'',7X,''*'',7X,''UNITE'',8X,''*'',10X,''COMMENT.'')'
+ PRINT '(1X,78(1H*))'
+ DO JJ=1,SIZE(CTITRE)
+ YC2=' '
+ IF(JJ < 10)THEN
+ WRITE(YC2(1:1),'(I1)')JJ
+ ELSE
+ WRITE(YC2(1:2),'(I2)')JJ
+ ENDIF
+ CTITRE(JJ)=ADJUSTL(ADJUSTR(CTITRE(JJ)))
+ CUNITE(JJ)=ADJUSTL(ADJUSTR(CUNITE(JJ)))
+ CCOMMENT(JJ)=ADJUSTL(ADJUSTR(CCOMMENT(JJ)))
+ PRINT '(1X,I1,A6,''* '',A17,1X,''*'',1X,A18, &
+! PRINT '(1X,A6,'' * '',A17,1X,''*'',1X,A18, &
+& '' * '',A26)',NGRIDIA(JJ),'PROC'//YC2,CTITRE(JJ)(1:17), &
+!& '' * '',A26)','PROC'//YC2,CTITRE(JJ)(1:17), &
+ CUNITE(JJ)(1:18),CCOMMENT(JJ)(1:26)
+ IF(LEN_TRIM(CCOMMENT(JJ)) > 26 .OR. LEN_TRIM(CTITRE(JJ)) > 17 .OR. &
+ LEN_TRIM(CUNITE(JJ)) >18)THEN
+ PRINT '(8X,''* '',A17,'' * '',A18,'' * '',A26)', &
+ CTITRE(JJ)(18:34),CUNITE(JJ)(19:36), &
+ CCOMMENT(JJ)(27:52)
+ ENDIF
+ ENDDO
+ PRINT '(1X,78(1H*))'
+
+ ENDIF
+ENDIF
+
+!
+! Impression des temps
+!
+SELECT CASE(CTYPE)
+ CASE('DRST','RSPL','RAPL')
+ INDN=JLOOPN
+ CASE DEFAULT
+ INDN=1
+END SELECT
+IF(INDTIME /= 0)THEN
+ IF(.NOT.GPRIGRP)THEN
+ PRINT *,' ******** GROUP: ',YGROUP2,' ******* TYPE: ',CTYPE,' ******* '
+ PRINT '(1X,78(1H*))'
+ GPRIGRP=.TRUE.
+ ENDIF
+ YTIMES(:)(1:LEN(YTIMES))=' '
+ YTIME2(:)(1:LEN(YTIME2))=' '
+ DO J=1,9
+ WRITE(YC1,'(I1)')J
+ YTIMES(J:J)(2:6)='TIME'//YC1
+ ENDDO
+ IT=SIZE(XTRAJT,1)
+! print *,'IT INDN AV DO JA ',IT,INDN
+ DO JA=1,100000
+!print *,'on cerne le pb, JA',JA
+ IF(XTRAJT(IT,INDN) == -1.E-15)THEN
+ IF(IT == 1)THEN
+ EXIT
+ ELSE
+ IT=IT-1
+! print *,'on continue'
+ ENDIF
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+
+ IF(IT < 9)THEN
+ PRINT '(1X,8(A8,''*''))',(YTIMES(J),J=1,IT)
+ PRINT '(1X,78(1H*))'
+ PRINT '(1X,8(F8.0,''*''))',(XTRAJT(J,INDN),J=1,IT)
+! PRINT '(1X,8(F8.0,''*''))',(XTRAJT(J,1),J=1,IT)
+ PRINT '(1X,78(1H*))'
+ ELSE
+ PRINT '(1X,8(A8,''*''))',(YTIMES(J),J=1,8)
+ PRINT '(1X,78(1H*))'
+ PRINT '(1X,8(F8.0,''*''))',(XTRAJT(J,INDN),J=1,8)
+! PRINT '(1X,8(F8.0,''*''))',(XTRAJT(J,1),J=1,8)
+ PRINT '(1X,78(1H*))'
+ SELECT CASE(IT)
+ CASE(9:16)
+ DO J=10,IT
+ WRITE(YC2,'(I2)')J
+ YTIMES(J:J)(2:7)='TIME'//YC2
+ ENDDO
+ PRINT '(1X,8(A8,''*''))',(YTIMES(J),J=9,IT)
+ PRINT '(1X,78(1H*))'
+ PRINT '(1X,8(F8.0,''*''))',(XTRAJT(J,INDN),J=9,IT)
+! PRINT '(1X,8(F8.0,''*''))',(XTRAJT(J,1),J=9,IT)
+ PRINT '(1X,78(1H*))'
+ CASE(17:99)
+ IND=8
+ DO J=IT-8+1,IT
+ WRITE(YC2,'(I2)')J
+ IND=IND+1
+ YTIMES(IND)(2:7)='TIME'//YC2
+ ENDDO
+ PRINT '(1X,8(A8,''*''))',(YTIMES(J),J=9,16)
+ PRINT '(1X,78(1H*))'
+ PRINT '(1X,8(F8.0,''*''))',(XTRAJT(J,INDN),J=IT-8+1,IT)
+! PRINT '(1X,8(F8.0,''*''))',(XTRAJT(J,1),J=IT-8+1,IT)
+ PRINT '(1X,78(1H*))'
+ CASE(100:999)
+ IND=8
+ DO J=IT-8+1,IT
+ WRITE(YC3,'(I3)')J
+ IND=IND+1
+ YTIMES(IND)(1:7)='TIME'//YC3
+ ENDDO
+ PRINT '(1X,8(A8,''*''))',(YTIMES(J),J=9,16)
+ PRINT '(1X,78(1H*))'
+ PRINT '(1X,8(F8.0,''*''))',(XTRAJT(J,INDN),J=IT-8+1,IT)
+! PRINT '(1X,8(F8.0,''*''))',(XTRAJT(J,1),J=IT-8+1,IT)
+ PRINT '(1X,78(1H*))'
+ CASE(1000:9999)
+ IND=8
+ DO J=IT-8+1,IT
+ WRITE(YC4,'(I4)')J
+ IND=IND+1
+ YTIMES(IND)(1:8)='TIME'//YC4
+ ENDDO
+ PRINT '(1X,8(A8,''*''))',(YTIMES(J),J=9,16)
+ PRINT '(1X,78(1H*))'
+ PRINT '(1X,8(F8.0,''*''))',(XTRAJT(J,INDN),J=IT-8+1,IT)
+! PRINT '(1X,8(F8.0,''*''))',(XTRAJT(J,1),J=IT-8+1,IT)
+ PRINT '(1X,78(1H*))'
+ CASE(10000:)
+ IND=0
+ IF(IT >= 10000 .AND. IT <= 99999)THEN
+ DO J=IT-4+1,IT
+ WRITE(YC5,'(I5)')J
+ IND=IND+1
+ YTIME2(IND)(2:10)='TIME'//YC5
+ ENDDO
+ PRINT '(1X,4(A17,''*''))',(YTIME2(J),J=1,4)
+ PRINT '(1X,78(1H*))'
+ PRINT '(1X,4(F8.0,9X,''*''))',(XTRAJT(J,INDN),J=IT-4+1,IT)
+! PRINT '(1X,4(F8.0,9X,''*''))',(XTRAJT(J,1),J=IT-4+1,IT)
+ PRINT '(1X,78(1H*))'
+ ELSE
+ DO J=IT-4+1,IT
+ WRITE(YC6,'(I6)')J
+ IND=IND+1
+ YTIME2(IND)(2:11)='TIME'//YC6
+ ENDDO
+ PRINT '(1X,4(A17,''*''))',(YTIME2(J),J=1,4)
+ PRINT '(1X,78(1H*))'
+ PRINT '(1X,4(F8.0,9X,''*''))',(XTRAJT(J,INDN),J=IT-4+1,IT)
+! PRINT '(1X,4(F8.0,9X,''*''))',(XTRAJT(J,1),J=IT-4+1,IT)
+ PRINT '(1X,78(1H*))'
+ ENDIF
+ END SELECT
+ ENDIF
+ENDIF
+
+ENDDO ! Fin de boucle stations
+!
+! Impression de valeurs
+!
+IF(INDVAL /= 0)THEN
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ JLOOPP=1
+! JLOOPK=1; JLOOPT=1; JLOOPN=1; JLOOPP=1;
+ ILOOP=SIZE(XVAR,1)/6
+ IF(ILOOP * 6 < SIZE(XVAR,1))ILOOP=ILOOP+1
+! WRITE(INUM,'(1X,78(1H*))')
+ DO JLOOPN=1,SIZE(XVAR,5)
+ DO JLOOPT=1,SIZE(XVAR,4)
+ WRITE(INUM,'('' 6eme indice='',I4,'' 5eme indice='',I4,'' Time JLOOPT and val '',I4,1X,F10.0)')JLOOPP,JLOOPN,&
+ JLOOPT,XTRAJT(JLOOPT,JLOOPN)
+ DO JLOOPK=1,SIZE(XVAR,3)
+ WRITE(INUM,'('' K= '',I8)')JLOOPK
+ DO JLOOPI=1,ILOOP
+
+ IF(JLOOPI == 1)THEN
+ IDEB=1; IFIN=6
+ ELSE
+ IDEB=IFIN+1; IFIN=IFIN+6
+ ENDIF
+ IF(JLOOPI == ILOOP)THEN
+ IFIN=SIZE(XVAR,1)
+ ENDIF
+
+! PRINT '(1X,78(1H*))'
+! PRINT '(1X,6(5X,I3,5X))',(/(II,II=IDEB,IFIN)/)
+! PRINT '(1X,78(1H*))'
+ WRITE(INUM,'(1X,78(1H*))')
+ WRITE(INUM,'(1X,''I->'',2X,I4,5X,5(5X,I4,5X))')(/(II,II=IDEB,IFIN)/)
+ WRITE(INUM,'(1X,78(1H*))')
+
+ DO JLOOPJ=SIZE(XVAR,2),1,-1
+! PRINT '(1X,6E13.6)',(XVAR(II,JLOOPJ,JLOOPK,JLOOPT,JLOOPN,JLOOPP), &
+! II=IDEB,IFIN)
+ WRITE(INUM,'(I4,1X,6E12.5)')JLOOPJ,(XVAR(II,JLOOPJ,JLOOPK,JLOOPT,JLOOPN,JLOOPP), &
+ II=IDEB,IFIN)
+! WRITE(INUM,'(1X,6E13.6)')(XVAR(II,JLOOPJ,JLOOPK,JLOOPT,JLOOPN,JLOOPP), &
+ ENDDO
+! WRITE(INUM,'(1X,78(1H*))')
+! PRINT '(1X,78(1H*))'
+
+ ENDDO
+
+ ENDDO
+ ENDDO
+ ENDDO
+ENDIF
+
+DO JLOOPN=1,SIZE(XVAR,5) ! Boucle sur les stations
+
+SELECT CASE(CTYPE)
+ CASE('CART','MASK','SSOL','SPXY')
+ INDN=1
+ CASE DEFAULT
+ INDN=JLOOPN
+END SELECT
+
+IF(INDMNMX /= 0)THEN
+
+SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ IF(NIH-NIL /= 0)THEN
+ IF(NIL >= IIB)THEN
+ IDI=1
+ ELSE
+ IDI=IIB
+ ENDIF
+ IF(NIH <= IIE)THEN
+ IEI=SIZE(XVAR,1)
+ ELSE
+ IEI=IIE
+ ENDIF
+! Correction en Juillet 99 pour compatibilite avec les nouveaux masques(Nicole)
+ IF(CTYPE == 'MASK')THEN
+ IDI=1;IEI=1
+ ENDIF
+ ELSE
+ IDI=1; IEI=1
+ ENDIF
+
+ IF(NJH-NJL /= 0)THEN
+ IF(NJL >= IJB)THEN
+ IDJ=1
+ ELSE
+ IDJ=IJB
+ ENDIF
+ IF(NJH <= IJE)THEN
+ IEJ=SIZE(XVAR,2)
+ ELSE
+ IEJ=IJE
+ ENDIF
+! Correction en Juillet 99 pour compatibilite avec les nouveaux masques(Nicole)
+ IF(CTYPE == 'MASK')THEN
+ IDJ=1;IEJ=1
+ ENDIF
+ ELSE
+ IDJ=1; IEJ=1
+ ENDIF
+
+ IF(NKH-NKL /= 0)THEN
+ IF(NKL >= IKB)THEN
+ IDK=1
+ ELSE
+ IDK=IKB
+ ENDIF
+ IF(NKH <= IKE)THEN
+ IEK=SIZE(XVAR,3)
+ ELSE
+ IEK=IKE
+ ENDIF
+ ELSE
+ IDK=1; IEK=1
+ ENDIF
+ IT=SIZE(XVAR,4)
+
+ CASE DEFAULT
+
+ IDI=1; IEI=SIZE(XVAR,1)
+ IDJ=1; IEJ=SIZE(XVAR,2)
+ IDK=1; IEK=SIZE(XVAR,3)
+ DO JA=1,1000000
+ IF(XTRAJZ(IEK,1,JLOOPN) == -1.E-15)THEN
+ IF(IEK == 1)THEN
+ EXIT
+ ELSE
+ IEK=IEK-1
+ ENDIF
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+ IT=SIZE(XVAR,4)
+ DO JA=1,1000000
+ IF(XTRAJT(IT,INDN) == -1.E-15)THEN
+ IF(IT == 1)THEN
+ EXIT
+ ELSE
+ IT=IT-1
+ ENDIF
+ ELSE
+ EXIT
+ ENDIF
+ ENDDO
+END SELECT
+
+IF(SIZE(XVAR,5) /= 1)THEN
+ YC5(1:LEN(YC5))=' '
+ WRITE(YC5,'(I5)')JLOOPN
+ print *,' ******** ',CTYPE,' N:',YC5
+ENDIF
+
+ IF(.NOT.GPRIGRP)THEN
+ PRINT *,' ******** GROUP: ',YGROUP2,' ******* TYPE: ',CTYPE,' ******* '
+ PRINT '(1X,78(1H*))'
+ GPRIGRP=.TRUE.
+ ENDIF
+ PRINT '(7X,''PROC'',7X,''*'',11X,''MINVAL'',11X,''*'',11X,''MAXVAL'')'
+ PRINT '(46X,''MOY'')'
+ IF(LMNMXLOC)THEN
+ PRINT '(18X,''*'',4X,''MINLOC (i,j,k,t,n,p)'',4X,''*'',5X, &
+ & ''MAXLOC (i,j,k,t,n,p)'')'
+ PRINT '(6X,'' Expression des indices par / a (1,1,1,1,1,1) de la matrice'',&
+&'' consideree'')'
+ ENDIF
+ PRINT '(1X,78(1H*))'
+
+ ALLOCATE(GMASK(IEI-IDI+1,IEJ-IDJ+1,IEK-IDK+1,IT))
+ DO JLOOPP=1,SIZE(XVAR,6)
+ GMASK(:,:,:,:)=XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,1:IT,JLOOPN,JLOOPP) /= XSPVAL
+ ZMN=MINVAL(XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,1:IT,JLOOPN,JLOOPP), &
+ !MASK=XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,1:IT,JLOOPN,JLOOPP) /= XSPVAL)
+ MASK=GMASK)
+ ZMX=MAXVAL(XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,1:IT,JLOOPN,JLOOPP), &
+ !MASK=XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,1:IT,JLOOPN,JLOOPP) /= XSPVAL)
+ MASK=GMASK)
+ ZMOY=SUM(XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,1:IT,JLOOPN,JLOOPP), &
+ MASK=GMASK ) /COUNT(GMASK)
+ IF(LMNMXLOC)THEN
+ IMN(1:4)=MINLOC(XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,1:IT,JLOOPN,JLOOPP), &
+ !MASK=XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,1:IT,JLOOPN,JLOOPP) /= XSPVAL)
+ MASK=GMASK)
+ IMX(1:4)=MAXLOC(XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,1:IT,JLOOPN,JLOOPP), &
+ !MASK=XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,1:IT,JLOOPN,JLOOPP) /= XSPVAL)
+ MASK=GMASK)
+! ZMN=MINVAL(XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,:,JLOOPN,JLOOPP))
+! ZMX=MAXVAL(XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,:,JLOOPN,JLOOPP))
+! IMN(:)=MINLOC(XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,:,:,JLOOPP))
+! IMX(:)=MAXLOC(XVAR(IDI:IEI,IDJ:IEJ,IDK:IEK,:,:,JLOOPP))
+ IMN(1)=IMN(1)+IDI-1
+ IMN(2)=IMN(2)+IDJ-1
+ IMN(3)=IMN(3)+IDK-1
+ IMX(1)=IMX(1)+IDI-1
+ IMX(2)=IMX(2)+IDJ-1
+ IMX(3)=IMX(3)+IDK-1
+ IMN(5)=JLOOPN
+ IMX(5)=JLOOPN
+ ENDIF
+ CTITRE(JLOOPP)=ADJUSTL(ADJUSTR(CTITRE(JLOOPP)))
+ PRINT '(1X,A17,''*'',7X,E14.7,7X,''*'',7X,E14.7)', &
+ & CTITRE(JLOOPP)(1:17),ZMN,ZMX
+ PRINT '(40X,E14.7)',ZMOY
+
+ IF(LMNMXLOC)THEN
+! PRINT '(1X,17X,''*'',7X,E14.7,7X,''*'',7X,E14.7)',ZMN,ZMX
+ PRINT '(1X,A17,''*'','' ('',4(I4,1H,),I2,'','',I2, &
+ & '') * ('',4(I4,1H,),I2,'','',I2,'')'')', &
+ & CTITRE(JLOOPP)(1:17),IMN,JLOOPP,IMX,JLOOPP
+ ENDIF
+ ENDDO
+ DEALLOCATE(GMASK)
+ PRINT '(1X,78(1H*))'
+ENDIF
+
+ENDDO ! Fin boucle stations
+!
+CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+RETURN
+!
+!
+!------------------------------------------------------------------------------
+!
+!* 5. EXIT
+! ----
+!
+!
+END SUBROUTINE PRINTS
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/pro1d_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/pro1d_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..cec539a7e8f2e442564499ebd58ab619e8514ba1
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/pro1d_fordiachro.f90
@@ -0,0 +1,1498 @@
+! ######spl
+ SUBROUTINE PRO1D_FORDIACHRO(KPRO,PPRO,PTAB,PTABMIN,PTABMAX,KXDOT, &
+ HLEGEND,HTEXT)
+! ####################################################################
+!
+!!**** *PRO1D_FORDIACHRO* - Draws vertical profiles
+!!
+!! PURPOSE
+!! -------
+! Draws vertical profiles.
+!
+!!** METHOD
+!! ------
+!! The NCAR autograph utility is called with appropriate
+!! scaling and headers.
+!!
+!! EXTERNAL
+!! --------
+!! SET : defines the display window in normalized device !
+!! coordinate and user coordinate. !
+!! LABMOD : defines the label formats ! NCAR
+!! GRIDAL : draws axes, perimeter, ticks, and labels !
+!! GSCLIP : prevents out of window plotting !
+!! GSFAIS : color filling iusing GKS !
+!! PLCHHQ : prints high quality texts on graphics ! routines
+!! EZXY : compact utility to draw a Y=f(X) function plot !
+!! AGSETF : sets an NCAR parameter to a el value (AUTOGRAPH) !
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist (former PARA common)
+!! NIDEBCOU,NJDEBCOU : Origin of a vertical cross-section
+!! in grid index integer values
+!! (XIDEBCOU and XJDEBCOU must
+!! be = to -999.)
+!! XIDEBCOU,XJDEBCOU : Origin of a vertical cross-section
+!! in cartesian (or conformal) real values
+!! NLANGLE : Angle between X Meso-NH axis and
+!! cross-section direction in degrees
+!! (Integer value anticlockwise)
+!! XHMIN : Altitude of the vert. cross-section
+!! bottom (in meters above sea-level)
+!! XHMAX : Altitude of the vert. cross-section
+!! top (in meters above sea-level)
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NKMAX : z array dimension
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!! JPVEXT : Vertical external points number
+!!
+!! Module MODD_ALLVAR : contains generic variables arrays and structures
+!! L1DT : Logical identifying the current generic variable as a 1D
+!! scalar variable when .TRUE. No signification otherwise.
+!!
+!! Module MODD_GRID1 : declares grid variables (Model module)
+!! XZZ : true gridpoint z altitude
+!!
+!! Module MODD_SUPER : defines plot overlay control variables
+!! LSUPER : =.TRUE. --> plot overlay is active
+!! =.FALSE. --> plot overlay is not active
+!! NSUPER : Rank of the current plot in the overlay
+!! sequence. The initial plot is rank 1.
+!! Module MODD_TITLE : Declares heading variables for the plots (TRACE)
+!! CLEGEND2 : Current plot heading title
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 13/01/95
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+
+USE MODN_NCAR
+USE MODN_PARA
+USE MODD_PARAMETERS
+USE MODD_RESOLVCAR
+USE MODD_ALLVAR
+USE MODD_GRID1
+USE MODD_CONF
+USE MODD_DEFCV
+USE MODD_SUPER
+USE MODD_TITLE
+USE MODD_OUT
+USE MODD_TYPE_AND_LH
+USE MODD_TIT
+USE MODD_EXPERIM
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_CTL_AXES_AND_STYL
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments and results
+!
+INTEGER :: KPRO ! Profile gridpont index along section x-axis
+REAL,DIMENSION(:) :: PPRO ! Data array to be plotted
+REAL,DIMENSION(:) :: PTAB ! Altitude array for the profile
+REAL :: PTABMIN ! Minimum altitude of the profile
+REAL :: PTABMAX ! Maximum altitude of the profile
+INTEGER :: KXDOT ! Number of major division along abscissa
+CHARACTER(LEN=*) :: HLEGEND ! Name of the variable header
+CHARACTER(LEN=*) :: HTEXT ! General header
+!
+!* 0.2 Local variables
+!
+INTEGER :: INTERVAL
+INTEGER :: IKE,IKB
+INTEGER :: IK
+INTEGER,SAVE :: ICOL, ISTYL, IERR
+INTEGER,SAVE :: I1D, NSUP
+INTEGER :: ID, IND1, ILENC
+INTEGER :: IKL, IKH, JB
+INTEGER,SAVE :: ISUIT, ISUI, INDISTM, ISTOK
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: ISTM
+!
+REAL :: Z1, Z2, ZX1, ZX2
+REAL,SAVE :: ZLWSC, ZSC
+REAL,SAVE :: ZSCMIN
+REAL,SAVE :: ZHMIN, ZHMAX
+REAL,SAVE :: ZMNM, ZMXM
+REAL :: ZVL, ZVR, ZVB, ZVT, ZWL, ZWR, ZWB, ZWT
+REAL :: ZDEBX, ZECART1, ZECART2
+REAL :: ZXPOSTITT1, ZXYPOSTITT1
+REAL :: ZXPOSTITT2, ZXYPOSTITT2
+REAL :: ZXPOSTITT3, ZXYPOSTITT3
+REAL :: ZXPOSTITB1, ZXYPOSTITB1
+REAL :: ZXPOSTITB2, ZXYPOSTITB2
+REAL :: ZXPOSTITB3, ZXYPOSTITB3
+REAL,DIMENSION(2) :: ZX(2), ZY(2)
+REAL,DIMENSION(2) :: ZXZERO(2), ZYZERO(2)
+!
+CHARACTER(LEN=80),SAVE :: YCARCOU
+CHARACTER(LEN=80),SAVE :: YCAR
+CHARACTER(LEN=40) :: YTEX
+CHARACTER(LEN=100) :: YTEM
+CHARACTER(LEN=100) :: YTITB3
+CHARACTER(LEN=8) :: YT
+CHARACTER(LEN=10) :: FORMAX, FORMAY
+!
+!----------------------------------------------------------------------
+!!!!!!!!!!! 110797
+!ZHMIN=XHMIN; ZHMAX=XHMAX
+!!!!!!!!!!! 110797
+!CALL GQLN (IERR,ISTYL)
+print *,' +++pro1d entree ISTYL ',ISTYL,' CVARNPV1 ',CVARNPV1(1:LEN(CVARNPV1))
+YTEX(1:LEN(YTEX))=' '
+!
+!* 1. DISPLAY ENVIRONMENT SETUP AND PROFILE DRAWING
+! ---------------------------------------------
+!
+!* 1.1 Array size calculation
+!
+!IK=SIZE(PPRO,1)
+SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ IKB=1+JPVEXT
+ IKE=NKMAX+JPVEXT
+ IK=(MIN(NKH,IKE)-MAX(NKL,IKB))+1
+ CASE('SSOL','DRST','RSPL','RAPL')
+ IKB=1
+ IKE=SIZE(PPRO)
+ IK=IKE
+ IKL=NKL
+ IKH=NKH
+ NKL=IKB
+ NKH=IKE
+END SELECT
+!
+!WRITE(YCARCOU,1000)NIDEBCOU,NJDEBCOU,NLANGLE,KPRO
+!1000 FORMAT(' Oblique section IDEB=',I2,' JDEB=',I2,' ANG.=',I3, &
+!' IPRO=',I3)
+!
+!* 1.2 Sets NCAR viewport and window
+!
+IF(LVPTPVUSER)THEN
+ ZX1=XVPTPVL; ZX2=XVPTPVR; Z1=XVPTPVB; Z2=XVPTPVT
+ELSE
+ Z1=0.1
+ Z2=0.9
+!Z2=0.1+AMIN1(0.85,(XHMAX-XHMIN)/10000.)
+ ZX1=0.13
+ ZX2=0.9
+ENDIF
+!
+IF(XHMAX > XHMIN)THEN
+ELSE
+SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ XHMIN=0.
+ XHMAX=XZZ(1,1,IKE)
+ CASE('SSOL','DRST','RSPL')
+ XHMIN=PPRO(1)
+ XHMAX=PPRO(IK)
+ CASE('RAPL')
+ IF(PPRO(1) < PPRO(IK))THEN
+ XHMIN=PPRO(1)
+ XHMAX=PPRO(IK)
+ ELSE
+ XHMIN=PPRO(IK)
+ XHMAX=PPRO(1)
+ ENDIF
+END SELECT
+
+END IF
+CALL SET(ZX1,ZX2,Z1,Z2,PTABMIN,PTABMAX,XHMIN,XHMAX,1)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!JDJD
+!
+!* 1.3 Actually draws the profile
+!
+CALL AGSETF('SET.',4.) ! autograph uses the last SET values
+CALL AGSETF('BAC.',4.) ! no perimeter drawn
+CALL AGSETF('FRA.',2.) ! no frame advance
+!!!!!Oct 99
+CALL GQLN (IERR,ISTYL)
+!print *,' +++pro1d ISTYL ',ISTYL
+ISTYL=ISTYL+NGSLNP
+IF(ISTYL == 1)CALL AGSETR('DAS/PA/1.',65535.)
+IF(ISTYL == 2)CALL AGSETR('DAS/PA/1.',30583.)
+IF(ISTYL == 3)CALL AGSETR('DAS/PA/1.',21845.)
+IF(ISTYL == 4)CALL AGSETR('DAS/PA/1.',10023.)
+IF(ISTYL == 5)CALL AGSETR('DAS/PA/1.',16191.)
+IF(ISTYL == 6)CALL AGSETR('DAS/PA/1.',990.)
+IF(ISTYL == 7)CALL AGSETR('DAS/PA/1.',3855.)
+IF(ISTYL == 8)CALL AGSETR('DAS/PA/1.',24415.)
+IF(ISTYL == 9)CALL AGSETR('DAS/PA/1.',13107.)
+IF(ISTYL == 10)CALL AGSETR('DAS/PA/1.',63903.)
+call gsln(1)
+CALL AGSETR('DAS/SE.',1.)
+if(nverbia >0)then
+print *,' +++pro1d AV EZXY ISTYL ',ISTYL
+endif
+!!!!!Oct 99
+CALL EZXY(PTAB(MAX(NKL,IKB):MIN(NKH,IKE)), &
+ PPRO(MAX(NKL,IKB):MIN(NKH,IKE)),IK,0) ! calls autograph
+!!!!!!!!!!!!!!JD Mars 2009 Ligne zero sur PV
+IF(LINZEROPV)THEN
+ IF(NSTYLINZEROPV == 1)CALL AGSETR('DAS/PA/1.',65535.)
+ IF(NSTYLINZEROPV == 2)CALL AGSETR('DAS/PA/1.',30583.)
+ IF(NSTYLINZEROPV == 3)CALL AGSETR('DAS/PA/1.',21845.)
+ IF(NSTYLINZEROPV == 4)CALL AGSETR('DAS/PA/1.',10023.)
+ IF(NSTYLINZEROPV == 5)CALL AGSETR('DAS/PA/1.',16191.)
+ IF(NSTYLINZEROPV == 6)CALL AGSETR('DAS/PA/1.',990.)
+ IF(NSTYLINZEROPV == 7)CALL AGSETR('DAS/PA/1.',3855.)
+ IF(NSTYLINZEROPV == 8)CALL AGSETR('DAS/PA/1.',24415.)
+ IF(NSTYLINZEROPV == 9)CALL AGSETR('DAS/PA/1.',13107.)
+ IF(NSTYLINZEROPV == 10)CALL AGSETR('DAS/PA/1.',63903.)
+CALL GSLN(NSTYLINZEROPV)
+ ZXZERO(1:2)=0.
+ ZYZERO(1)=XHMIN
+ ZYZERO(2)=XHMAX
+ CALL CURVED(ZXZERO,ZYZERO,2)
+ENDIF
+!!!!!!!!!!!!!!JD Mars 2009 Ligne zero sur PV
+!!!!!Oct 99
+CALL GSLN(ISTYL)
+!!!!!Oct 99
+IF(LSUPER)THEN
+ CALL GQPLCI(IERR,ICOL)
+! CALL GQLN (IERR,ISTYL)
+END IF
+CALL GQLN (IERR,ISTYL)
+CALL GQLWSC(IERR,ZLWSC)
+CALL GSLN(1) ! solid line restored
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+CALL GSLWSC(1.)
+SELECT CASE(CTYPE)
+ CASE('SSOL','DRST','RSPL','RAPL')
+ NKL=IKL
+ NKH=IKH
+END SELECT
+!
+!* 1.4 Prints the tick labels
+!
+IF(NPVITVYMJ /= 0)THEN
+ INTERVAL=NPVITVYMJ
+ELSE
+IF(XHMAX-XHMIN < 2000.)THEN
+ INTERVAL=5
+ELSE
+ INTERVAL=NINT((XHMAX-XHMIN)/1000.)
+ENDIF
+ENDIF
+FORMAX=' '
+IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ENDIF
+ FORMAY=' '
+IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ELSE
+ FORMAY='(F6.0)'
+ENDIF
+FORMAY=ADJUSTL(FORMAY)
+!print *,' FORMAX,FORMAY ',FORMAX
+!print *,' FORMAX,FORMAY ',FORMAY
+
+IF(.NOT.LSUPER)THEN !00000000000000000000000000000000
+
+ IF(LFMTAXEX .AND. LFMTAXEY)THEN !Aout 2000
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0) ! sets label format ...
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0) ! sets label format ...
+ ELSE IF(LFMTAXEX)THEN
+ CALL LABMOD(FORMAX,'(F6.0)',0,0,NSZLBX,NSZLBY,0,0,0) ! sets label format ...
+! CALL LABMOD(FORMAX,'(F6.0)',0,0,10,10,0,0,0) ! sets label format ...
+ ELSE
+ IF(PTABMAX /= 0.)THEN
+! IF(LOG10(ABS(PTABMAX)).GE.6. .OR. LOG10(ABS(PTABMAX)).LE. -1.)THEN
+ IF(LOG10(ABS(PTABMAX)).GE.6. .OR. LOG10(ABS(PTABMAX)).LT. 0.)THEN
+ CALL LABMOD('(E8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,0,0) ! sets label format ...
+! CALL LABMOD('(E8.2)',FORMAY,0,0,10,10,0,0,0) ! sets label format ...
+! CALL LABMOD('(E8.2)','(F6.0)',0,0,10,10,0,0,0) ! sets label format ...
+ ELSE
+ IF(PTABMIN /= 0. .AND. (LOG10(ABS(PTABMIN)).GE.5. .OR. LOG10(ABS(PTABMIN)) &
+ .LT. 0.))THEN
+! .LE. -1.))THEN
+ CALL LABMOD('(E8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD('(E8.2)',FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(F6.0)',0,0,10,10,0,0,0)
+ ELSE IF(ABS(PTABMAX-PTABMIN) <= 1.)THEN
+! ELSE IF(ABS(PTABMAX-PTABMIN) < 1.)THEN
+ CALL LABMOD('(F8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+ CALL LABMOD('(F8.2)',FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(F6.0)',0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(F6.0)',8,6,10,10,0,0,0)
+ ELSE
+ IF(PTABMIN <0)THEN
+ CALL LABMOD('(F9.1)',FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD('(F9.1)',FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.0)',FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.0)','(F6.0)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD('(F8.1)',FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD('(F8.1)',FORMAY,0,0,10,10,0,0,0)
+! print *,' format F8.1 ************pro1d'
+! CALL LABMOD('(F8.1)','(F6.0)',0,0,10,10,0,0,0)
+ ENDIF
+ END IF
+ END IF
+ ELSE
+! PTABMAX = 0.
+ IF(PTABMIN /= 0. .AND. (LOG10(ABS(PTABMIN)).GE.5. .OR. LOG10(ABS(PTABMIN)) &
+ .LT. 0.))THEN
+! .LE. -1.))THEN
+ CALL LABMOD('(E8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD('(E8.2)',FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(F6.0)',0,0,10,10,0,0,0)
+ ELSE IF(ABS(PTABMAX-PTABMIN) <= 1.)THEN
+! ELSE IF(ABS(PTABMAX-PTABMIN) < 1.)THEN
+ CALL LABMOD('(F8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD('(F8.2)',FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(F6.0)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD('(F9.1)',FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD('(F9.1)',FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.0)',FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.0)','(F6.0)',0,0,10,10,0,0,0)
+ END IF
+
+ ENDIF
+
+ ENDIF !Aout 2000
+
+ CALL GASETI('LTY',1) ! High quality perimeter font
+! Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(KXDOT,NPVITVXMN,INTERVAL,NPVITVYMN,0,0,5,0,0) ! draws perimeter and labels
+ ELSEIF(LNOLABELX .AND. .NOT. LNOLABELY)THEN
+ CALL GRIDAL(KXDOT,NPVITVXMN,INTERVAL,NPVITVYMN,0,1,5,0,0) ! draws perimeter and labels
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(KXDOT,NPVITVXMN,INTERVAL,NPVITVYMN,1,0,5,0,0) ! draws perimeter and labels
+ ELSE
+ CALL GRIDAL(KXDOT,NPVITVXMN,INTERVAL,NPVITVYMN,1,1,5,0,0) ! draws perimeter and labels
+ ENDIF
+! Avril 2002
+! CALL GRIDAL(KXDOT,1,INTERVAL,1,1,1,5,0,0) ! draws perimeter and labels
+
+ELSE !00000000000000000000000000000000
+
+ CALL GASETI('LTY',1) ! High quality perimeter font
+ SELECT CASE(NSUPER)
+ CASE(1)
+ NSUP=NSUPER
+ ZSCMIN=999.
+ ZMNM=PTABMIN
+ ZMXM=PTABMAX
+
+ IF(LFMTAXEX)THEN ! Aout 2000
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,3+(NSUPER-1)*15,0)
+ ELSE
+
+ IF(PTABMAX /= 0.)THEN
+ IF(LOG10(ABS(PTABMAX)).GE.6. .OR. LOG10(ABS(PTABMAX)).LT. 0.)THEN
+! IF(LOG10(ABS(PTABMAX)).GE.6. .OR. LOG10(ABS(PTABMAX)).LE. -1.)THEN
+ CALL LABMOD('(E8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(E8.2)',FORMAY,0,0,10,10,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(E8.2)','(F6.0)',0,0,10,10,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(E8.2)','(F6.0)',8,6,10,10,0,3+(NSUPER-1)*15,0)
+ ELSE
+ IF(PTABMIN /= 0. .AND. (LOG10(ABS(PTABMIN)).GE.5. .OR. LOG10(ABS(PTABMIN)) &
+ .LT. 0.))THEN
+! .LE. -1.))THEN
+ CALL LABMOD('(E8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(E8.2)',FORMAY,0,0,10,10,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(E8.2)','(F6.0)',0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(F6.0)',8,6,10,10,0,0,0)
+ ELSE IF(ABS(PTABMAX-PTABMIN) <= 1.)THEN
+! ELSE IF(ABS(PTABMAX-PTABMIN) < 1.)THEN
+ CALL LABMOD('(F8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(F8.2)',FORMAY,0,0,10,10,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(F8.2)','(F6.0)',0,0,10,10,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(F8.2)','(F6.0)',8,6,10,10,0,3+(NSUPER-1)*15,0)
+ ELSE
+ CALL LABMOD('(F9.1)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(F9.1)',FORMAY,0,0,10,10,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(F8.0)',FORMAY,0,0,10,10,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(F8.0)','(F6.0)',0,0,10,10,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(F8.0)','(F6.0)',8,6,10,10,0,3+(NSUPER-1)*15,0)
+ END IF
+ END IF
+ ELSE
+ ! PTABMAX = 0.
+ IF(PTABMIN /= 0. .AND. (LOG10(ABS(PTABMIN)).GE.5. .OR. LOG10(ABS(PTABMIN)) &
+ .LT. 0.))THEN
+! .LE. -1.))THEN
+ CALL LABMOD('(E8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(E8.2)',FORMAY,0,0,10,10,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(E8.2)','(F6.0)',0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(F6.0)',8,6,10,10,0,0,0)
+ ELSE IF(ABS(PTABMAX-PTABMIN) <= 1.)THEN
+! ELSE IF(ABS(PTABMAX-PTABMIN) < 1.)THEN
+ CALL LABMOD('(F8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(F8.2)',FORMAY,0,0,10,10,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(F8.2)','(F6.0)',0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(F6.0)',8,6,10,10,0,0,0)
+ ELSE
+ CALL LABMOD('(F9.1)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(F9.1)',FORMAY,0,0,10,10,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(F8.0)',FORMAY,0,0,10,10,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD('(F8.0)','(F6.0)',0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.0)','(F6.0)',8,6,10,10,0,0,0)
+ END IF
+
+ ENDIF
+
+ ENDIF ! Aout 2000
+
+! CALL GRIDAL(KXDOT,1,INTERVAL,1,1,1,5,0,0) ! draws perimeter and labels
+! Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(KXDOT,NPVITVXMN,INTERVAL,NPVITVYMN,0,0,5,0,0) ! draws perimeter and labels
+ ELSEIF(LNOLABELX .AND. .NOT. LNOLABELY)THEN
+ CALL GRIDAL(KXDOT,NPVITVXMN,INTERVAL,NPVITVYMN,0,1,5,0,0) ! draws perimeter and labels
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(KXDOT,NPVITVXMN,INTERVAL,NPVITVYMN,1,0,5,0,0) ! draws perimeter and labels
+ ELSE
+ CALL GRIDAL(KXDOT,NPVITVXMN,INTERVAL,NPVITVYMN,1,1,5,0,0) ! draws perimeter and labels
+ ENDIF
+! Avril 2002
+ CASE(2:)
+ IF(PTABMIN == ZMNM .AND. PTABMAX == ZMXM)THEN
+ ELSE
+ NSUP=NSUP+1
+ IF (NSUP > 3)THEN
+ WRITE(NLUOUT,*)' ** PRO1D_FORDIACHRO NB DE SUPERPOSITIONS TROP ELEVE. IMPOSSIBILITE D''ECRIRE LES BORNES '
+ WRITE(NLUOUT,*)' DES VARIABLES INSCRITES A DROITE DU DESSIN'
+ WRITE(NLUOUT,*)' ** IL SUFFIRAIT PEUT-ETRE DE METTRE EN TETE DES VAR. a SUPERPOSER CELLE DONT '
+ WRITE(NLUOUT,*)' LES BORNES ENGLOBENT LES LIMITES DES AUTRES'
+ ELSE
+
+ IF(LFMTAXEX)THEN ! Aout 2000
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUPER-1)*15,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,3+(NSUPER-1)*15,0)
+ ELSE
+
+ IF(PTABMAX /= 0.)THEN
+ IF(LOG10(ABS(PTABMAX)).GE.6. .OR. LOG10(ABS(PTABMAX)).LT. 0.)THEN
+! IF(LOG10(ABS(PTABMAX)).GE.6. .OR. LOG10(ABS(PTABMAX)).LE. -1.)THEN
+ CALL LABMOD('(E8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(E8.2)',FORMAY,0,0,10,10,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(E8.2)','(F6.0)',0,0,10,10,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(E8.2)','(F6.0)',8,6,10,10,0,3+(NSUP-1)*15,0)
+ ELSE
+ IF(PTABMIN /= 0. .AND. (LOG10(ABS(PTABMIN)).GE.5. .OR. LOG10(ABS(PTABMIN)) &
+ .LT. 0.))THEN
+! .LE. -1.))THEN
+ CALL LABMOD('(E8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(E8.2)',FORMAY,0,0,10,10,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(E8.2)','(F6.0)',0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(F6.0)',8,6,10,10,0,0,0)
+ ELSE IF(ABS(PTABMAX-PTABMIN) <= 1.)THEN
+! ELSE IF(ABS(PTABMAX-PTABMIN) < 1.)THEN
+ CALL LABMOD('(F8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(F8.2)',FORMAY,0,0,10,10,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(F8.2)','(F6.0)',0,0,10,10,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(F8.2)','(F6.0)',8,6,10,10,0,3+(NSUP-1)*15,0)
+ ELSE
+ CALL LABMOD('(F9.1)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(F9.1)',FORMAY,0,0,10,10,0,3+(NSUP-1)*15,0)
+! print *,' format f9.1 **********pro1d'
+! CALL LABMOD('(F8.0)',FORMAY,0,0,10,10,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(F8.0)','(F6.0)',0,0,10,10,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(F8.0)','(F6.0)',8,6,10,10,0,3+(NSUP-1)*15,0)
+ END IF
+ END IF
+ ELSE
+ ! PTABMAX = 0.
+ IF(PTABMIN /= 0. .AND. (LOG10(ABS(PTABMIN)).GE.5. .OR. LOG10(ABS(PTABMIN)) &
+ .LT. 0.))THEN
+! .LE. -1.))THEN
+ CALL LABMOD('(E8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(E8.2)',FORMAY,0,0,10,10,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(E8.2)','(F6.0)',0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(F6.0)',8,6,10,10,0,0,0)
+ ELSE IF(ABS(PTABMAX-PTABMIN) <= 1.)THEN
+! ELSE IF(ABS(PTABMAX-PTABMIN) < 1.)THEN
+ CALL LABMOD('(F8.2)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(F8.2)',FORMAY,0,0,10,10,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(F8.2)','(F6.0)',0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(F6.0)',8,6,10,10,0,0,0)
+ ELSE
+ CALL LABMOD('(F9.1)',FORMAY,0,0,NSZLBX,NSZLBY,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(F9.1)',FORMAY,0,0,10,10,0,3+(NSUP-1)*15,0)
+! CALL LABMOD('(F8.0)',FORMAY,0,0,10,10,0,3+(NSUP-1)*15,0)
+! print *,' format f9.1 **********pro1d'
+! CALL LABMOD('(F8.0)','(F6.0)',0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.0)','(F6.0)',8,6,10,10,0,0,0)
+ END IF
+
+ ENDIF
+
+ ENDIF ! Aout 2000
+
+! CALL GRIDAL(KXDOT,1,INTERVAL,1,1,1,5,0,0) ! draws perimeter and labels
+! Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(KXDOT,NPVITVXMN,INTERVAL,NPVITVYMN,0,0,5,0,0) ! draws perimeter and labels
+ ELSEIF(LNOLABELX .AND. .NOT. LNOLABELY)THEN
+ CALL GRIDAL(KXDOT,NPVITVXMN,INTERVAL,NPVITVYMN,0,1,5,0,0) ! draws perimeter and labels
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(KXDOT,NPVITVXMN,INTERVAL,NPVITVYMN,1,0,5,0,0) ! draws perimeter and labels
+ ELSE
+ CALL GRIDAL(KXDOT,NPVITVXMN,INTERVAL,NPVITVYMN,1,1,5,0,0) ! draws perimeter and labels
+ ENDIF
+! Avril 2002
+ CALL GSPLCI(ICOL)
+! Oct 99
+! CALL GSLN(ISTYL)
+ CALL GSLN(1)
+ CALL AGSETR('DAS/SE.',1.)
+! Oct 99
+ CALL GSLWSC(ZLWSC)
+ ZX(1)=PTABMIN+((MIN(0.06+ZX2,.96)-ZX1)*ABS(PTABMAX-PTABMIN)/(ZX2-ZX1))
+! ZX(1)=PTABMIN+((0.96-ZX1)*ABS(PTABMAX-PTABMIN)/(ZX2-ZX1))
+ ZX(2)=PTABMIN+((MIN(0.10+ZX2,1.)-ZX1)*ABS(PTABMAX-PTABMIN)/(ZX2-ZX1))
+! ZX(2)=PTABMIN+((1.00-ZX1)*ABS(PTABMAX-PTABMIN)/(ZX2-ZX1))
+ ZY(1)=XHMIN-ABS(((XHMAX-XHMIN)*(3+10+(NSUP-1)*15))/((Z2-Z1)*1024.))
+ ZY(2)=ZY(1)
+ CALL GSCLIP(0)
+! Oct 99
+ if(nverbia > 0)then
+ print *,' AV CURVED'
+ endif
+ CALL CURVED(ZX,ZY,2)
+! CALL GPL(2,ZX,ZY)
+! Semble inutile
+! CALL GSLN(ISTYL)
+! Semble inutile
+! Oct 99
+! CALL GSCLIP(1)
+ CALL GSLWSC(1.)
+ END IF
+ CALL GSPLCI(1)
+ CALL GSLN(1)
+ CALL GSLWSC(1.)
+ END IF
+ END SELECT
+END IF !00000000000000000000000000000000
+CALL GSCLIP(0) ! suppress clipping
+!CALL PLCHHQ((PTABMIN-(PTABMAX-PTABMIN)/(ZX2-ZX1)*ZX1),XHMIN+(XHMAX-XHMIN)/2., &
+!'ALTITUDE',.012,0.,-1.)
+!CALL PLCHHQ((PTABMIN-(PTABMAX-PTABMIN)/(ZX2-ZX1)*ZX1),XHMIN+(XHMAX-XHMIN)/2.4, &
+!'(M)',.012,0.,-1.)
+!
+!* 1.5 Headers printing with pretty font,
+!* and possible overlay
+!
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+XCURVPTL=ZVL;XCURVPTR=ZVR;XCURVPTB=ZVB;XCURVPTT=ZVT
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+!IF(LFACTIMP)THEN
+! CALL FACTIMP
+!ENDIF
+!
+! Page headers
+!
+IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN
+
+IF(LFACTIMP )THEN
+ CALL FACTIMP
+ENDIF
+ ZXPOSTITB1=.002
+ ZXYPOSTITB1=.005
+ IF(XPOSTITB1 /= 0.)THEN
+ ZXPOSTITB1=XPOSTITB1
+ ENDIF
+ IF(XYPOSTITB1 /= 0.)THEN
+ ZXYPOSTITB1=XYPOSTITB1
+ ENDIF
+
+ CALL RESOLV_TIT('CTITB1',HLEGEND)
+ IF(HLEGEND /= ' ')THEN
+ IF(XSZTITB1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HLEGEND,XSZTITB1,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,HLEGEND,XSZTITB1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HLEGEND,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,HLEGEND,.007,0.,-1.)
+ ENDIF
+ ENDIF
+ ZXPOSTITB2=.002
+ ZXYPOSTITB2=.025
+ IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ ENDIF
+ IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ ENDIF
+ CALL RESOLV_TIT('CTITB2',CLEGEND2)
+ IF(CLEGEND2 /= ' ')THEN
+ IF(XSZTITB2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,XSZTITB2,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,CLEGEND2,XSZTITB2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
+ ENDIF
+ ENDIF
+! Titres en X
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/2.,.05),YTEM,XSZTITXL,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),XSZTITXM,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ CALL PLCHHQ(ZVR,ZVB-MIN(ZVB/2.,.05),YTEM,XSZTITXR,0.,+1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ if(nverbia > 0)then
+ print *,' ***pro1d 627'
+ endif
+! Titres en Y
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYT',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ YTEM='ALTITUDE;(M)'
+ CALL RESOLV_TITY('CTITYM',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYB',ZVL,ZVR,ZVB,ZVT,YTEM)
+! Titres TOP
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT3',YTEM)
+ ZXPOSTITT3=.002
+ ZXYPOSTITT3=.93
+ IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ ENDIF
+ IF(XYPOSTITT3 /= 0.)THEN
+ ZXYPOSTITT3=XYPOSTITT3
+ ENDIF
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,XSZTITT3,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+
+ENDIF
+!
+! Profile location
+!
+IF(L1DT)THEN
+ if(nverbia > 0)then
+ print *,' ***pro1d L1DT=T'
+ endif
+ SELECT CASE(CTYPE)
+ CASE('CART','MASK')
+ IF(NIL == 1 .OR. NJL == 1)THEN
+ WRITE(YCARCOU,1002)
+ ELSE
+ WRITE(YCARCOU,1012)NIL,NJL
+ ENDIF
+ YCAR(1:LEN(YCAR))=' '
+ if(nverbia > 0)then
+ print *,' ***pro1d 675'
+ endif
+
+ CASE('SSOL')
+ IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN
+ YCARCOU(1:LEN(YCARCOU))=' '
+ YCAR(1:LEN(YCAR))=' '
+ YCARCOU(1:7)='SSOL N.'
+ WRITE(YCARCOU(8:10),'(I3)')NLOOPN
+ YCARCOU(11:13)=' ('
+ WRITE(YCARCOU(14:18),'(F5.0)')XTRAJX(1,1,NLOOPN)
+ YCARCOU(19:19)=','
+ WRITE(YCARCOU(20:24),'(F5.0)')XTRAJY(1,1,NLOOPN)
+ YCARCOU(25:27)=') '
+ ISUIT=28
+ ISUI=8
+ IF(ALLOCATED(ISTM))THEN
+ DEALLOCATE(ISTM)
+ ENDIF
+ ALLOCATE(ISTM(NSUPERDIA))
+ INDISTM=1
+ ISTM(INDISTM)=NLOOPN
+ ELSE IF(LSUPER .AND. NSUPER > 1)THEN
+ ISTOK=0
+ DO JB=1,INDISTM
+ IF(NLOOPN == ISTM(JB))THEN
+ ISTOK=1
+ ENDIF
+ ENDDO
+ IF(ISTOK == 1)THEN
+ ELSE
+ INDISTM=INDISTM+1
+ ISTM(INDISTM)=NLOOPN
+ IF(ISUIT > 50)THEN
+ WRITE(YCAR(ISUI:ISUI+3),'(I4)')NLOOPN
+ YCAR(ISUI+4:ISUI+6)=' ('
+ WRITE(YCAR(ISUI+7:ISUI+11),'(F5.0)')XTRAJX(1,1,NLOOPN)
+ ISUI=ISUI+12
+ YCAR(ISUI:ISUI)=','
+ ISUI=ISUI+1
+ WRITE(YCAR(ISUI:ISUI+4),'(F5.0)')XTRAJY(1,1,NLOOPN)
+ ISUI=ISUI+5
+ YCAR(ISUI:ISUI+2)=') '
+ ISUI=ISUI+3
+ ELSE
+ WRITE(YCARCOU(ISUIT:ISUIT+3),'(I4)')NLOOPN
+ YCARCOU(ISUIT+4:ISUIT+6)=' ('
+ WRITE(YCARCOU(ISUIT+7:ISUIT+11),'(F5.0)')XTRAJX(1,1,NLOOPN)
+ ISUIT=ISUIT+12
+ YCARCOU(ISUIT:ISUIT)=','
+ ISUIT=ISUIT+1
+ WRITE(YCARCOU(ISUIT:ISUIT+4),'(F5.0)')XTRAJY(1,1,NLOOPN)
+ ISUIT=ISUIT+5
+ YCARCOU(ISUIT:ISUIT+2)=') '
+ ISUIT=ISUIT+3
+ ENDIF
+ ENDIF
+ ENDIF
+ CASE DEFAULT
+ if(nverbia > 0)then
+ print *,' ***pro1d CASE DEFAULT'
+ endif
+ IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == 1))THEN
+ YCARCOU(1:LEN(YCARCOU))=' '
+ YCAR(1:LEN(YCAR))=' '
+ YCARCOU(1:4)=CTYPE
+ YCARCOU(5:7)=' N.'
+ WRITE(YCARCOU(8:10),'(I3)')NLOOPN
+ if(nverbia > 0)then
+ print *,' ***pro1d YCARCOU',YCARCOU(1:LEN_TRIM(YCARCOU))
+ endif
+ ISUIT=11
+ IF(ALLOCATED(ISTM))THEN
+ DEALLOCATE(ISTM)
+ ENDIF
+ ALLOCATE(ISTM(NSUPERDIA))
+ INDISTM=1
+ ISTM(INDISTM)=NLOOPN
+ if(nverbia > 0)then
+ print *,' ***pro1d YCARCOU',YCARCOU(1:LEN_TRIM(YCARCOU))
+ endif
+ ELSE IF(LSUPER .AND. NSUPER > 1)THEN
+ ISTOK=0
+ DO JB=1,INDISTM
+ IF(NLOOPN == ISTM(JB))THEN
+ ISTOK=1
+ ENDIF
+ ENDDO
+ IF(ISTOK == 1)THEN
+ ELSE
+ INDISTM=INDISTM+1
+ ISTM(INDISTM)=NLOOPN
+ WRITE(YCARCOU(ISUIT:ISUIT+4),'(I5)')NLOOPN
+ ISUIT=ISUIT+5
+ ENDIF
+ ENDIF
+ END SELECT
+ELSE
+ YCAR(1:LEN(YCAR))=' '
+ IF(XIDEBCOU /= -999.)THEN
+ IF(LDEFCV2CC)THEN !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(LDEFCV2IND)THEN
+ WRITE(YCARCOU,1018)NIDEBCV,NJDEBCV,NIFINCV,NJFINCV
+ WRITE(YCAR,1006)KPRO,XIPROFV,XJPROFV
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(YCARCOU,1019)XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL
+ WRITE(YCAR,1006)KPRO,XIPROFV,XJPROFV
+ ELSE
+ WRITE(YCARCOU,1020)XIDEBCV,XJDEBCV,XIFINCV,XJFINCV
+ WRITE(YCAR,1006)KPRO,XIPROFV,XJPROFV
+ ENDIF
+ ELSE !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(XIDEBCOU < 99999.)THEN
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1001)XIDEBCOU,XJDEBCOU,NLANGLE,KPRO
+ IF(.NOT.LCARTESIAN)THEN
+ WRITE(YCAR,1006)KPRO,XIPROFV,XJPROFV
+ ENDIF
+ ELSE
+ WRITE(YCARCOU,1003)XIDEBCOU,XJDEBCOU,NLANGLE,KPRO
+ IF(.NOT.LCARTESIAN)THEN
+ WRITE(YCAR,1006)KPRO,XIPROFV,XJPROFV
+ ENDIF
+ END IF
+ ELSE
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1004)XIDEBCOU,XJDEBCOU,NLANGLE,KPRO
+ ELSE
+ WRITE(YCARCOU,1005)XIDEBCOU,XJDEBCOU,NLANGLE,KPRO
+ END IF
+ END IF
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ ELSE
+ if(nverbia > 0)then
+ print *,' ***pro1d AV YCARCOU',YCARCOU(1:LEN_TRIM(YCARCOU))
+ endif
+ WRITE(YCARCOU,1000)NIDEBCOU,NJDEBCOU,NLANGLE,KPRO
+ END IF
+END IF
+ if(nverbia > 0)then
+ print *,' ***pro1d 815'
+ endif
+
+!IF(L1DT)THEN
+IF(L1DT .AND. NIL == 1 .AND. NIH == 1 .AND. NJL == 1 .AND. NJH == 1)THEN
+ if(nverbia > 0)then
+ print *,' ***pro1d L1DT AV PCSETI'
+ endif
+CALL PCSETI('BF',1) ! Fills a box around characters
+CALL PCSETR('BL',2.) ! heavy line plotted
+CALL PCSETR('BM',.3) ! sets a box margin
+CALL PCSETI('BC(1)',1) ! sets box color for prints
+ENDIF
+
+ZXPOSTITT1=.002
+ZXYPOSTITT1=.98
+IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ENDIF
+IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ENDIF
+
+ZXPOSTITT2=.002
+ZXYPOSTITT2=.95
+IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ENDIF
+IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ENDIF
+
+
+IF(.NOT.LSUPER)THEN
+ if(nverbia > 0)then
+ print *,' ***pro1d AV RESOLV_TIT(CTITT1,YCARCOU)'
+ endif
+ CALL RESOLV_TIT('CTITT1',YCARCOU)
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,.012,0.,-1.)
+ ENDIF
+ IF(YCAR /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCAR,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YCAR,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCAR,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YCAR,.012,0.,-1.)
+ ENDIF
+ ENDIF
+ELSE
+
+ SELECT CASE(CTYPE)
+
+ CASE('CART','MASK')
+
+ IF(NSUPER == 1)THEN
+ I1D=2
+ IF(L1DT)I1D=1
+ CALL RESOLV_TIT('CTITT1',YCARCOU)
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,.012,0.,-1.)
+ ENDIF
+ if(nverbia > 0)then
+ print *,' ***pro1d 887'
+ endif
+ IF(.NOT.L1DT)THEN
+! Mars 2000
+ CALL RESOLV_TIT('CTITT2',YCAR)
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCAR,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YCAR,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCAR,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YCAR,.012,0.,-1.)
+ ENDIF
+ ENDIF
+ ELSE IF(NSUPER >= 2)THEN
+ SELECT CASE(I1D)
+ CASE(1)
+ IF(.NOT.L1DT)THEN
+ ! Titres TOP
+ CALL RESOLV_TIT('CTITT2',YCARCOU)
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.92
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCARCOU,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.92,YCARCOU,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCARCOU,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.92,YCARCOU,.012,0.,-1.)
+ ENDIF
+ I1D=3
+ END IF
+ CASE(2)
+ IF(L1DT)THEN
+ ! Titres TOP
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCARCOU,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YCARCOU,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCARCOU,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YCARCOU,.012,0.,-1.)
+ ENDIF
+ I1D=3
+ END IF
+ CASE(3)
+ END SELECT
+ END IF
+
+ CASE DEFAULT
+
+ IF(NSUPER == NSUPERDIA)THEN
+ CALL RESOLV_TIT('CTITT1',YCARCOU)
+ IF(YCARCOU /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU,.010,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YCARCOU,.010,0.,-1.)
+ ENDIF
+ ENDIF
+ CALL RESOLV_TIT('CTITT2',YCAR)
+ IF(YCAR /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCAR,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YCAR,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YCAR,.010,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YCAR,.010,0.,-1.)
+ ENDIF
+ ENDIF
+ IF(ALLOCATED(ISTM))THEN
+ DEALLOCATE(ISTM)
+ ENDIF
+ ENDIF
+ END SELECT
+ if(nverbia > 0)then
+ print *,' ***pro1d 970'
+ endif
+
+END IF
+CALL GSFAIS(0)
+CALL PCSETI('BF',0) ! desactivates text outline option
+!
+! Variable names
+!
+ILENC=LEN_TRIM(CTIMEC)
+IF(ILENC < LEN(CTIMEC))THEN
+ IF(CTIMEC(ILENC:ILENC) == '.')THEN
+ CTIMEC(ILENC:ILENC)='s'
+ ELSE
+ ILENC=ILENC+1
+ CTIMEC(ILENC:ILENC)='s'
+ ENDIF
+ENDIF
+YT(1:LEN(YT))=' '
+IND1=INDEX(CTIMEC,'=')
+YT=CTIMEC(IND1+1:ILENC)
+YT=ADJUSTL(YT)
+ZXPOSTITB3=.75
+ZXYPOSTITB3=.025
+IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ENDIF
+IF(XYPOSTITB3 /= 0.)THEN
+ ZXYPOSTITB3=XYPOSTITB3
+ENDIF
+YTEM(1:LEN(YTEM))=' '
+if(nverbia > 0)then
+print *,' **pro1d CTITB3 CTITB3MEM ',CTITB3, CTITB3MEM
+endif
+!!!!!!!!!!!!!!!!=================================================
+IF(.NOT.LSUPER)THEN
+ if(nverbia > 0)then
+ print *,' ***pro1d AV CALL PLCHHQ(0.75,0.007,HTEXT,.011,0.,-1.) '
+ endif
+ CALL PLCHHQ(0.75,0.007,HTEXT,.011,0.,-1.)
+ if(nverbia > 0)then
+ print *,' ***pro1d AP CALL PLCHHQ(0.75,0.007,HTEXT,.011,0.,-1.) '
+ endif
+
+!! nov 2001
+ IF(.NOT.LTITDEFM)THEN
+ YTITB3=' '
+ YTITB3=CTITB3
+ CTITB3=' '
+ CTITB3=CTITB3MEM
+ CTITB3=ADJUSTL(CTITB3)
+if(nverbia > 0)then
+print *,' **pro1d CTITB3 CTITB3MEM ',CTITB3, CTITB3MEM
+endif
+ CALL RESOLV_TIT('CTITB3',YTEM)
+! CTITB3=YTITB3
+ ELSE
+!! nov 2001
+ CALL RESOLV_TIT('CTITB3',YTEM)
+ ENDIF
+
+if(nverbia > 0)then
+ print *,' YTEM++++++++ ',YTEM,' CTITB3 ',CTITB3
+endif
+
+ IF(LTITDEFM)THEN
+! ELSE
+!! Nov 2001
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTIMEC,XSZTITB3,0.,-1.)
+! CALL PLCHHQ(0.75,0.025,CTIMEC,XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTIMEC,.011,0.,-1.)
+! CALL PLCHHQ(0.75,0.025,CTIMEC,.011,0.,-1.)
+ ENDIF
+
+ ELSEIF(YTEM /= ' ')THEN
+
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM(1:LEN_TRIM(YTEM)),XSZTITB3,0.,-1.)
+! CALL PLCHHQ(0.75,0.025,YTEM(1:LEN_TRIM(YTEM)),XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM(1:LEN_TRIM(YTEM)),.011,0.,-1.)
+! CALL PLCHHQ(0.75,0.025,YTEM(1:LEN_TRIM(YTEM)),.011,0.,-1.)
+ ENDIF
+!! Nov 2001
+ ENDIF
+ IF(.NOT.LTITDEFM)THEN
+ CTITB3=YTITB3
+ ENDIF
+
+!!!!!!!!!!!!!!!!=================================================
+ELSE
+!!!!!!!!!!!!!!!!=================================================
+
+!! nov 2001
+ IF(.NOT.LTITDEFM)THEN
+ YTITB3=' '
+ YTITB3=CTITB3
+ CTITB3=' '
+ CTITB3=CTITB3MEM
+ CTITB3=ADJUSTL(CTITB3)
+ CALL RESOLV_TIT('CTITB3',YTEM)
+! CTITB3=YTITB3
+ ELSE
+! CTITB3=' '
+ CALL RESOLV_TIT('CTITB3',YTEM)
+ ENDIF
+if(nverbia > 0)then
+ print *,' YTEM2++++++++ ',YTEM
+endif
+ IF(YTEM /= 'DEFAULT' .AND. YTEM /= ' ')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM(1:LEN_TRIM(YTEM)),XSZTITB3,0.,-1.)
+! CALL PLCHHQ(0.75,0.025,YTEM(1:LEN_TRIM(YTEM)),XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM(1:LEN_TRIM(YTEM)),.011,0.,-1.)
+ if(nverbia >0)then
+ print *,' ***pro1d CTITB3*******',CTITB3
+ endif
+! CALL PLCHHQ(0.75,0.025,YTEM(1:LEN_TRIM(YTEM)),.011,0.,-1.)
+ ENDIF
+ ENDIF
+ IF(.NOT.LTITDEFM)THEN
+ CTITB3=YTITB3
+ ENDIF
+ SELECT CASE(CTYPE)
+ CASE('SSOL','DRST','RSPL','RAPL')
+ WRITE(YTEX(1:4),'(I4)')NLOOPN
+ YTEX(1+5:MIN(LEN(YTEX),LEN_TRIM(HTEXT)+5))=HTEXT(1:MIN(LEN(YTEX),LEN_TRIM(HTEXT)))
+ YTEX=ADJUSTL(ADJUSTR(YTEX))
+ if(nverbia > 0)then
+ print *,' PRO1D**** YTEX LEN_TRIM(HTEXT) ',LEN_TRIM(HTEXT),' ',YTEX
+ endif
+ CASE DEFAULT
+ YTEX(1:MIN(LEN(YTEX),LEN_TRIM(HTEXT)))=HTEXT(1:MIN(LEN(YTEX),LEN_TRIM(HTEXT)))
+ YTEX=ADJUSTL(ADJUSTR(YTEX))
+ END SELECT
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!JDJD
+ IF(NSUPER >4)THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!JDJD BOTTOM TITRES
+!!!!!!!!!!!!!!!
+ IF(LVARNPVUSER)THEN
+ CALL GSPLCI(ICOL)
+ CALL GSTXCI(ICOL)
+ IF(XSZVARNPVBOT /=0.)THEN
+ ZSCMIN=XSZVARNPVBOT
+ ELSE
+ ZSCMIN=.008
+ ENDIF
+ IF(NSUPER == 5)THEN
+ IF(CVARNPV5 == 'WHITE' .OR. CVARNPV5 == 'white')THEN
+! CVARNPV5(1:LEN_TRIM(CVARNPV5))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV5 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV5
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 6)THEN
+ IF(CVARNPV6 == 'WHITE' .OR. CVARNPV6 == 'white')THEN
+! CVARNPV6(1:LEN_TRIM(CVARNPV6))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV6 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV6
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 7)THEN
+ IF(CVARNPV7 == 'WHITE' .OR. CVARNPV7 == 'white')THEN
+! CVARNPV7(1:LEN_TRIM(CVARNPV7))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV7 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV7
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 8)THEN
+ IF(CVARNPV8 == 'WHITE' .OR. CVARNPV8 == 'white')THEN
+! CVARNPV8(1:LEN_TRIM(CVARNPV8))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV8 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV8
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 9)THEN
+ IF(CVARNPV9 == 'WHITE' .OR. CVARNPV9 == 'white')THEN
+! CVARNPV9(1:LEN_TRIM(CVARNPV9))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV9 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV9
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 10)THEN
+ IF(CVARNPV10 == 'WHITE' .OR. CVARNPV10 == 'white')THEN
+! CVARNPV10(1:LEN_TRIM(CVARNPV10))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV10 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV10
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 11)THEN
+ IF(CVARNPV11 == 'WHITE' .OR. CVARNPV11 == 'white')THEN
+! CVARNPV11(1:LEN_TRIM(CVARNPV11))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV11 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV11
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 12)THEN
+ IF(CVARNPV12 == 'WHITE' .OR. CVARNPV12 == 'white')THEN
+! CVARNPV12(1:LEN_TRIM(CVARNPV12))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV12 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV12
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 13)THEN
+ IF(CVARNPV13 == 'WHITE' .OR. CVARNPV13 == 'white')THEN
+! CVARNPV13(1:LEN_TRIM(CVARNPV13))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV13 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV13
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 14)THEN
+ IF(CVARNPV14 == 'WHITE' .OR. CVARNPV14 == 'white')THEN
+! CVARNPV14(1:LEN_TRIM(CVARNPV14))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV14 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV14
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 15)THEN
+ IF(CVARNPV15 == 'WHITE' .OR. CVARNPV15 == 'white')THEN
+! CVARNPV15(1:LEN_TRIM(CVARNPV15))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV15 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV15
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ENDIF
+ print *,' NSUPER YTEX ',NSUPER,YTEX
+ IF(XPOSXVARNPV5BOT /= 0.)THEN
+ IF(XPOSYVARNPV5BOT == 0.)THEN
+ CALL PLCHHQ(XPOSXVARNPV5BOT,.005+(NSUPER-5)*.017,YTEX(1:LEN_TRIM(YTEX)),ZSCMIN,0.,-1.)
+ ELSE
+ CALL PLCHHQ(XPOSXVARNPV5BOT,XPOSYVARNPV5BOT+(NSUPER-5)*.017,YTEX(1:LEN_TRIM(YTEX)),ZSCMIN,0.,-1.)
+ ENDIF
+ ELSEIF(XPOSYVARNPV5BOT /= 0.)THEN
+ CALL PLCHHQ(.75,XPOSYVARNPV5BOT+(NSUPER-5)*.017,YTEX(1:LEN_TRIM(YTEX)),ZSCMIN,0.,-1.)
+ ELSE
+ CALL PLCHHQ(.75,.005+(NSUPER-5)*.017,YTEX(1:LEN_TRIM(YTEX)),ZSCMIN,0.,-1.)
+ ENDIF
+ ELSE
+!!!!!!!!!!!!!!!
+ CALL GSLN(1)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ CALL GSLWSC(1.)
+ if(nverbia >0)then
+ print *,' YTEX BOTTOM ',YTEX(1:LEN_TRIM(YTEX))
+ print *,' YT BOTTOM ',YT
+ endif
+ IF(ZSCMIN /= 999.)THEN
+ CALL PLCHHQ(.75,.005+(NSUPER-5)*.017,YTEX(1:LEN_TRIM(YTEX)),ZSCMIN,0.,-1.)
+! CALL PLCHHQ(.75,.005+(NSUPER-5)*.017,HTEXT,ZSCMIN,0.,-1.)
+ ELSE
+ CALL PLCHHQ(.75,.005+(NSUPER-5)*.017,YTEX(1:LEN_TRIM(YTEX)),.007,0.,-1.)
+! CALL PLCHHQ(.75,.005+(NSUPER-5)*.017,HTEXT,.007,0.,-1.)
+ ENDIF
+ CALL PLCHHQ(.62,.005+(NSUPER-5)*.017,YT,.007,0.,-1.)
+! CALL PLCHHQ(.60,.005+(NSUPER-5)*.017,YT,.007,0.,-1.)
+ if(nverbia > 0)then
+ print *,' ***pro1d 1065'
+ endif
+ CALL GSPLCI(ICOL)
+ CALL GSTXCI(ICOL)
+! Oct 99
+! CALL GSLN(ISTYL)
+ CALL GSLN(1)
+ CALL AGSETR('DAS/SE.',1.)
+! Oct 99
+ CALL GSLWSC(ZLWSC)
+ ZX(1)=.69
+! ZX(1)=.67
+ ZX(2)=ZX(1)+.03
+ ZY(1)=0.005+(NSUPER-5)*.017
+ ZY(2)=ZY(1)
+! Oct 99
+! CALL GPL(2,ZX,ZY)
+ CALL CURVED(ZX,ZY,2)
+!!!!!!!!!!!!!!!
+ ENDIF
+!!!!!!!!!!!!!!!
+! Oct 99
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!JDJD
+ ELSE
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!JDJD TOP
+ IF(LVARNPVUSER)THEN
+ IF(XSZVARNPVTOP /=0.)THEN
+ ZSC=XSZVARNPVTOP
+ ELSE
+ ZSC=.008
+ ENDIF
+ IF(NSUPER == 1)THEN
+ IF(CVARNPV1 == 'WHITE' .OR. CVARNPV1 == 'white')THEN
+! CVARNPV1(1:LEN_TRIM(CVARNPV1))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV1 /= ' ')THEN
+ print *,' ***pro1d CVARNPV1 ',CVARNPV1
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=ADJUSTL(CVARNPV1)
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 2)THEN
+ IF(CVARNPV2 == 'WHITE' .OR. CVARNPV2 == 'white')THEN
+! CVARNPV2(1:LEN_TRIM(CVARNPV2))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ print *,' NSUPER=2 YTEX ',YTEX
+ ELSEIF(CVARNPV2 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV2
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 3)THEN
+ IF(CVARNPV3 == 'WHITE' .OR. CVARNPV3 == 'white')THEN
+! CVARNPV3(1:LEN_TRIM(CVARNPV3))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV3 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV3
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ELSEIF(NSUPER == 4)THEN
+ IF(CVARNPV4 == 'WHITE' .OR. CVARNPV4 == 'white')THEN
+! CVARNPV4(1:LEN_TRIM(CVARNPV4))=' '
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ ELSEIF(CVARNPV4 /= ' ')THEN
+ YTEX(1:LEN_TRIM(YTEX))=' '
+ YTEX=CVARNPV4
+ YTEX=ADJUSTL(YTEX)
+ ENDIF
+ ENDIF
+ CALL GSPLCI(ICOL)
+ CALL GSTXCI(ICOL)
+ IF(XPOSXVARNPV1TOP /= 0.)THEN
+ ZDEBX=XPOSXVARNPV1TOP
+ ELSE
+ ZDEBX=ZVL
+ ENDIF
+ IF(XPOSYVARNPV1TOP /= 0.)THEN
+ ZECART2=XPOSYVARNPV1TOP-ZVT
+ ELSE
+ ZECART2=.02
+ ENDIF
+ print *,' pro1d ZSC ',ZSC,' YTEX ',YTEX(1:LEN_TRIM(YTEX)),' YT ',YT
+! STOP
+ CALL PLCHHQ(ZDEBX+(NSUPER-1)*.21,ZVT+ZECART2,YTEX(1:LEN_TRIM(YTEX)),ZSC,0.,-1.)
+ IF(YTEX == ' ')THEN
+ ELSE
+ CALL PLCHHQ(ZDEBX+(NSUPER-1)*.21,ZVT+ZECART2+.02,YT,ZSC,0.,-1.)
+ ENDIF
+! CALL PLCHHQ(ZDEBX,.95,YT,ZSC,0.,-1.)
+ ELSE
+!!!!!!!!!!!!!!
+ CALL GSLN(1)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ CALL GSLWSC(1.)
+ ZSC=.007
+ IF(LEN_TRIM(HTEXT) >25)THEN
+ ZSC=.006
+! ZSC=.005
+ ELSE IF(LEN_TRIM(HTEXT) >20)THEN
+ ZSC=.007
+ ENDIF
+ IF(NSUPERDIA > 3)THEN
+ ZDEBX=.1
+ ELSE
+ ZDEBX=ZVL
+ ENDIF
+ IF(ZVT >= .9)THEN
+ ZECART1=.01; ZECART2=.03
+ ELSE
+ ZECART1=.02; ZECART2=.04
+ ENDIF
+ ZSCMIN=MIN(ZSCMIN,ZSC)
+ if(nverbia > 0)then
+ print *,' ***pro1d YTEX TOP ',YTEX(1:LEN_TRIM(YTEX))
+ endif
+ CALL PLCHHQ(ZDEBX+(NSUPER-1)*.21,ZVT+ZECART2,YTEX(1:LEN_TRIM(YTEX)),ZSC,0.,-1.)
+! CALL PLCHHQ(ZVL+(NSUPER-1)*.21,ZVT+.03,YTEX(1:LEN_TRIM(YTEX)),ZSC,0.,-1.)
+! CALL PLCHHQ(ZVL+(NSUPER-1)*.21,ZVT+.03,HTEXT,.007,0.,-1.)
+ CALL PLCHHQ(ZDEBX+(NSUPER-1)*.21,ZVT+ZECART1,YT,.006,0.,-1.)
+ if(nverbia > 0)then
+ print *,' ***pro1d 1113'
+ endif
+! CALL PLCHHQ(ZVL+(NSUPER-1)*.21,ZVT+.01,YT,.006,0.,-1.)
+ CALL GSPLCI(ICOL)
+ CALL GSTXCI(ICOL)
+! Oct 99
+! CALL GSLN(ISTYL)
+ CALL GSLN(1)
+ CALL AGSETR('DAS/SE.',1.)
+! Oct 99
+ CALL GSLWSC(ZLWSC)
+ ZX(1)= ZDEBX+(NSUPER-1)*.21+(LEN_TRIM(YT)+2)*.010
+! ZX(1)= ZVL+(NSUPER-1)*.21+(LEN_TRIM(YT)+2)*.010
+! ZX(1)= ZVL+(NSUPER-1)*.21+(LEN_TRIM(HTEXT)+2)*.011
+ ZX(2)=ZX(1)+.03
+ ZY(1)=ZVT+ZECART1
+! ZY(1)=ZVT+.01
+! ZY(1)=ZVT+.02
+! ZY(1)=ZVT+.03
+ ZY(2)=ZY(1)
+! Oct 99
+ CALL CURVED(ZX,ZY,2)
+ if(nverbia > 0)then
+ print *,' ***pro1d AP CURVED'
+ endif
+!!!!!!!!!!!!!!!!!!!
+ ENDIF
+!!!!!!!!!!!!!!!!!!!
+! CALL GPL(2,ZX,ZY)
+! Oct 99
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!JDJD
+ END IF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!JDJD
+ CALL GSLN (1)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ CALL GSLWSC(1.)
+END IF
+!!!!!!!!!!!!!!!!=================================================
+IF(.NOT.LSUPER .OR. NSUPER == 1)THEN
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ENDIF
+1000 FORMAT('Vertical section IDEB=',I4,' JDEB=',I4,' ANG.=',I3,' IPRO=',I4)
+1001 FORMAT('Vertical section XDEB=',F6.0,' YDEB=',F6.0,' ANG.=',I3,' IPRO=',I4)
+1002 FORMAT('Vertical profile (1D)')
+1012 FORMAT('Vertical profile (1D) I=',I4,' J=',I4)
+1003 FORMAT('Vertical section XDEB=',F6.0,' YDEB=',E7.2,' ANG.=',I3,' IPRO=',I4)
+1004 FORMAT('Vertical section XDEB=',E7.2,' YDEB=',F6.0,' ANG.=',I3,' IPRO=',I4)
+1005 FORMAT('Vertical section XDEB=',E6.2,' YDEB=',E7.2,' ANG.=',I3,' IPRO=',I4)
+1006 FORMAT('Vertical profile IPRO=',I4,' --> LAT=',F10.5,' ,LON=',F10.5)
+1018 FORMAT('Vertical section IND I,J (BEGIN)-(END)=(',I4,',',I4,')-(',I4,',',I4,')')
+1019 FORMAT('Vertical section LAT,LON (BEGIN)-(END)=(',F5.1,',',F6.1,')-(',F5.1,',',F6.1,')')
+1020 FORMAT('Vert. section CONF. COORD.(BEGIN)-(END)=(',F8.0,',',F8.0,')-(',F8.0,',',F8.0,')')
+!
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+CALL GSCLIP(1) ! Restores window clipping
+!!!!!!!!!!! 110797
+IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == NSUPERDIA))THEN
+ XHMIN=ZHMIN; XHMAX=ZHMAX
+ENDIF
+!!!!!!!!!!! 110797
+RETURN
+!
+!-----------------------------------------------------------------------------
+!
+! 2. EXIT
+! ----
+!
+END SUBROUTINE PRO1D_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/pvfct.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/pvfct.f90
new file mode 100644
index 0000000000000000000000000000000000000000..dbc70952a1985de8016947c2ff9b18317204ba13
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/pvfct.f90
@@ -0,0 +1,693 @@
+! ######spl
+ MODULE MODI_PVFCT
+! ##################
+!
+INTERFACE
+!
+SUBROUTINE PVFCT(PWORKT,PWORK2D,K)
+REAL,DIMENSION(:) :: PWORKT
+REAL,DIMENSION(:,:) :: PWORK2D
+INTEGER :: K
+END SUBROUTINE PVFCT
+!
+END INTERFACE
+END MODULE MODI_PVFCT
+! ######spl
+ SUBROUTINE PVFCT(PWORKT,PWORK2D,K)
+! ##################################
+!
+!!**** *PVFCT* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODD_COORD
+USE MODD_GRID
+USE MODD_TIT
+USE MODD_GRID1
+USE MODD_TYPE_AND_LH
+USE MODD_PARAMETERS
+USE MODD_DIM1
+USE MODD_TITLE
+USE MODD_CVERT
+USE MODD_PVT
+USE MODD_NMGRID
+USE MODD_SUPER
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_EXPERIM
+USE MODN_NCAR
+USE MODN_PARA
+USE MODE_GRIDPROJ
+USE MODI_VARFCT
+
+IMPLICIT NONE
+
+INTERFACE
+ SUBROUTINE IMCOU_FORDIACHRO(PTABV,PINT,HLEGEND,HTEXT)
+ REAL,DIMENSION(:,:) :: PTABV
+ REAL :: PINT
+ CHARACTER(LEN=*) :: HTEXT, HLEGEND
+ END SUBROUTINE IMCOU_FORDIACHRO
+END INTERFACE
+!!! Mars 2000
+INTERFACE
+ SUBROUTINE IMCOUPV_FORDIACHRO(PU,PW,HLEGEND,HTEXT)
+ REAL,DIMENSION(:,:) :: PU,PW
+ CHARACTER(LEN=*) :: HTEXT, HLEGEND
+ END SUBROUTINE IMCOUPV_FORDIACHRO
+END INTERFACE
+!!! Mars 2000
+
+
+COMMON/TEMV/XZWORKZ,XZZDS,NINX,NINY
+COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+#include "big.h"
+REAL,DIMENSION(N2DVERTX,2500) :: XZWORKZ
+!REAL,DIMENSION(1000,400) :: XZWORKZ
+!REAL,DIMENSION(200,200) :: XZWORKZ
+REAL,DIMENSION(N2DVERTX) :: XZZDS
+!REAL,DIMENSION(1000) :: XZZDS
+!REAL,DIMENSION(200) :: XZZDS
+INTEGER :: NINX, NINY
+LOGICAL :: LVERT, LHOR, LPT, LXABS
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+REAL,DIMENSION(:) :: PWORKT
+REAL,DIMENSION(:,:) :: PWORK2D
+INTEGER :: K
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: J,JILOOP, JKLOOP
+INTEGER :: ICOMPT=0
+INTEGER,SAVE :: INUM
+INTEGER :: JLOOPK, ISUPERDIA
+INTEGER :: IKU, IKB, IKE, IK1, IK2, IT
+INTEGER :: ILENT, ILENU
+INTEGER :: INDN, INDT
+INTEGER :: IART
+
+REAL,SAVE :: ZWL, ZWR, ZWB, ZWT
+REAL,SAVE :: ZHMIN, ZHMAX
+REAL :: ZX, ZY, ZLAT, ZLON
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: ZWORK2D
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZWORK2DT
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZWORK1D
+
+CHARACTER(LEN=40) :: YTEXTE
+CHARACTER(LEN=16),DIMENSION(:),ALLOCATABLE,SAVE :: YGROUP
+
+!
+!------------------------------------------------------------------------------
+
+!!!!!!!!!!! 110797
+IF(LPVT .AND. NLOOPSUPER == 1)THEN
+ZHMIN=XHMIN; ZHMAX=XHMAX
+ENDIF
+!!!!!!!!!!! 110797
+IKU=NKMAX+2*JPVEXT
+IKB=1+JPVEXT
+IKE=IKU-JPVEXT
+SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ IK1=MAX(IKB,NKL)
+ IK2=MIN(IKE,NKH)
+ CASE DEFAULT
+ IK1=1
+ IK2=NKH
+! IK2=SIZE(PWORK2D,1)
+END SELECT
+IF(LPBREAD)THEN
+ IF(ALLOCATED(ZWORK2D))THEN
+ DEALLOCATE(ZWORK2D)
+ ENDIF
+ IF(ALLOCATED(ZWORK2DT))THEN
+ DEALLOCATE(ZWORK2DT)
+ ENDIF
+ IF(ALLOCATED(YGROUP))THEN
+ DEALLOCATE(YGROUP)
+ ENDIF
+ ICOMPT=0
+ RETURN
+ENDIF
+IF(LCOLINE)CALL TABCOL_FORDIACHRO
+IF(LPVT .OR. LPXT .OR. LPYT)THEN
+
+ IF(SIZE(PWORKT) > N2DVERTX)THEN
+! IF(SIZE(PWORKT) > 1000)THEN
+ IF(LPVT .OR. LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
+ print *,' Operation impossible en raison du nombre de points trop eleve sur&
+& l''axe des abscisses (temps)'
+ ELSE IF(LPXT .AND. LXABSC)THEN
+ print *,' Operation impossible en raison du nombre de points trop eleve sur&
+& l''axe des ordonnees (temps)'
+ ENDIF
+ print *,'( Limitation due a la dimension actuelle d''un tableau de travail du NCAR)'
+ print *,' 2 solutions :'
+! print *,' - Sortie par plages de 1000 temps '
+ print *,' - Sortie par plages de ',N2DVERTX,' temps '
+ print *,' - Introduction d''un increment temporel dans la directive '
+ print *,' (doit etre 1 multiple entier de l''increment d''enregistrement)'
+ print *,' Ex : _T_0_to_36000_by_360 '
+ LPBREAD=.TRUE.
+ RETURN
+ ENDIF
+
+ ICOMPT=ICOMPT+1
+ if(nverbia > 0)then
+ print *,'** Pvfct ICOMPT ',ICOMPT
+ endif
+! On suppose meme longueur temps
+ ALLOCATE(ZWORK2D(SIZE(PWORK2D,1),SIZE(PWORK2D,2),NSUPERDIA))
+ if(nverbia > 0)then
+ print *,'** Pvfct AP ALLOCATE'
+ endif
+ IF(LPXT .AND. LXABSC)THEN
+ ALLOCATE(ZWORK2DT(SIZE(PWORK2D,1),SIZE(PWORK2D,2)))
+ ELSE
+ ALLOCATE(ZWORK2DT(SIZE(PWORK2D,2),SIZE(PWORK2D,1)))
+ ENDIF
+ ALLOCATE(YGROUP(NSUPERDIA))
+ if(nverbia > 0)then
+ print *,'** Pvfct AP ALLOCATE,NSUPERDIA ',NSUPERDIA
+ endif
+ IF(ICOMPT == 1)THEN
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ INUM=0
+ IF(NSUPERDIA > 1)THEN
+ LSUPER=.TRUE.
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ NSUPER=0
+ ENDIF
+
+ if(nverbia > 0)then
+ print *,' NMGRID ',NMGRID
+ endif
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+ if(nverbia > 0)then
+! Elimination de l'impression suivante car souvent plantage si NIINF ...
+! =0 ; par ex cas PVT
+!print *,' NMGRID ',NMGRID,NiINF,NISUP,NJINF,NJSUP,XXX(NIINF,NMGRID),XXX(NISUP,NMGRID)
+ print *,' ** Pvfct AP COMPCOORD'
+ endif
+ IF(ICOMPT > NSUPERDIA)THEN
+ if(nverbia > 0)then
+ print *,' ** PVFCT A Verifier AI mis NSUPERDIA a la place de ICOMPT '
+ print *,' pour essayer de resoudre le pb de _on_ sans rien derriere '
+ endif
+ ZWORK2D(:,:,NSUPERDIA)=PWORK2D(:,:)
+ YGROUP(NSUPERDIA)=CGROUP
+
+ ELSE
+
+ ZWORK2D(:,:,ICOMPT)=PWORK2D(:,:)
+ YGROUP(ICOMPT)=CGROUP
+ ENDIF
+ if(nverbia > 0)then
+! print *,' ICOMPT ZWORK2D ',ICOMPT,ZWORK2D
+ print *,' ICOMPT sans ZWORK2D ',ICOMPT
+ endif
+
+ ! IL FAUDRA CONSIDERER LE CAS L1DT=.TRUE. pour les altitudes
+
+ INUM=INUM+1
+ if(nverbia > 0)then
+ print *,' INUM ',INUM
+ endif
+
+ IKU=NKMAX+2*JPVEXT
+ IKB=1+JPVEXT
+ IKE=IKU-JPVEXT
+
+!00000000000000000000000000000000000000000000000000000000000000000000000
+ IF(ICOMPT == 1)THEN
+
+ IF(LPVT .OR. LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
+ ZWL=PWORKT(1); ZWR=PWORKT(SIZE(PWORKT,1))
+!!!!!Oct 2001
+ IART=0
+IF(ZWL == ZWR .AND. LUMVMPV)THEN
+ print *,'- Attention ARTIFICE CORRECT pour sortie Profil vent, cas LUMVMPV=T '
+ IF(LHEURX)THEN
+ ZWR=ZWL+1
+ ZWL=ZWL-1
+ ELSE
+ ZWR=ZWL+1*3600
+ ZWL=ZWL-1*3600
+ ENDIF
+ IART=1
+ENDIF
+!!!!!Oct 2001
+ ELSE IF(LPXT .AND. LXABSC)THEN
+ ZWL=XXX(NIINF,NMGRID); ZWR=XXX(NISUP,NMGRID)
+ ENDIF
+ if(nverbia > 0)then
+ print *,' zwl zwr ',ZWL,ZWR
+ endif
+
+ IF((XHMAX-XHMIN == 0.).OR.(XHMAX<=XHMIN))THEN
+ IF(LPRESY)THEN
+ ELSE
+ XHMIN=0.
+ ENDIF
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ IF(LPVT)THEN
+ IF(L1DT)THEN
+! Mars 2000 Cas d'un profil issu matrice 3D enreg. a hte frequence
+! Besoin de l'altitude vraie
+! On suppose que le compcoord(NMGRID) a ete fait ds oper
+ IF(NIL /= 1 .OR. NJL /=1)THEN
+!! Mars 2001 Veronique Ducrocq m'a signale le pb
+ IF(LICP .OR. LJCP)THEN
+ XHMAX=XXZ(IKE,NMGRID)
+ ELSE
+ XHMAX=XZZ(NIL,NJL,IKE)
+ ENDIF
+ ELSE
+! Cas des bilans par ex MASK resultat de compressions sur 2 axes
+! on les met au point 1,1
+ XHMAX=XXZ(IKE,NMGRID)
+ ENDIF
+ ELSE
+ IF(LPRESY .AND. XHMIN > XHMAX)THEN
+ ELSE
+ IF(LPRESY)THEN
+ print *,' ** pvfct size(xpresm,1,2)',SIZE(XPRESM,1),SIZE(XPRESM,2)
+ XHMIN=MAXVAL(XPRESM(:,IKB))
+! XHMIN=XWORKZ(NPROFILE,IKB,NMGRID)
+ ENDIF
+ IF(LPRESY)THEN
+ XHMAX=MINVAL(XPRESM(:,IKE))
+ ELSE
+ XHMAX=XWORKZ(NPROFILE,IKE,NMGRID)
+ ENDIF
+ ENDIF
+ IF(LPRESY)THEN
+ print *,' LPRESY,XHMIN,XHMAX ',LPRESY,XHMIN,XHMAX
+ ENDIF
+ ENDIF
+ ENDIF
+ CASE('MASK')
+ XHMAX=XXZ(IKE,NMGRID)
+ CASE('SSOL')
+ XHMIN=MIN(0.,XZSOL(1))
+ XHMAX=MAX(0.,XZSOL(SIZE(XZSOL)))
+ IF(XHMAX - XHMIN == 0.)THEN
+ XHMIN=XHMIN-1.
+ XHMAX=XHMAX+1.
+ ENDIF
+ CASE('DRST','RAPL')
+ IF(.NOT.LTINCRDIA(NLOOPSUPER,NLOOPN))THEN
+ XHMIN=MINVAL(XTRAJZ(NLVLKDIA(1:NBLVLKDIA(NLOOPSUPER,NLOOPN), &
+ NLOOPSUPER,NLOOPN), &
+ NTIMEDIA(1:NBTIMEDIA(NLOOPSUPER,NLOOPN),NLOOPSUPER,NLOOPN),NLOOPN))
+ XHMAX=MAXVAL(XTRAJZ(NLVLKDIA(1:NBLVLKDIA(NLOOPSUPER,NLOOPN), &
+ NLOOPSUPER,NLOOPN), &
+ NTIMEDIA(1:NBTIMEDIA(NLOOPSUPER,NLOOPN),NLOOPSUPER,NLOOPN),NLOOPN))
+ ELSE
+ XHMIN=MINVAL(XTRAJZ(NLVLKDIA(1:NBLVLKDIA(NLOOPSUPER,NLOOPN), &
+ NLOOPSUPER,NLOOPN), &
+ NTIMEDIA(1,NLOOPSUPER,NLOOPN):NTIMEDIA(2,NLOOPSUPER,NLOOPN): &
+ NTIMEDIA(3,NLOOPSUPER,NLOOPN),NLOOPN))
+! NTIMEDIA(1:2:NTIMEDIA(3,NLOOPSUPER,NLOOPN),NLOOPSUPER,NLOOPN),NLOOPN))
+ XHMAX=MAXVAL(XTRAJZ(NLVLKDIA(1:NBLVLKDIA(NLOOPSUPER,NLOOPN), &
+ NLOOPSUPER,NLOOPN), &
+ NTIMEDIA(1,NLOOPSUPER,NLOOPN):NTIMEDIA(2,NLOOPSUPER,NLOOPN): &
+ NTIMEDIA(3,NLOOPSUPER,NLOOPN),NLOOPN))
+! NTIMEDIA(1:2:NTIMEDIA(3,NLOOPSUPER,NLOOPN),NLOOPSUPER,NLOOPN),NLOOPN))
+ ENDIF
+ CALL VALMNMX(XHMIN,XHMAX)
+ END SELECT
+ END IF
+ if(nverbia > 0)then
+ print *,' ** pvfct LPXT,LXABSC ',LPXT,LXABSC
+ endif
+ IF(LPVT)THEN
+ ZWB=XHMIN
+ ZWT=XHMAX
+ if(nverbia > 0)then
+ print *,' **pvfct ZWB,ZWT ',ZWB,ZWT
+ endif
+ ELSE IF(LPXT .AND. LXABSC)THEN
+ ZWB=PWORKT(1)
+ ZWT=PWORKT(SIZE(PWORKT,1))
+! print *,PWORKT(1),PWORKT(SIZE(PWORKT,1)),SIZE(PWORKT,1)
+ ELSE IF(LPXT .AND..NOT.LXABSC)THEN
+ ZWB=XXX(NIINF,NMGRID)
+ ZWT=XXX(NISUP,NMGRID)
+ ELSE IF(LPYT)THEN
+ ZWB=XXY(NJINF,NMGRID)
+ ZWT=XXY(NJSUP,NMGRID)
+ ENDIF
+ LVERT=.TRUE.
+ LHOR=.FALSE.
+ LPT=LPXT
+ CALL GSCLIP(1)
+ CALL CPSETI('SET',0)
+ CALL CPSETI('MAP',4)
+ if(nverbia > 0)then
+ print *,'** Pvfct ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT
+ endif
+ IF(LVPTVUSER)THEN
+ CALL SET(XVPTVL,XVPTVR,XVPTVB,XVPTVT,ZWL,ZWR,ZWB,ZWT,1)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZWL,ZWR,ZWB,ZWT,1)
+ ENDIF
+! print *,' PVFCT ZWL,ZWR,ZWB,ZWT ',ZWL,ZWR,ZWB,ZWT
+
+ ENDIF
+
+!!!!!Oct 2001
+ IF(IART == 1)THEN
+ CALL FRSTPT((ZWL+ZWR)/2,ZWB)
+ CALL VECTOR((ZWL+ZWR)/2,ZWT)
+ ENDIF
+!!!!!Oct 2001
+!0000000000000000000000000000000000000000000000000000 je crois
+ if(nverbia > 0)then
+ print *,' **pvfct AV NINX ',NINX
+ endif
+
+ IF(LPVT .OR. LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
+ NINX=SIZE(PWORKT)
+ ELSE IF(LPXT .AND. LXABSC)THEN
+ NINX=SIZE(PWORK2D,1)
+ ENDIF
+ if(nverbia > 0)then
+ print *,' **pvfct NINX ',NINX
+ endif
+ SELECT CASE(CTYPE)
+ CASE('CART','MASK')
+ IF(LPVT)THEN
+ NINY=IKU
+ ELSE IF(LPXT .AND. LXABSC)THEN
+ NINY=SIZE(PWORK2D,2)
+ ELSE IF(LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
+ NINY=SIZE(PWORK2D,1)
+ ENDIF
+ CASE('SSOL')
+ NINY=SIZE(XZSOL)
+ CASE('DRST','RAPL')
+ NINY=SIZE(PWORK2D,1)
+ END SELECT
+
+ DO JILOOP=1,NINX
+ IF(LPVT .OR. LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
+ XZZDS(JILOOP)=PWORKT(JILOOP)
+ ELSE IF(LPXT .AND. LXABSC)THEN
+ XZZDS(JILOOP)=XXX(NIINF+JILOOP-1,NMGRID)
+ XZWORKZ(JILOOP,:)=PWORKT(JILOOP)
+ ENDIF
+ DO JKLOOP=1,NINY
+ IF(LPVT)THEN
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ IF(l1DT)THEN
+! Mars 2000 Cas d'un profil issu matrice 3D enreg. a hte frequence
+! Besoin de l'altitude vraie
+! On suppose que le compcoord(NMGRID) a ete fait ds oper
+ IF(NIL /= 1 .OR. NJL /=1)THEN
+!! Mars 2001 Veronique Ducrocq m'a signale le pb
+ IF(LICP .OR. LJCP)THEN
+ XZWORKZ(JILOOP,JKLOOP)=XXZ(JKLOOP,NMGRID)
+ ELSE
+ XZWORKZ(JILOOP,JKLOOP)=XZZ(NIL,NJL,JKLOOP)
+ ENDIF
+ ELSE
+ XZWORKZ(JILOOP,JKLOOP)=XXZ(JKLOOP,NMGRID)
+ ENDIF
+ ELSE
+ XZWORKZ(JILOOP,JKLOOP)=XWORKZ(NPROFILE,JKLOOP,NMGRID)
+ IF(LPRESY)THEN
+ XZWORKZ(JILOOP,JKLOOP)=XPRESM(JILOOP,JKLOOP)
+ print *,' **pvfct JILOOP,JKLOOP,XPRESM ',JILOOP,JKLOOP,XPRESM(JILOOP,JKLOOP)
+ IF(JILOOP == NINX .AND. JKLOOP == NINY)THEN
+ DEALLOCATE(XPRESM)
+ ENDIF
+ ENDIF
+ ENDIF
+ CASE('MASK')
+ XZWORKZ(JILOOP,JKLOOP)=XXZ(JKLOOP,NMGRID)
+ CASE('SSOL')
+ XZWORKZ(JILOOP,JKLOOP)=XZSOL(JKLOOP)
+ CASE('DRST','RAPL')
+ IF(.NOT.LTINCRDIA(NLOOPSUPER,NLOOPN))THEN
+ INDT=NTIMEDIA(JILOOP,NLOOPSUPER,NLOOPN)
+ ELSE
+ INDT=NTIMEDIA(1,NLOOPSUPER,NLOOPN)+(JILOOP-1)*NTIMEDIA(3, &
+ NLOOPSUPER,NLOOPN)
+ ENDIF
+ XZWORKZ(JILOOP,JKLOOP)=XTRAJZ(NLVLKDIA(JKLOOP,NLOOPSUPER,NLOOPN), &
+ INDT,NLOOPN)
+ END SELECT
+
+ ELSE IF(LPXT .AND..NOT.LXABSC)THEN
+ XZWORKZ(JILOOP,JKLOOP)=XXX(NIINF+JKLOOP-1,NMGRID)
+ ELSE IF(LPYT)THEN
+ XZWORKZ(JILOOP,JKLOOP)=XXY(NJINF+JKLOOP-1,NMGRID)
+ ENDIF
+ ENDDO
+ ENDDO
+ IF(LPVT .OR. LPYT .OR. (LPXT .AND..NOT.LXABSC))THEN
+ IF(INUM> NSUPERDIA)THEN
+ if(nverbia > 0)then
+ print *,' ** PVFCT A Verifier AI mis NSUPERDIA a la place de INUM'
+ print *,' pour essayer de resoudre le pb de _on_ sans rien derriere '
+ endif
+ ENDIF
+ DO JILOOP=1,NINX
+ IF(INUM> NSUPERDIA)THEN
+ ZWORK2DT(JILOOP,:)=ZWORK2D(:,JILOOP,NSUPERDIA)
+ ELSE
+ ZWORK2DT(JILOOP,:)=ZWORK2D(:,JILOOP,INUM)
+ ENDIF
+ ENDDO
+ ELSE IF(LPXT .AND. LXABSC)THEN
+ IF(INUM> NSUPERDIA)THEN
+ if(nverbia > 0)then
+ print *,' ** PVFCT A Verifier AI mis NSUPERDIA a la place de INUM'
+ print *,' pour essayer de resoudre le pb de _on_ sans rien derriere '
+ endif
+ ZWORK2DT(:,:)=ZWORK2D(:,:,NSUPERDIA)
+ ELSE
+ ZWORK2DT(:,:)=ZWORK2D(:,:,INUM)
+ ENDIF
+ ENDIF
+ YTEXTE(1:LEN(YTEXTE))=' '
+ ILENT=LEN_TRIM(CTITGAL)
+ ILENU=LEN_TRIM(CUNITGAL)
+ YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+ YTEXTE(ILENT+1:ILENT+1)=' '
+ YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
+ SELECT CASE(CTYPE)
+ CASE('CART','MASK')
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+ CASE('SSOL')
+ END SELECT
+! Mars 2000 + Janv 2001(LUMVM + LDIRWIND)
+ IF(LUMVMPV .OR. LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. LDIRWIND)THEN
+ CUNITE(1)=ADJUSTL(CUNITE(1))
+ ILENU=LEN_TRIM(CUNITE(1))
+! Janvier 2001
+ IF(LDIRWIND)THEN
+ YTEXTE(1:LEN(YTEXTE))=' '
+ ILENT=LEN_TRIM(CTITGAL)
+ YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+ print *,' **pvfct YTEXTE ',CTITGAL(1:ILENT)
+ ELSE
+! Janvier 2001
+
+ IF(CTITRE(1) == 'UM' .OR. CTITRE(1) == 'VM')THEN
+ YTEXTE(1:LEN(YTEXTE))=' '
+ YTEXTE(1:5)='UMVM '
+ ILENT=4
+ YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITE(1)(1:ILENU)
+ ENDIF
+ IF(CTITRE(1) == 'UT' .OR. CTITRE(1) == 'VT')THEN
+ YTEXTE(1:LEN(YTEXTE))=' '
+ YTEXTE(1:5)='UTVT '
+ ILENT=4
+ YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITE(1)(1:ILENU)
+ ENDIF
+! Janvier 2001
+ ENDIF
+ IF(LDIRWIND)THEN
+ ALLOCATE(XTDIRWIND(SIZE(PWORKT,1)))
+! Chargement des temps pour etre utilises ds IMCOUPV_FORDIACHRO
+ XTDIRWIND=PWORKT
+ ENDIF
+! Janvier 2001
+ CALL IMCOUPV_FORDIACHRO(XTEM2D,XTEM2D2,CLEGEND,YTEXTE(1:LEN_TRIM(YTEXTE)))
+! Janvier 2001
+ IF(LDIRWIND)THEN
+ DEALLOCATE(XTDIRWIND)
+ ENDIF
+! Janvier 2001
+! Mars 2000
+ ELSE
+ if(nverbia > 0)then
+ print *,' **PVFCT YTEXTE AV appel IMCOU ',YTEXTE(1:LEN_TRIM(YTEXTE))
+ endif
+ CALL IMCOU_FORDIACHRO(ZWORK2DT,XDIAINT,CLEGEND,YTEXTE(1:LEN_TRIM(YTEXTE)))
+ ENDIF
+ DEALLOCATE(ZWORK2D)
+ DEALLOCATE(ZWORK2DT)
+ DEALLOCATE(YGROUP)
+!! Octobre 2001
+ if(nverbia > 0)then
+ print *,' ** pvfct ICOMPT NSUPERDIA ',ICOMPT,NSUPERDIA,CGROUP
+ endif
+ IF(ICOMPT == NSUPERDIA -NBPMT)THEN
+! IF(ICOMPT == NSUPERDIA)THEN
+ ICOMPT=0
+ ENDIF
+ENDIF
+
+! Mars 2001
+IF(LPVKT .OR. LPVKT1)THEN
+ IF(LDIRWIND .AND. ALLOCATED(XDSX) .AND. ALLOCATED(XTEM2D2) .AND. &
+ NMGRID == 1)THEN
+ ZX=XDSX(NPROFILE,1)
+ ZY=XDSY(NPROFILE,1)
+ CALL SM_LATLON_S(XLATORI,XLONORI,ZX,ZY,ZLAT,ZLON)
+ WHERE(XTEM2D /= XSPVAL .AND. XTEM2D2 /= XSPVAL)
+ XTEM2D=ATAN2(XTEM2D2,XTEM2D)*180./ACOS(-1.)
+ ENDWHERE
+ WHERE(XTEM2D /= XSPVAL .AND. XTEM2D2 /= XSPVAL)
+ XTEM2D=XTEM2D-(XRPK*(ZLON-XLON0)-XBETA)+90.
+ ENDWHERE
+ WHERE(XTEM2D <0. )XTEM2D=XTEM2D+360.
+ WHERE(XTEM2D /= XSPVAL .AND. XTEM2D2 /= XSPVAL)
+ XTEM2D2=360.-XTEM2D
+ ELSEWHERE
+ XTEM2D2=XSPVAL
+ ENDWHERE
+ PWORK2D=XTEM2D2
+ ELSE
+ ENDIF
+ENDIF
+! Mars 2001
+! Remarque :
+! Cas CART + MASK + SPXY : OPER transmet toujours IKU niveaux . Donc la
+! selection des niveaux se fait ici dans PVFCT
+! Dans les autres cas: la selection des niveaux est deja faite dans OPER
+!
+IF(LPVKT)THEN
+! On force NSUPERDIA a la valeur du nb de niveaux K pour une gestion + facile
+! dans varfct
+! En realite on n'a pas demande de superpostions. Donc NSUPERDIA=1
+SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ INDN=1
+ CASE DEFAULT
+ INDN=NLOOPN
+END SELECT
+IF(NSUPERDIA == 1 .AND. NBLVLKDIA(1,INDN) > 1)THEN
+ ISUPERDIA=NSUPERDIA
+ NSUPERDIA=NBLVLKDIA(1,INDN)
+ IT=0
+ DO J=1,NBLVLKDIA(1,INDN)
+ SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ IF(NLVLKDIA(J,1,INDN) < IK1 .OR. NLVLKDIA(J,1,INDN) > IK2)IT=IT+1
+ CASE DEFAULT
+ END SELECT
+ ENDDO
+ NSUPERDIA=NSUPERDIA-IT
+ ALLOCATE(ZWORK1D(SIZE(PWORK2D,2)))
+ DO JLOOPK=1,NBLVLKDIA(1,INDN)
+ SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ IF(NLVLKDIA(JLOOPK,1,INDN) < IK1 .OR. NLVLKDIA(JLOOPK,1,INDN) > IK2)CYCLE
+ ZWORK1D(:)=PWORK2D(NLVLKDIA(JLOOPK,1,INDN),:)
+ CASE DEFAULT
+ ZWORK1D(:)=PWORK2D(JLOOPK,:)
+ END SELECT
+ CALL VARFCT(PWORKT,ZWORK1D,NLVLKDIA(JLOOPK,1,INDN))
+ ENDDO
+ DEALLOCATE(ZWORK1D)
+ NSUPERDIA=ISUPERDIA
+ELSE
+ ALLOCATE(ZWORK1D(SIZE(PWORK2D,2)))
+ L1K=.TRUE.
+ SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ ZWORK1D(:)=PWORK2D(NLVLKDIA(NBLVLKDIA(K,INDN),K,INDN),:)
+ CASE DEFAULT
+ ZWORK1D(:)=PWORK2D(1,:)
+ END SELECT
+ CALL VARFCT(PWORKT,ZWORK1D,NLVLKDIA(NBLVLKDIA(K,INDN),K,INDN))
+ DEALLOCATE(ZWORK1D)
+ENDIF
+ENDIF
+
+! Remarque :
+! Cas CART + MASK + SPXY : OPER transmet toujours IKU niveaux . Donc la
+! selection des niveaux se fait ici dans PVFCT
+! Dans les autres cas: la selection des niveaux est deja faite dans OPER
+!
+IF(LPVKT1)THEN
+ SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ INDN=1
+ CASE DEFAULT
+ INDN=NLOOPN
+ END SELECT
+ ALLOCATE(ZWORK1D(SIZE(PWORK2D,2)))
+ DO JLOOPK=1,NBLVLKDIA(K,INDN)
+ SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ ZWORK1D(:)=PWORK2D(NLVLKDIA(JLOOPK,K,INDN),:)
+ CASE DEFAULT
+ ZWORK1D(:)=PWORK2D(JLOOPK,:)
+ END SELECT
+ CALL VARFCT(PWORKT,ZWORK1D,NLVLKDIA(JLOOPK,K,INDN))
+ ENDDO
+ DEALLOCATE(ZWORK1D)
+ENDIF
+IF(LPVT .AND. (.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == NSUPERDIA)))THEN
+ XHMIN=ZHMIN; XHMAX=ZHMAX
+ENDIF
+RETURN
+END SUBROUTINE PVFCT
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/read_dimgridref.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/read_dimgridref.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3b747fcece7744d47814203a3e49cc904d405dda
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/read_dimgridref.f90
@@ -0,0 +1,202 @@
+! ######spl
+ MODULE MODI_READ_DIMGRIDREF
+! ###########################
+!
+INTERFACE
+!
+SUBROUTINE READ_DIMGRIDREF(K,HNAMFILE,HLUOUT)
+INTEGER :: K
+CHARACTER(LEN=*) :: HNAMFILE, HLUOUT
+END SUBROUTINE READ_DIMGRIDREF
+!
+END INTERFACE
+!
+END MODULE MODI_READ_DIMGRIDREF
+! ######spl
+ SUBROUTINE READ_DIMGRIDREF(K,HNAMFILE,HLUOUT)
+! #############################################
+!
+!!**** *READ_DIMGRIDREF* -
+!!
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHORS
+!! -------
+!! J. Duron *Lab. Aerologie*
+!!
+!! Copyright 1994, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/01/96
+!! Modification 01/2003 suppression de l appel a SET_REF_FORDIACHRO
+! (=SET_REF modifie en supprimant toute la partie calculs inutile)
+!! Modification 12/2003 appel a SET_GRID remplace par SET_LIGHT_GRID
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF, ONLY: CCONF,CSTORAGE_TYPE,LCARTESIAN,LTHINSHELL
+USE MODD_DIM1, ONLY: NIMAX,NJMAX,NKMAX, NIINF,NISUP,NJINF,NJSUP
+USE MODD_GRID ! XLONORI,XLATORI
+USE MODD_GRID1, ONLY: XLON,XLAT,XXHAT,XYHAT,&
+ XDXHAT,XDYHAT,XMAP,XZS,XZZ,XZHAT,&
+ LSLEVE,XLEN1,XLEN2,XZSMT
+USE MODD_PARAMETERS, ONLY: JPHEXT,JPVEXT
+USE MODD_TIME
+USE MODD_TIME1
+!
+USE MODD_REA_LFI
+USE MODD_RESOLVCAR, ONLY: NVERBIA
+!
+USE MODI_SET_DIM
+USE MODI_SET_LIGHT_GRID
+USE MODI_FMREAD
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+!
+INTEGER :: K
+!
+CHARACTER(LEN=*) :: HNAMFILE
+CHARACTER(LEN=*) :: HLUOUT
+!
+!* 0.2 Local variables declarations
+!
+INTEGER :: IIU, IJU, IKU ! Upper bounds in x, y, z directions
+INTEGER :: IIB, IJB, IKB ! Begining useful area in x, y, z directions
+INTEGER :: IIE, IJE, IKE ! End useful area in x, y, z directions
+!
+INTEGER,SAVE :: IIINF, IISUP, IJINF, IJSUP
+!
+!REAL :: ZLAT,ZLON ! Emagram soundings gridpoint location
+ ! latitude and longitude (decimal degrees)
+!REAL :: ZX,ZY ! Emagram soundings gridpoint location
+ ! cartesian east and north coordinates (meters)
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: ZJ ! Jacobian
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Preseting the general FM2DIACHRO environment
+! ---------------------------------------
+!
+!* 1.1 Sets default values
+!
+CCONF='POSTP'
+!
+!* 1.6 Reads the LFIFM file initial section (i.e. Array dimensions)
+!
+IIINF=NIINF; IISUP=NISUP; IJINF=NJINF; IJSUP=NJSUP
+NIINF=0 ; NISUP=0 ; NJINF=0 ; NJSUP=0
+NIMAX=0
+CALL FMREAD(HNAMFILE,'IMAX',HLUOUT,1,NIMAX,NGRID,NLENCH,CCOMMENT,NRESP)
+IF(NRESP /= 0)THEN
+ NIMAX=0
+ print *,' Absence d''entete dans ce fichier '
+ RETURN
+ENDIF
+if(nverbia>=5) print *,'Av SET_DIM NIMAX=',NIMAX
+CALL SET_DIM(HNAMFILE,HLUOUT,NIINF,NISUP,NJINF,NJSUP,NIMAX,NJMAX,NKMAX)
+if(nverbia>=5) print *,'Ap SET_DIM NIMAX=',NIMAX
+!
+! Reads the geometry configuration selector
+!
+CRECFM='CARTESIAN'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,LCARTESIAN,NGRID,NLENCH,CCOMMENT,NRESP)
+if(nverbia>=5)print *,' LCARTESIAN=', LCARTESIAN
+
+CRECFM='THINSHELL'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,LTHINSHELL,NGRID,NLENCH,CCOMMENT,NRESP)
+if(nverbia>=5)print *,' LTHINSHELL=', LTHINSHELL
+
+CRECFM='STORAGE_TYPE'
+NLENG=2
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,CSTORAGE_TYPE,NGRID,NLENCH,CCOMMENT,NRESP)
+IF(NRESP /= 0) CSTORAGE_TYPE='MT'
+print *,' CSTORAGE_TYPE =',CSTORAGE_TYPE
+!
+!* 1.7 Allocates the first bunch of input arrays
+!
+!
+!* 1.7.1 Local variables :
+!
+IIU=NIMAX+2*JPHEXT ; IJU=NJMAX+2*JPHEXT ; IKU=NKMAX+2*JPVEXT
+!
+IF(CSTORAGE_TYPE == 'PG' .OR. CSTORAGE_TYPE =='SU') IKU=1
+!
+IIB=1+JPHEXT ; IIE=IIU-JPHEXT
+IJB=1+JPHEXT ; IJE=IJU-JPHEXT
+IKB=1+JPVEXT ; IKE=IKU-JPVEXT
+if(nverbia>=3) print*,'* in READ_DIMGRIDREF'
+print*,' IIB, IJB, IKB= ',IIB,IJB,IKB
+print*,' IIE, IJE, IKE= ',IIE,IJE,IKE
+print*,' IIU, IJU, IKU= ',IIU,IJU,IKU
+!
+!* 1.7.2 Grid variables (MODD_GRID1 module):
+!
+IF(ALLOCATED(XXHAT)) DEALLOCATE(XXHAT)
+IF(ALLOCATED(XYHAT)) DEALLOCATE(XYHAT)
+IF(ALLOCATED(XZHAT)) DEALLOCATE(XZHAT)
+IF(ALLOCATED(XMAP)) DEALLOCATE(XMAP)
+IF(ALLOCATED(XLAT)) DEALLOCATE(XLAT)
+IF(ALLOCATED(XLON)) DEALLOCATE(XLON)
+IF(ALLOCATED(XDXHAT))DEALLOCATE(XDXHAT)
+IF(ALLOCATED(XDYHAT))DEALLOCATE(XDYHAT)
+IF(ALLOCATED(XZS)) DEALLOCATE(XZS)
+IF(ALLOCATED(XZSMT)) DEALLOCATE(XZSMT)
+IF(ALLOCATED(XZZ)) DEALLOCATE(XZZ)
+ALLOCATE(XXHAT(IIU),XYHAT(IJU),XZHAT(IKU))
+ALLOCATE(XMAP(IIU,IJU))
+ALLOCATE(XLAT(IIU,IJU))
+ALLOCATE(XLON(IIU,IJU))
+ALLOCATE(XDXHAT(IIU),XDYHAT(IJU))
+ALLOCATE(XZS(IIU,IJU),XZSMT(IIU,IJU))
+ALLOCATE(XZZ(IIU,IJU,IKU))
+!
+!* 1.8 Reads the last section of the LFIFM file
+!
+! Notice: The whole XXHAT, XYHAT arrays have to be set here
+! to make provision for any grid selector choice
+!
+NIINF=1 ; NISUP=IIU
+NJINF=1 ; NJSUP=IJU
+!
+ALLOCATE(ZJ(IIU,IJU,IKU))
+CALL SET_LIGHT_GRID(1,HNAMFILE,HLUOUT, &
+ IIU,IJU,IKU,NIMAX,NJMAX, &
+ XLONORI,XLATORI, &
+ XLON,XLAT,XXHAT,XYHAT, &
+ XDXHAT,XDYHAT,XMAP, &
+ XZS,XZZ,XZHAT,LSLEVE,XLEN1,XLEN2,XZSMT, &
+ ZJ, &
+ TDTMOD,TDTCUR )
+!
+DEALLOCATE(ZJ)
+IF(IIINF /= 0 .AND. IISUP /=0 .AND. IJINF /=0 .AND. IJSUP /=0)THEN
+ NIINF=IIINF; NISUP=IISUP; NJINF=IJINF; NJSUP=IJSUP
+ENDIF
+!
+!------------------------------------------------------------------------------
+!
+!* 4. EPILOGUE
+! --------
+RETURN
+
+END SUBROUTINE READ_DIMGRIDREF
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/read_filehead.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/read_filehead.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bdc450f6c305489fc9d41dd474e1bc47f6717289
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/read_filehead.f90
@@ -0,0 +1,161 @@
+! ######spl
+ SUBROUTINE READ_FILEHEAD(K,HFILEDIA,HLUOUTDIA)
+! ##############################################
+!
+!!**** *READ_FILEHEAD* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/01/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_DIACHRO
+USE MODD_PARAMETERS
+USE MODD_RESOLVCAR
+USE MODD_TYPE_AND_LH
+USE MODD_DIM1
+USE MODN_PARA
+USE MODN_NCAR
+USE MODI_FMREAD
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+INTEGER :: K
+CHARACTER(LEN=*) :: HFILEDIA, HLUOUTDIA
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+CHARACTER(LEN=16) :: YRECFM
+CHARACTER(LEN=100) :: YCOMMENT
+CHARACTER(LEN=16),DIMENSION(5000),SAVE :: YGROUP
+INTEGER :: ILENG, ILENCH, IGRID, J, JJ, ILENDIM
+INTEGER :: IRESPDIA
+INTEGER,SAVE :: IGROUP=0
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: ITABCHAR
+INTEGER :: IIINF, IJINF, IISUP, IJSUP
+INTEGER :: IMAX
+REAL :: ZIDEBCOU, ZJDEBCOU
+LOGICAL :: GDIMGRIDREF
+!------------------------------------------------------------------------------
+!
+
+ILENDIM=1
+YRECFM='MENU_BUDGET.DIM'
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENDIM,ILENG,&
+IGRID,ILENCH,YCOMMENT,IRESPDIA)
+IF (IRESPDIA .NE. 0) THEN
+ print*,'-> le fichier ',TRIM(HFILEDIA),' n''est pas diachronique'
+ print*,' (avez-vous fait conv2dia une fois pour traiter un fichier synchrone ?)'
+ print*,' (ne pas appliquer conv2dia sur la sortie .000 du run)'
+ STOP
+END IF
+ALLOCATE(ITABCHAR(ILENG))
+YRECFM='MENU_BUDGET'
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+IGRID,ILENCH,YCOMMENT,IRESPDIA)
+IGROUP=ILENG/16
+!print *,' ILENG ILENCH IGROUP ',ILENG,ILENCH,IGROUP
+
+DO JJ=1,IGROUP
+ DO J = 1,16
+ YGROUP(JJ)(J:J)=CHAR(ITABCHAR(16*(JJ-1)+J))
+ ENDDO
+ENDDO
+DEALLOCATE(ITABCHAR)
+GDIMGRIDREF=.FALSE.
+DO JJ=1,IGROUP
+! print *,' YGROUP : ',YGROUP(JJ)
+ YRECFM=ADJUSTL(ADJUSTR(YGROUP(JJ))//'.TYPE')
+ ILENG=LEN(CTYPE)
+ ALLOCATE(ITABCHAR(ILENG))
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ DO J = 1,ILENG
+ CTYPE(J:J) = CHAR(ITABCHAR(J))
+ ENDDO
+!66666666666666666666666666666666666666666666666666
+! IF(CTYPE == 'CART' .OR. CTYPE == 'MASK' .OR. CTYPE == 'SPXY')THEN
+!66666666666666666666666666666666666666666666666666
+ GDIMGRIDREF=.TRUE.
+!66666666666666666666666666666666666666666666666666
+! EXIT
+! ENDIF
+!66666666666666666666666666666666666666666666666666
+ DEALLOCATE(ITABCHAR)
+ENDDO
+
+IF(GDIMGRIDREF)THEN
+ IIINF=NIINF; IJINF=NJINF; IISUP=NISUP; IJSUP=NJSUP
+ IF(NVERBIA > 0)THEN
+ print *,' IIINF,IJINF,IISUP,IJSUP ',IIINF,IJINF,IISUP,IJSUP
+ ENDIF
+ ZIDEBCOU=XIDEBCOU; ZJDEBCOU=XJDEBCOU
+ CALL INI_CST
+ CALL FMREAD(HFILEDIA,'IMAX',HLUOUTDIA,1,IMAX,&
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IF(IRESPDIA /= 0)THEN
+ NIMAX=0
+ ELSE
+ CALL READ_DIMGRIDREF(K,HFILEDIA,HLUOUTDIA)
+! CALL INIDEF
+! NIMNMX=-1
+! LMINMAX=.TRUE.
+!66666666666666666666666666666666666666666666666666
+! IF(NIMAX /= 0)THEN
+!66666666666666666666666666666666666666666666666666
+ CALL COMPCOORD_FORDIACHRO(0)
+!66666666666666666666666666666666666666666666666666
+ ENDIF
+!66666666666666666666666666666666666666666666666666
+ NIINF=IIINF; NJINF=IJINF; NISUP=IISUP; NJSUP=IJSUP
+ XIDEBCOU=ZIDEBCOU; XJDEBCOU=ZJDEBCOU
+ENDIF
+
+!66666666666666666666666666666666666666666666666666
+IF(ALLOCATED(ITABCHAR))THEN
+ DEALLOCATE(ITABCHAR)
+ENDIF
+!66666666666666666666666666666666666666666666666666
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE READ_FILEHEAD
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/read_sufwind.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/read_sufwind.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a829bd456d97b2a720d9ce3d52b7d4497c582928
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/read_sufwind.f90
@@ -0,0 +1,246 @@
+! ######spl
+ SUBROUTINE READ_SUFWIND(HGROUP)
+! ###############################
+!
+!!**** *READ_SUFWIND* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 29/01/98
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HGROUP
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+INTEGER :: J, IND, ILENGP, I
+CHARACTER(LEN=LEN(HGROUP)) :: YGROUP
+!------------------------------------------------------------------------------
+YGROUP=HGROUP
+ILENGP=LEN_TRIM(YGROUP)
+CSUFWIND=' '
+NSUFWIND=0
+DO J=1,1
+ I=7
+ IND=INDEX(YGROUP,'DIRUMVM')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ IND=INDEX(YGROUP,'DIRUTVT')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ I=6
+ IND=INDEX(YGROUP,'DDUMVM')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ IND=INDEX(YGROUP,'DDUTVT')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ I=5
+ IND=INDEX(YGROUP,'MUMVM')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ IND=INDEX(YGROUP,'MUTVT')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ IND=INDEX(YGROUP,'ULMWM')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ IND=INDEX(YGROUP,'ULTWT')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ I=4
+ IND=INDEX(YGROUP,'UMVM')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ IND=INDEX(YGROUP,'UTVT')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ I=3
+ IND=INDEX(YGROUP,'ULM')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ IND=INDEX(YGROUP,'ULT')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ IND=INDEX(YGROUP,'VTM')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ IND=INDEX(YGROUP,'VTT')
+ IF(IND /= 0)THEN
+ IF(ILENGP == I)THEN
+ ELSE IF((ILENGP-I) == 1)THEN
+ CSUFWIND(1:1)=YGROUP(IND+I:IND+I)
+ NSUFWIND=1
+ ELSE IF((ILENGP-I) == 2)THEN
+ CSUFWIND(1:2)=YGROUP(IND+I:IND+I+1)
+ NSUFWIND=2
+ ENDIF
+ EXIT
+ ENDIF
+ENDDO
+!print *,' YGROUP CSUFWIND NSUFWIND ',YGROUP,CSUFWIND,NSUFWIND
+!
+
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE READ_SUFWIND
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/read_th_pr.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/read_th_pr.f90
new file mode 100644
index 0000000000000000000000000000000000000000..521c56ca90087f224f65b1615d58a0f772f17cf1
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/read_th_pr.f90
@@ -0,0 +1,304 @@
+! ##################################################
+ SUBROUTINE READ_TH_PR(HFILEDIA,HLUOUTDIA,KMT,KIND)
+! ##################################################
+!
+!!**** *READ_TH_PR* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/01/97
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODD_SEVERAL_RECORDS
+USE MODD_RESOLVCAR
+USE MODD_FILES_DIACHRO
+USE MODD_MASK3D
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+INTEGER :: KMT, KIND
+CHARACTER(LEN=*) :: HFILEDIA, HLUOUTDIA
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+INTEGER :: J
+CHARACTER(LEN=12) :: YGP, YGPM
+!------------------------------------------------------------------------------
+!
+! KIND=1 --> LTK=.TRUE. or LEV=.TRUE.
+!
+YGP=' '
+YGPM=' '
+IF(KIND == 1)THEN
+ IF(KMT == 1)THEN
+ IF(LTK .OR. LRS .OR. LRS1)THEN
+ YGP='THM'
+ ELSE IF(LEV)THEN
+ YGP='POVOM'
+ ELSE IF(LSV3)THEN
+ IF(LXYZ00)THEN
+ YGP=CGROUPSV3(1:LEN_TRIM(CGROUPSV3))
+ ELSE
+ YGP='LGZM'
+ ENDIF
+ YGPM=YGP
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,YGP)
+ IF(LPBREAD .AND. .NOT.LXYZ00)THEN
+ LPBREAD=.FALSE.
+ YGP='SVM003'
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,YGP)
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ YGP='SVM3'
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE IF(KMT == 2)THEN
+ IF(LTK .OR. LRS .OR. LRS1)THEN
+ YGP='THT'
+ ELSE IF(LEV)THEN
+ YGP='POVOT'
+ ELSE IF(LSV3)THEN
+ IF(LXYZ00)THEN
+ YGP=CGROUPSV3(1:LEN_TRIM(CGROUPSV3))
+ ELSE
+ YGP='LGZT'
+ ENDIF
+ YGPM=YGP
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,YGP)
+ IF(LPBREAD .AND. .NOT.LXYZ00)THEN
+ LPBREAD=.FALSE.
+ YGP='SVT003'
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,YGP)
+ IF(LPBREAD)THEN
+ LPBREAD=.FALSE.
+ YGP='SVT3'
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ SELECT CASE(KMT)
+ CASE(1)
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,YGP)
+ IF(LPBREAD)THEN
+! LPBREAD=.FALSE.
+ IF(LSV3)THEN
+! IF(.NOT.LXY00)THEN
+ IF(YGP /= YGPM)THEN
+ IF(INDEX(YGP,'00') == 0)THEN
+ print *,' **READ_TH_PR requete peut-etre impossible.', YGPM, &
+ ', ',YGP(1:3)//'00'//YGP(4:4),' et ',YGP,' n''existent pas'
+ ELSE
+ print *,' **READ_TH_PR requete peut-etre impossible.',YGPM, &
+ ' et ',YGP,' n''existent pas'
+ ENDIF
+ ENDIF
+! ENDIF
+ ELSE
+ print *,' REQUETE IMPOSSIBLE .',YGP,' N''EXISTE PAS'
+ ENDIF
+ IF(.NOT.LSV3)THEN
+ YGP(LEN_TRIM(YGP):LEN_TRIM(YGP))='T'
+ print *,' **READ_TH_PR Recherche de ** ',YGP,' ** pour resoudre le pb'
+ ENDIF
+ RETURN
+ ELSE
+ print *,' **READ_TH_PR Utilisation de ** ',YGP,' **'
+ ENDIF
+ IF(LGROUP)THEN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,YGP)
+ ENDIF
+ IF(.NOT.LFIC1)THEN
+ CALL REALLOC_AND_LOAD(YGP)
+ IF(LPBREAD)THEN
+! LPBREAD=.FALSE.
+ print *,' REQUETE IMPOSSIBLE .',YGP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ CASE(2)
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,YGP)
+ IF(LPBREAD)THEN
+! LPBREAD=.FALSE.
+ IF(LSV3)THEN
+! IF(.NOT.LXY00)THEN
+ IF(YGP /= YGPM)THEN
+ IF(INDEX(YGP,'00') == 0)THEN
+ print *,' **READ_TH_PR requete peut-etre impossible. ',YGPM, &
+ ', ',YGP(1:3)//'00'//YGP(4:4),' et ',YGP,' n''existent pas'
+ ELSE
+ print *,' **READ_TH_PR requete peut-etre impossible. ',YGPM, &
+ ' et ',YGP,' n''existent pas'
+ ENDIF
+ ENDIF
+! ENDIF
+ ELSE
+ print *,' REQUETE IMPOSSIBLE .',YGP,' N''EXISTE PAS'
+ ENDIF
+ IF(.NOT.LSV3)THEN
+ YGP(LEN_TRIM(YGP):LEN_TRIM(YGP))='M'
+ print *,' **READ_TH_PR Recherche de ** ',YGP,' ** pour resoudre le pb'
+ ENDIF
+ RETURN
+ ELSE
+ print *,' **READ_TH_PR Utilisation de ** ',YGP,' **'
+ ENDIF
+ IF(LGROUP)THEN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,YGP)
+ ENDIF
+ IF(.NOT.LFIC1)THEN
+ CALL REALLOC_AND_LOAD(YGP)
+ IF(LPBREAD)THEN
+! LPBREAD=.FALSE.
+ print *,' REQUETE IMPOSSIBLE .',YGP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ END SELECT
+ IF(ALLOCATED(XTH)) DEALLOCATE(XTH)
+ ALLOCATE(XTH(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ XTH(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+! KIND=2 --> LPR=.TRUE.
+ELSE IF(KIND == 2)THEN
+
+ SELECT CASE(KMT)
+ CASE(1)
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'PABSM')
+! CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'PHIM')
+ IF(LPBREAD)THEN
+! LPBREAD=.FALSE.
+ print *,' REQUETE a priori IMPOSSIBLE . PABSM N''EXISTE PAS . '
+ print *,' **READ_TH_PR Recherche de ** PABST ** pour resoudre le pb'
+ RETURN
+ ELSE
+ print *,' **READ_TH_PR Utilisation de ** PABSM **'
+ ENDIF
+ IF(LGROUP)THEN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'PABSM')
+! CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'PHIM')
+ ENDIF
+ IF(.NOT.LFIC1)THEN
+ CALL REALLOC_AND_LOAD('PABSM')
+! CALL REALLOC_AND_LOAD('PHIM')
+ IF(LPBREAD)THEN
+! LPBREAD=.FALSE.
+ print *,' REQUETE IMPOSSIBLE . PABSM N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ CASE(2)
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'PABST')
+! CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'PHIT')
+ IF(LPBREAD)THEN
+! LPBREAD=.FALSE.
+ print *,' REQUETE a priori IMPOSSIBLE . PABST N''EXISTE PAS . '
+ print *,' **READ_TH_PR Recherche de ** PABSM ** pour resoudre le pb'
+ RETURN
+ ELSE
+ print *,' **READ_TH_PR Utilisation de ** PABST **'
+ ENDIF
+ IF(LGROUP)THEN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'PABST')
+! CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'PHIT')
+ ENDIF
+ IF(.NOT.LFIC1)THEN
+ CALL REALLOC_AND_LOAD('PABST')
+! CALL REALLOC_AND_LOAD('PHIT')
+ IF(LPBREAD)THEN
+! LPBREAD=.FALSE.
+ print *,' REQUETE IMPOSSIBLE . PABST N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ END SELECT
+ ALLOCATE(XPHI(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ XPHI(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+ IF(.NOT.LRS .AND. .NOT.LRS1)THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ IF(ALLOCATED(XPRES))THEN
+ DEALLOCATE(XPRES)
+ ENDIF
+ ALLOCATE(XPRES(SIZE(XPHI,1),SIZE(XPHI,2),SIZE(XPHI,3),SIZE(XPHI,4), &
+ SIZE(XPHI,5),SIZE(XPHI,6)))
+ IF(SIZE(XPHI,5) /= 1 .OR. SIZE(XPHI,6) /= 1)THEN
+ print *,' SIZE(XPHI,5) SIZE(XPHI,6) /= 1 ',SIZE(XPHI,5),SIZE(XPHI,6)
+ print *,' CALCUL DE LA PRESSION IMPOSSIBLE. REQUETE NON TRAITEE '
+ DEALLOCATE(XPHI,XPRES)
+ LPBREAD=.TRUE.
+ RETURN
+ ENDIF
+!! Calcul de la pres/sion
+! Chargement de la pression
+ DO J=1,SIZE(XPHI,4)
+! XPRES(:,:,:,J,1,1)=XP00*(XEXNREF(:,:,:)+XPHI(:,:,:,J,1,1) &
+! /(XCPD*XTHVREF(:,:,:)))**(XCPD/XRD)
+ XPRES(:,:,:,J,1,1)=XPHI(:,:,:,J,1,1)
+ ENDDO
+ DEALLOCATE(XPHI)
+ENDIF
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. RETURNS
+! -----
+!
+RETURN
+END SUBROUTINE READ_TH_PR
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/read_type.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/read_type.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d251fdb955c75e2479ca921cd05526ebbff27094
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/read_type.f90
@@ -0,0 +1,340 @@
+! ######spl
+ MODULE MODI_READ_TYPE
+! #####################
+!
+INTERFACE
+!
+SUBROUTINE READ_TYPE(HFILEDIA,HLUOUTDIA,HGROUP)
+CHARACTER(LEN=*) :: HFILEDIA, HLUOUTDIA, HGROUP
+END SUBROUTINE READ_TYPE
+!
+END INTERFACE
+END MODULE MODI_READ_TYPE
+! ###############################################
+ SUBROUTINE READ_TYPE(HFILEDIA,HLUOUTDIA,HGROUP)
+! ###############################################
+!
+!!**** *READ_TYPE* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/01/97
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_DIACHRO
+USE MODD_TYPE_AND_LH
+USE MODD_SEVERAL_RECORDS
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+USE MODI_FMREAD
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HFILEDIA, HLUOUTDIA, HGROUP
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+CHARACTER(LEN=16) :: YRECFM
+! Aout 99 longueur YCOMMENT passee de 20 a 100
+CHARACTER(LEN=100) :: YCOMMENT
+CHARACTER(LEN=LEN(HGROUP)) :: YGROUP
+INTEGER :: ILENG, ILENCH, IGRID, J ,IL, ILS
+INTEGER :: IRESPDIA
+INTEGER,DIMENSION(:),ALLOCATABLE :: ITABCHAR
+!------------------------------------------------------------------------------
+!
+LUMVM=.FALSE.; LMUMVM=.FALSE.; LULM=.FALSE.; LVTM=.FALSE.
+LUTVT=.FALSE.; LMUTVT=.FALSE.; LULT=.FALSE.; LVTT=.FALSE.
+LULMWM=.FALSE.; LULTWT=.FALSE.
+LSUMVM=.FALSE.; LSUTVT=.FALSE.; LMLSUMVM=.FALSE.; LMLSUTVT=.FALSE.
+LDIRWM=.FALSE.; LDIRWT=.FALSE.
+YRECFM(1:LEN(YRECFM))=' '
+LTYPE=.TRUE.
+YGROUP=HGROUP
+IL=LEN_TRIM(HGROUP)
+ILS=INDEX(HGROUP,'LS')
+IF(ILS == 0)THEN
+!print *,' ENTREE read_type HGROUP ',HGROUP
+ CALL READ_SUFWIND(YGROUP)
+ELSE
+ NSUFWIND=0
+ENDIF
+IF(NSUFWIND == 1)THEN
+ HGROUP(IL:IL)=' '
+ELSE IF(NSUFWIND == 2)THEN
+ HGROUP(IL-1:IL)=' '
+ENDIF
+
+SELECT CASE(HGROUP)
+
+ CASE('UMVM','MUMVM','ULM','VTM','DIRUMVM','DDUMVM')
+
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'UM'//CSUFWIND)
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE UM'//CSUFWIND,' N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='UM'//CSUFWIND
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'VM'//CSUFWIND)
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE VM'//CSUFWIND,' N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='VM'//CSUFWIND
+
+ IF(HGROUP == 'UMVM')THEN
+ LUMVM=.TRUE.
+ ELSE IF(HGROUP == 'MUMVM')THEN
+ LMUMVM=.TRUE.
+ ELSE IF(HGROUP == 'ULM')THEN
+ LULM=.TRUE.
+ ELSE IF(HGROUP == 'VTM')THEN
+ LVTM=.TRUE.
+ ELSE IF(HGROUP == 'DIRUMVM')THEN
+ LDIRWM=.TRUE.
+ LDIRWIND=.TRUE.
+ ELSE IF(HGROUP == 'DDUMVM')THEN
+ LDIRWM=.TRUE.
+ ENDIF
+
+ YRECFM=ADJUSTL(ADJUSTR(YRECFM)//'.TYPE')
+
+ CASE('LSUMVM','MLSUMVM')
+
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'LSUM')
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE LSUM N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='LSUM'
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'LSVM')
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE LSVM N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='LSVM'
+
+ IF(HGROUP == 'LSUMVM')THEN
+ LSUMVM=.TRUE.
+ ELSE IF(HGROUP == 'MLSUMVM')THEN
+ LMLSUMVM=.TRUE.
+ ENDIF
+
+ YRECFM=ADJUSTL(ADJUSTR(YRECFM)//'.TYPE')
+
+ CASE('UTVT','MUTVT','ULT','VTT','DIRUTVT','DDUTVT')
+
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'UT'//CSUFWIND)
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE UT'//CSUFWIND,' N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='UT'//CSUFWIND
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'VT'//CSUFWIND)
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE VT'//CSUFWIND,' N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='VT'//CSUFWIND
+
+ IF(HGROUP == 'UTVT')THEN
+ LUTVT=.TRUE.
+ ELSE IF(HGROUP == 'MUTVT')THEN
+ LMUTVT=.TRUE.
+ ELSE IF(HGROUP == 'ULT')THEN
+ LULT=.TRUE.
+ ELSE IF(HGROUP == 'VTT')THEN
+ LVTT=.TRUE.
+ ELSE IF(HGROUP == 'DIRUTVT')THEN
+ LDIRWT=.TRUE.
+ LDIRWIND=.TRUE.
+ ELSE IF(HGROUP == 'DDUTVT')THEN
+ LDIRWT=.TRUE.
+ ENDIF
+
+ YRECFM=ADJUSTL(ADJUSTR(YRECFM)//'.TYPE')
+
+ CASE('LSUTVT','MLSUTVT')
+
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'LSUT')
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE LSUT N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='LSUT'
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'LSVT')
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE LSVT N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='LSVT'
+
+ IF(HGROUP == 'LSUTVT')THEN
+ LSUTVT=.TRUE.
+ ELSE IF(HGROUP == 'MLSUTVT')THEN
+ LMLSUTVT=.TRUE.
+ ENDIF
+
+ YRECFM=ADJUSTL(ADJUSTR(YRECFM)//'.TYPE')
+
+ CASE('ULMWM')
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'UM'//CSUFWIND)
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE UM'//CSUFWIND,' N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='UM'//CSUFWIND
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'VM'//CSUFWIND)
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE VM'//CSUFWIND,' N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='VM'//CSUFWIND
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'WM'//CSUFWIND)
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE WM'//CSUFWIND,' N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='WM'//CSUFWIND
+
+ LULMWM=.TRUE.
+
+ YRECFM=ADJUSTL(ADJUSTR(YRECFM)//'.TYPE')
+
+ CASE('ULTWT')
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'UT'//CSUFWIND)
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE UT'//CSUFWIND,' N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='UT'//CSUFWIND
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'VT'//CSUFWIND)
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE VT'//CSUFWIND,' N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='VT'//CSUFWIND
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'WT'//CSUFWIND)
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE WT'//CSUFWIND,' N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ YRECFM='WT'//CSUFWIND
+
+ LULTWT=.TRUE.
+
+ YRECFM=ADJUSTL(ADJUSTR(YRECFM)//'.TYPE')
+
+ CASE DEFAULT
+
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,HGROUP)
+ IF(LPBREAD)THEN
+ LTYPE=.FALSE.
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+! print *,' YGROUP : ',HGROUP
+ IF(LGROUP)THEN
+ YRECFM=ADJUSTL(ADJUSTR(HGROUP)//'.TYPE')
+ ELSE
+ YRECFM=ADJUSTL(ADJUSTR(CGPNAM1)//'.TYPE')
+ ENDIF
+END SELECT
+ILENG=LEN(CTYPE)
+ALLOCATE(ITABCHAR(ILENG))
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+IGRID,ILENCH,YCOMMENT,IRESPDIA)
+DO J = 1,ILENG
+ CTYPE(J:J) = CHAR(ITABCHAR(J))
+ENDDO
+DEALLOCATE(ITABCHAR)
+
+LTYPE=.FALSE.
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+!print *,' AV SORTIE HGROUP ',HGROUP
+HGROUP=YGROUP
+!print *,' SORTIE read_type HGROUP ',HGROUP
+RETURN
+END SUBROUTINE READ_TYPE
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/read_uvw.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/read_uvw.f90
new file mode 100644
index 0000000000000000000000000000000000000000..fa499c02ee751675d711fc35953ecccf30c84578
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/read_uvw.f90
@@ -0,0 +1,352 @@
+! ######spl
+ MODULE MODI_READ_UVW
+! #####################
+!
+INTERFACE
+!
+SUBROUTINE READ_UVW(HFILEDIA,HLUOUTDIA,HGROUP)
+CHARACTER(LEN=*) :: HFILEDIA, HLUOUTDIA, HGROUP
+END SUBROUTINE READ_UVW
+!
+END INTERFACE
+END MODULE MODI_READ_UVW
+! ######spl
+ SUBROUTINE READ_UVW(HFILEDIA,HLUOUTDIA,HGROUP)
+! ###############################################
+!
+!!**** *READ_UVW* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/01/97
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_TYPE_AND_LH
+USE MODD_SEVERAL_RECORDS
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODD_FILES_DIACHRO
+USE MODD_MEMGRIUV
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HFILEDIA, HLUOUTDIA, HGROUP
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+INTEGER :: IL
+CHARACTER(LEN=LEN(HGROUP)) :: YGROUP
+!------------------------------------------------------------------------------
+!
+YGROUP=HGROUP
+IL=LEN_TRIM(HGROUP)
+!print *,' ENTREE uvw HGROUP ',HGROUP
+IF(NSUFWIND == 1)THEN
+ HGROUP(IL:IL)=' '
+ELSE IF(NSUFWIND == 2)THEN
+ HGROUP(IL-1:IL)=' '
+ENDIF
+!
+! Chargement des composantes du vent
+! On met toujours U dans XU
+! On laisse V dans XVAR qd on n'utilise que 2 composantes et on la met
+! dans XV ad on utilise les 3 composantes
+! On laisse toujours W dans XVAR
+!
+SELECT CASE(HGROUP)
+
+ CASE('UMVM','MUMVM','ULM','VTM','ULMWM','LSUMVM','MLSUMVM','DIRUMVM','DDUMVM')
+
+ IF(LSUMVM .OR. LMLSUMVM)THEN
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'LSUM')
+ ELSE
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'UM'//CSUFWIND)
+ ENDIF
+ IF(LPBREAD)THEN
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE UM'//CSUFWIND,' ou LSUM N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ IF(LGROUP)THEN
+ IF(LSUMVM .OR. LMLSUMVM)THEN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'LSUM')
+ ELSE
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'UM'//CSUFWIND)
+ ENDIF
+ ENDIF
+ IF(.NOT.LFIC1)THEN
+ IF(LSUMVM .OR. LMLSUMVM)THEN
+ CALL REALLOC_AND_LOAD('LSUM')
+ ELSE
+ CALL REALLOC_AND_LOAD('UM'//CSUFWIND)
+ ENDIF
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE . UM ou LSUM N''EXISTE PAS DANS',&
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ ELSE
+ NBRECOUV=1
+ NRECOUV(1)=1
+ NRECOUV(2)=SIZE(XTRAJT,1)
+ ENDIF
+ ALLOCATE(XU(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ XU(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+!! Nov 2001
+ NGRIU=NGRIDIA(1)
+!! Nov 2001
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+ IF(LSUMVM .OR. LMLSUMVM)THEN
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'LSVM')
+ ELSE
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'VM'//CSUFWIND)
+ ENDIF
+ IF(LPBREAD)THEN
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE VM'//CSUFWIND,' ou LSVM N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ IF(LGROUP)THEN
+ IF(LSUMVM .OR. LMLSUMVM)THEN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'LSVM')
+ ELSE
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'VM'//CSUFWIND)
+ ENDIF
+ ENDIF
+ IF(.NOT.LFIC1)THEN
+ IF(LSUMVM .OR. LMLSUMVM)THEN
+ CALL REALLOC_AND_LOAD('LSVM')
+ ELSE
+ CALL REALLOC_AND_LOAD('VM'//CSUFWIND)
+ ENDIF
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE . VM ou LSVM N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+!! Nov 2001
+ NGRIV=NGRIDIA(1)
+!! Nov 2001
+ IF(LULMWM .OR. LULTWT)THEN
+ ALLOCATE(XV(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ XV(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+!! Nov 2001
+ NGRIV=NGRIDIA(1)
+!! Nov 2001
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+
+ CASE('UTVT','MUTVT','ULT','VTT','ULTWT','LSUTVT','MLSUTVT','DIRUTVT','DDUTVT')
+
+ IF(LSUTVT .OR. LMLSUTVT)THEN
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'LSUT')
+ ELSE
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'UT'//CSUFWIND)
+ ENDIF
+ IF(LPBREAD)THEN
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE UT'//CSUFWIND,' ou LSUT N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ IF(LGROUP)THEN
+ IF(LSUTVT .OR. LMLSUTVT)THEN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'LSUT')
+ ELSE
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'UT'//CSUFWIND)
+ ENDIF
+ ENDIF
+ IF(.NOT.LFIC1)THEN
+ IF(LSUTVT .OR. LMLSUTVT)THEN
+ CALL REALLOC_AND_LOAD('LSUT')
+ ELSE
+ CALL REALLOC_AND_LOAD('UT'//CSUFWIND)
+ ENDIF
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE . UT ou LSUT N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ ENDIF
+ ALLOCATE(XU(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ XU(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+!! Nov 2001
+ NGRIU=NGRIDIA(1)
+!! Nov 2001
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+ IF(LSUTVT .OR. LMLSUTVT)THEN
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'LSVT')
+ ELSE
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'VT'//CSUFWIND)
+ ENDIF
+ IF(LPBREAD)THEN
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE VT'//CSUFWIND,' ou LSVT N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ IF(LGROUP)THEN
+ IF(LSUTVT .OR. LMLSUTVT)THEN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'LSVT')
+ ELSE
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'VT'//CSUFWIND)
+ ENDIF
+ ENDIF
+ IF(.NOT.LFIC1)THEN
+ IF(LSUTVT .OR. LMLSUTVT)THEN
+ CALL REALLOC_AND_LOAD('LSVT')
+ ELSE
+ CALL REALLOC_AND_LOAD('VT'//CSUFWIND)
+ ENDIF
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE . VT ou LSVT N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ ENDIF
+!! Nov 2001
+ NGRIV=NGRIDIA(1)
+!! Nov 2001
+ IF(LULMWM .OR. LULTWT)THEN
+ ALLOCATE(XV(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ XV(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+!! Nov 2001
+ NGRIV=NGRIDIA(1)
+!! Nov 2001
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+
+
+END SELECT
+
+SELECT CASE(HGROUP)
+
+ CASE('ULMWM')
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'WM'//CSUFWIND)
+ IF(LPBREAD)THEN
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE WM'//CSUFWIND,' N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ IF(LGROUP)THEN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'WM'//CSUFWIND)
+ ENDIF
+ IF(.NOT.LFIC1)THEN
+ CALL REALLOC_AND_LOAD('WM'//CSUFWIND)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE . WM N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ ENDIF
+! ALLOCATE(XW(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+! SIZE(XVAR,5),SIZE(XVAR,6)))
+! XW(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+! CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+
+ CASE('ULTWT')
+ CALL VERIF_GROUP(HFILEDIA,HLUOUTDIA,'WT'//CSUFWIND)
+ IF(LPBREAD)THEN
+ print *,' GROUPE DEMANDE: ',YGROUP,' REQUETE IMPOSSIBLE '
+ print *,' LA COMPOSANTE WT'//CSUFWIND,' N''EXISTE PAS '
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ IF(LGROUP)THEN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,'WT'//CSUFWIND)
+ ENDIF
+ IF(.NOT.LFIC1)THEN
+ CALL REALLOC_AND_LOAD('WT'//CSUFWIND)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE . WT N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ HGROUP=YGROUP
+ RETURN
+ ENDIF
+ ENDIF
+! ALLOCATE(XW(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+! SIZE(XVAR,5),SIZE(XVAR,6)))
+! XW(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+! CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+
+END SELECT
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+HGROUP=YGROUP
+!print *,' uvw YGROUP CSUFWIND NSUFWIND ',YGROUP,CSUFWIND,NSUFWIND
+RETURN
+END SUBROUTINE READ_UVW
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/readcol_ft_pvkt.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/readcol_ft_pvkt.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2337b0c1120391393e200b52b506373a3bc87e4a
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/readcol_ft_pvkt.f90
@@ -0,0 +1,102 @@
+! ######spl
+ MODULE MODI_READCOL_FT_PVKT
+! ############################
+!
+INTERFACE
+!
+SUBROUTINE READCOL_FT_PVKT(HCARIN,KCOLI)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KCOLI
+END SUBROUTINE READCOL_FT_PVKT
+!
+END INTERFACE
+END MODULE MODI_READCOL_FT_PVKT
+! ######spl
+ SUBROUTINE READCOL_FT_PVKT(HCARIN,KCOLI)
+! ########################################
+!
+!!**** *READCOL_FT_PVKT* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 2/09/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KCOLI
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: J,JM
+CHARACTER(LEN=LEN(HCARIN)) :: YCARIN, YCARIN2
+
+!
+!------------------------------------------------------------------------------
+KCOLI=0
+IF(NBCOLI == 0)THEN
+ RETURN
+ELSE
+ YCARIN(1:LEN(YCARIN))=' '
+ YCARIN=ADJUSTL(HCARIN)
+ JM=0
+ DO J=1,LEN(YCARIN)
+ IF(YCARIN(J:J) == ' ')THEN
+ JM=J-1
+ EXIT
+ ENDIF
+ ENDDO
+ IF(JM /= 0)THEN
+ YCARIN2(1:LEN(YCARIN2))=' '
+ YCARIN2=YCARIN(1:JM)
+ YCARIN(1:LEN(YCARIN))=' '
+ YCARIN=ADJUSTL(YCARIN2)
+ ENDIF
+ DO J=1,NBCOLI
+ IF(YCARIN == CCOLI(J))THEN
+ KCOLI=NCOLI(J)
+ EXIT
+ ENDIF
+ ENDDO
+ RETURN
+ENDIF
+END SUBROUTINE READCOL_FT_PVKT
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/readmnmx_ft_pvkt.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/readmnmx_ft_pvkt.f90
new file mode 100644
index 0000000000000000000000000000000000000000..065a88b2fff836ab77ec868c28095f64894d9324
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/readmnmx_ft_pvkt.f90
@@ -0,0 +1,162 @@
+! ######spl
+ MODULE MODI_READMNMX_FT_PVKT
+! ############################
+!
+INTERFACE
+!
+SUBROUTINE READMNMX_FT_PVKT(HCARIN,PMN,PMX)
+CHARACTER(LEN=*) :: HCARIN
+REAL :: PMN, PMX
+END SUBROUTINE READMNMX_FT_PVKT
+!
+END INTERFACE
+END MODULE MODI_READMNMX_FT_PVKT
+! ######spl
+ SUBROUTINE READMNMX_FT_PVKT(HCARIN,PMN,PMX)
+! ###########################################
+!
+!!**** *READMNMX_FT_PVKT* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 2/09/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+REAL :: PMN, PMX
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: IMASK
+INTEGER :: J,JM
+LOGICAL :: GOKMN, GOKMX
+!REAL,DIMENSION(:),ALLOCATABLE :: ZFTMN, ZFTMX
+!CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE :: YFTMN, YFTMX
+CHARACTER(LEN=LEN(HCARIN)) :: YCARIN, YCARIN2
+
+!
+!------------------------------------------------------------------------------
+GOKMN=.FALSE.
+GOKMX=.FALSE.
+YCARIN(1:LEN(YCARIN))=' '
+HCARIN=ADJUSTL(HCARIN)
+YCARIN=HCARIN
+if(nverbia >0)then
+ print *,' **READMNMX_FT_PVKT YCARIN ',YCARIN(1:LEN_TRIM(YCARIN))
+endif
+IMASK=INDEX(YCARIN,'MASK')
+IF(IMASK /=0)THEN
+DO J=1,LEN(YCARIN)
+ IF(YCARIN(J:J) == ' ')THEN
+ JM=J-1
+ EXIT
+ ENDIF
+ENDDO
+YCARIN(1:LEN(YCARIN))=' '
+YCARIN=HCARIN(JM+2:LEN_TRIM(HCARIN))
+YCARIN=ADJUSTL(YCARIN)
+ENDIF
+JM=0
+DO J=1,LEN(YCARIN)
+ IF(YCARIN(J:J) == ' ')THEN
+ JM=J-1
+ EXIT
+ ENDIF
+ENDDO
+IF(JM /= 0)THEN
+ YCARIN2(1:LEN(YCARIN2))=' '
+ YCARIN2=YCARIN(1:JM)
+ YCARIN(1:LEN(YCARIN))=' '
+ YCARIN=ADJUSTL(YCARIN2)
+ENDIF
+!
+
+if(nverbia >0)then
+ print *,' **READMNMX_FT_PVKT JM,NBFTMN,NBFTMX ',JM,NBFTMN,NBFTMX
+endif
+IF(NBFTMN == 0)THEN
+ GOKMN=.FALSE.
+ print *,' AUCUN MIN USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ELSE
+ DO J=1,NBFTMN
+! IF(YCARIN(1:LEN_TRIM(YCARIN)) == CFTMN(J)(1:LEN_TRIM(YCARIN)))THEN
+ IF(YCARIN(1:LEN_TRIM(YCARIN)) == CFTMN(J))THEN
+ PMN=XFTMN(J)
+ print *,' MIN ENREGISTRE SOUS LA FORME XPVMIN_',YCARIN(1:LEN_TRIM(YCARIN)),' UTILISE: ',PMN
+ GOKMN=.TRUE.
+ EXIT
+ ENDIF
+ ENDDO
+ IF(.NOT.GOKMN)THEN
+ print *,' AUCUN MIN USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ ENDIF
+ENDIF
+!
+IF(NBFTMX == 0)THEN
+ GOKMX=.FALSE.
+ print *,' AUCUN MAX USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ELSE
+ DO J=1,NBFTMX
+! IF(YCARIN(1:LEN_TRIM(YCARIN)) == CFTMX(J)(1:LEN_TRIM(YCARIN)))THEN
+ IF(YCARIN(1:LEN_TRIM(YCARIN)) == CFTMX(J))THEN
+ PMX=XFTMX(J)
+ print *,' MAX ENREGISTRE SOUS LA FORME XPVMAX_',YCARIN(1:LEN_TRIM(YCARIN)),' UTILISE: ',PMX
+ GOKMX=.TRUE.
+ EXIT
+ ENDIF
+ ENDDO
+ IF(.NOT.GOKMX)THEN
+ print *,' AUCUN MAX USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ ENDIF
+ENDIF
+IF(.NOT.GOKMN .OR. .NOT.GOKMX)THEN
+ LOK=.FALSE.
+ print *,' CALCUL AUTOMATIQUE DES BORNES POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ELSE
+ LOK=.TRUE.
+ENDIF
+if(nverbia >0)then
+ print *,' **READMNMX_FT_PVKT LOK ',LOK
+endif
+RETURN
+END SUBROUTINE READMNMX_FT_PVKT
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/readmnmxint_iso.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/readmnmxint_iso.f90
new file mode 100644
index 0000000000000000000000000000000000000000..01844b380775a7ebcf2c36b75523ff7c04434428
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/readmnmxint_iso.f90
@@ -0,0 +1,213 @@
+! ######spl
+ MODULE MODI_READMNMXINT_ISO
+! ###########################
+!
+INTERFACE
+!
+SUBROUTINE READMNMXINT_ISO(KIMNMX,HCARIN,PMN,PMX,PINT)
+INTEGER, INTENT(INOUT) :: KIMNMX
+CHARACTER(LEN=*) :: HCARIN
+REAL :: PMN, PMX, PINT
+END SUBROUTINE READMNMXINT_ISO
+!
+END INTERFACE
+END MODULE MODI_READMNMXINT_ISO
+! ######spl
+ SUBROUTINE READMNMXINT_ISO(KIMNMX,HCARIN,PMN,PMX,PINT)
+! ###############################################
+!
+!!**** *READMNMXINT_ISO* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 2/09/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+!
+INTEGER, INTENT(INOUT) :: KIMNMX
+CHARACTER(LEN=*) :: HCARIN
+REAL :: PMN, PMX, PINT
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: IMASK
+INTEGER :: J,JM
+LOGICAL :: GOKMN, GOKMX, GOKINT
+REAL :: ZMEMINT
+!REAL,DIMENSION(:),ALLOCATABLE :: ZISOMN, ZISOMX, ZISOINT
+!CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE :: YISOMN, YISOMX, YISOINT
+CHARACTER(LEN=LEN(HCARIN)) :: YCARIN, YCARIN2
+!
+!------------------------------------------------------------------------------
+GOKMN=.FALSE.
+GOKMX=.FALSE.
+GOKINT=.FALSE.
+!
+YCARIN(1:LEN(YCARIN))=' '
+HCARIN=ADJUSTL(HCARIN)
+YCARIN=HCARIN
+IMASK=INDEX(YCARIN,'MASK')
+IF(IMASK /=0)THEN
+DO J=1,LEN(YCARIN)
+ IF(YCARIN(J:J) == ' ')THEN
+ JM=J-1
+ EXIT
+ ENDIF
+ENDDO
+YCARIN(1:LEN(YCARIN))=' '
+YCARIN=HCARIN(JM+2:LEN_TRIM(HCARIN))
+YCARIN=ADJUSTL(YCARIN)
+ENDIF
+JM=0
+DO J=1,LEN(YCARIN)
+ IF(YCARIN(J:J) == ' ')THEN
+ JM=J-1
+ EXIT
+ ENDIF
+ENDDO
+IF(JM /= 0)THEN
+ YCARIN2(1:LEN(YCARIN2))=' '
+ YCARIN2=YCARIN(1:JM)
+ YCARIN(1:LEN(YCARIN))=' '
+ YCARIN=ADJUSTL(YCARIN2)
+ENDIF
+!
+ZMEMINT=PINT
+PINT=0.
+!
+IF(NBISOMN == 0)THEN
+ GOKMN=.FALSE.
+ print *,' AUCUN MIN USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ELSE
+ DO J=1,NBISOMN
+ IF(YCARIN(1:LEN_TRIM(YCARIN)) == CISOMN(J)(1:LEN_TRIM(CISOMN(J))))THEN
+ PMN=XISOMN(J)
+ GOKMN=.TRUE.
+ EXIT
+ ENDIF
+ ENDDO
+ IF(.NOT.GOKMN)THEN
+ print *,' AUCUN MIN USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ ENDIF
+ENDIF
+!
+IF(NBISOMX == 0)THEN
+ GOKMX=.FALSE.
+ print *,' AUCUN MAX USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ELSE
+ DO J=1,NBISOMX
+ IF(YCARIN(1:LEN_TRIM(YCARIN)) == CISOMX(J)(1:LEN_TRIM(CISOMX(J))))THEN
+ PMX=XISOMX(J)
+ GOKMX=.TRUE.
+ EXIT
+ ENDIF
+ ENDDO
+ IF(.NOT.GOKMX)THEN
+ print *,' AUCUN MAX USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ ENDIF
+ENDIF
+IF(NBISOINT == 0)THEN
+ GOKINT=.FALSE.
+ print *,' AUCUN INT USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ELSE
+ DO J=1,NBISOINT
+ IF(YCARIN(1:LEN_TRIM(YCARIN)) == CISOINT(J)(1:LEN_TRIM(CISOINT(J))))THEN
+ PINT=XISOINT(J)
+ GOKINT=.TRUE.
+ EXIT
+ ENDIF
+ ENDDO
+ IF(.NOT.GOKINT)THEN
+ print *,' AUCUN INT USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ ENDIF
+ENDIF
+IF(.NOT.GOKMN .OR. .NOT.GOKMX .OR. .NOT.GOKINT)THEN
+ LISOK=.FALSE.
+ print *,' UTILISATION DES VALEURS DE XISOMIN,XISOMAX,XDIAINT POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ELSE
+ LISOK=.TRUE.
+ENDIF
+!
+!------------------------------------------------------------------------------
+IF(.NOT. LISOK)THEN
+
+ IF(PINT == 0.)THEN
+ PINT=ZMEMINT
+ ENDIF
+ IF((KIMNMX == 0 .OR. KIMNMX == 1) .AND. PINT == 0.)THEN
+! IF(XISOMIN == XISOMAX)THEN
+! 230498
+ IF(XISOMIN == XISOMAX .AND. XISOMIN /= 0. .AND. XISOMAX /= 0.)THEN
+ PMN=XISOMIN
+ PMX=XISOMAX
+ ELSE
+ print *,' AVEC NIMNMX = ',KIMNMX,' VOUS DEVEZ FOURNIR DANS XDIAINT (OU',&
+ &' XDIAINT_PROCESSUS) UN INTERVALLE D''ISOCONTOURS NON NUL.'
+ print *,' NIMNMX FORCE A LA VALEUR -1'
+ KIMNMX=-1
+ ENDIF
+ ELSE IF(KIMNMX == 1 .AND. PINT /= 0.)THEN
+ IF(XISOMAX == XISOMIN .OR. XISOMAX-XISOMIN <0 .OR. (XISOMAX-XISOMIN)/PINT <1)THEN
+ IF(XISOMAX == XISOMIN)THEN
+ PMN=XISOMIN
+ PMX=XISOMAX
+ ELSE
+ print *,' AVEC NIMNMX = ',KIMNMX,' VOUS DEVEZ FOURNIR DANS XDIAINT (OU',&
+ &' XDIAINT_PROCESSUS) UN INTERVALLE D''ISOCONTOURS NON NUL.'
+ print *,' DANS XISOMIN (OU XISOMIN_PROCESSUS) et XISOMAX (OU', &
+ &' XISOMAX_PROCESSUS) DES VALEURS EXTREMES D''ISOCONTOURS COHERENTES'
+ print *,' VALEURS ACTUELLES XISOMIN,XISOMAX,XDIAINT :',XISOMIN,XISOMAX,XDIAINT
+ print *,' NIMNMX FORCE A LA VALEUR -1'
+ KIMNMX=-1
+ ENDIF
+ ELSE
+ ! On explore la table utilisateur en premier
+ PMN=XISOMIN
+ PMX=XISOMAX
+ ENDIF
+ ENDIF
+ELSE
+ LISOK=.FALSE.
+ENDIF
+
+
+END SUBROUTINE READMNMXINT_ISO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/readrefint_iso.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/readrefint_iso.f90
new file mode 100644
index 0000000000000000000000000000000000000000..36e60a4051d8d879d5f805618e679d436f236486
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/readrefint_iso.f90
@@ -0,0 +1,246 @@
+! ######spl
+ MODULE MODI_READREFINT_ISO
+! ###########################
+!
+INTERFACE
+!
+SUBROUTINE READREFINT_ISO(HCARIN,PTABMN,PTABMX,PINT,PISOLEV)
+CHARACTER(LEN=*) :: HCARIN
+REAL, INTENT(IN) :: PTABMN,PTABMX
+REAL :: PINT
+REAL, DIMENSION(:) :: PISOLEV
+END SUBROUTINE READREFINT_ISO
+!
+END INTERFACE
+END MODULE MODI_READREFINT_ISO
+! ######spl
+ SUBROUTINE READREFINT_ISO(HCARIN,PTABMN,PTABMX,PINT,PISOLEV)
+! ###############################################
+!
+!!**** *READREFINT_ISO* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 2/09/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+REAL, INTENT(IN) :: PTABMN,PTABMX
+REAL :: PINT
+REAL, DIMENSION(:) :: PISOLEV
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: IMASK,II,IIMIN,IIMAX,IIDEB,IIFIN,INBISO
+INTEGER :: J,JM
+REAL :: ZMEMINT,ZREF,ZVALMIN,ZVALMAX
+LOGICAL :: GOKREF, GOKINT
+REAL, DIMENSION(SIZE(PISOLEV)) :: ZISOLEV
+CHARACTER(LEN=LEN(HCARIN)) :: YCARIN, YCARIN2
+!
+!------------------------------------------------------------------------------
+GOKREF=.FALSE.
+GOKINT=.FALSE.
+!
+YCARIN(1:LEN(YCARIN))=' '
+HCARIN=ADJUSTL(HCARIN)
+YCARIN=HCARIN
+IMASK=INDEX(YCARIN,'MASK')
+IF(IMASK /=0)THEN
+DO J=1,LEN(YCARIN)
+ IF(YCARIN(J:J) == ' ')THEN
+ JM=J-1
+ EXIT
+ ENDIF
+ENDDO
+YCARIN(1:LEN(YCARIN))=' '
+YCARIN=HCARIN(JM+2:LEN_TRIM(HCARIN))
+YCARIN=ADJUSTL(YCARIN)
+ENDIF
+JM=0
+DO J=1,LEN(YCARIN)
+ IF(YCARIN(J:J) == ' ')THEN
+ JM=J-1
+ EXIT
+ ENDIF
+ENDDO
+IF(JM /= 0)THEN
+ YCARIN2(1:LEN(YCARIN2))=' '
+ YCARIN2=YCARIN(1:JM)
+ YCARIN(1:LEN(YCARIN))=' '
+ YCARIN=ADJUSTL(YCARIN2)
+ENDIF
+!
+ZMEMINT=PINT
+!
+IF(NBISOREF == 0)THEN
+ GOKREF=.FALSE.
+ print *,' AUCUN REF USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ELSE
+ DO J=1,NBISOREF
+ IF(YCARIN(1:LEN_TRIM(YCARIN)) == CISOREF(J)(1:LEN_TRIM(YCARIN)))THEN
+ ZREF=XISOREFP(J)
+ GOKREF=.TRUE.
+ EXIT
+ ENDIF
+ ENDDO
+ IF(.NOT.GOKREF)THEN
+ print *,' AUCUN REF USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ ENDIF
+ENDIF
+!
+IF(NBISOINT == 0)THEN
+ GOKINT=.FALSE.
+ print *,' AUCUN INT USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ELSE
+ DO J=1,NBISOINT
+ IF(YCARIN(1:LEN_TRIM(YCARIN)) == CISOINT(J)(1:LEN_TRIM(YCARIN)))THEN
+ PINT=XISOINT(J)
+ GOKINT=.TRUE.
+ EXIT
+ ENDIF
+ ENDDO
+ IF(.NOT.GOKINT)THEN
+ print *,' AUCUN INT USER ENREGISTRE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ ENDIF
+ENDIF
+IF(.NOT.GOKREF .OR. .NOT.GOKINT)THEN
+ LISOREF=.FALSE.
+ print *,' UTILISATION DES VALEURS DE XISOREF,XDIAINT POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ELSE
+ LISOREF=.TRUE.
+ENDIF
+!------------------------------------------------------------------------------
+
+IF(.NOT. LISOREF)THEN
+ PINT=XDIAINT
+ IF(PINT == 0.)THEN
+ PINT=ZMEMINT
+ ENDIF
+ ZREF=XISOREF
+ IF (ZREF.LT.PTABMN .OR. ZREF.GT.PTABMX) THEN
+if (nverbia>5) then
+ print*,'TABmin-max= ',PTABMN,PTABMX
+ print*,'ISO REF hors des valeurs extremes du champ = ',XISOREF
+endif
+ ZREF=0.5*(PTABMN+PTABMX)
+if (nverbia>5) then
+ print*,'ISO REF calcule = ',ZREF
+endif
+ ENDIF
+ELSE
+ LISOREF=.FALSE.
+ENDIF
+!------------------------------------------------------------------------------
+ZISOLEV(:)=0.
+ZVALMIN=ZREF ; ZVALMAX=ZREF
+! ZISOLEV contient les valeurs des differentes isolignes a tracer
+!rempli ainsi: ZREF -PINT +PINT -2.PINT +2.PINT ...
+II=1 ; IIMIN=II ; IIMAX=II
+ZISOLEV(1)=ZREF
+DO J=1,SIZE(ZISOLEV)
+ ZVALMIN=ZVALMIN-PINT
+ IF (ZVALMIN.GT.PTABMN) THEN
+ II=II+1
+ ZISOLEV(II)=ZVALMIN
+ IIMIN=II
+ ENDIF
+ ZVALMAX=ZVALMAX+PINT
+ IF (ZVALMAX.LT.PTABMX) THEN
+ II=II+1
+ ZISOLEV(II)=ZVALMAX
+ IIMAX=II
+ ENDIF
+ENDDO
+if (nverbia>=5) then
+ print*,'IIMIN,IIMAX,II= ',IIMIN,IIMAX,II
+endif
+if (nverbia>5) then
+ print*,'ZISOLEV= ',ZISOLEV
+endif
+!
+! reordonne pour PISOLEV de la valeur min a la valeur max
+INBISO=II
+IF (INBISO.LE.2) THEN
+ PISOLEV(1)=ZISOLEV(1)
+ PISOLEV(2)=ZISOLEV(2)
+ELSE
+ II=1
+ IF (IIMIN .GT. (IIMAX+1)) THEN ! premiers min contigus
+ DO J=IIMIN,IIMAX+1,-1
+ PISOLEV(II)=ZISOLEV(J)
+ II=II+1
+ END DO
+ IIDEB=IIMAX+1-2
+ ELSE
+ IIDEB=IIMIN
+ ENDIF
+ !
+ IF (IIDEB.GT.0) THEN ! traite les valeurs inf a ZREF
+ ! une valeur sur 2 pour les min suivants
+ DO J=IIDEB,2,-2
+ PISOLEV(II)=ZISOLEV(J)
+ II=II+1
+ END DO
+ IIFIN=MIN(IIMAX,IIMIN+1)
+ ! une valeur sur 2 pour les premiers max
+ DO J=1,IIFIN,2
+ PISOLEV(II)=ZISOLEV(J)
+ II=II+1
+ END DO
+ ELSE ! toutes les valeurs sont sup a ZREF
+ IIFIN=0
+ ENDIF
+ !
+ IF (IIMAX.GT.IIMIN+1) THEN ! derniers max contigus
+ DO J=IIFIN+1,IIMAX
+ PISOLEV(II)=ZISOLEV(J)
+ II=II+1
+ ENDDO
+ ENDIF
+ENDIF
+if (nverbia>5) then
+ print*,'II= ',II
+endif
+
+END SUBROUTINE READREFINT_ISO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/readxisolevp.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/readxisolevp.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bf6628d3e3e4b041381b5b584ffc3025512d74f0
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/readxisolevp.f90
@@ -0,0 +1,145 @@
+! ######spl
+ MODULE MODI_READXISOLEVP
+! #########################
+!
+INTERFACE
+!
+SUBROUTINE READXISOLEVP(HCARIN,K,PISOLEVP)
+INTEGER :: K
+CHARACTER(LEN=*) :: HCARIN
+REAL,DIMENSION(:):: PISOLEVP
+END SUBROUTINE READXISOLEVP
+!
+END INTERFACE
+!
+END MODULE MODI_READXISOLEVP
+! ######spl
+ SUBROUTINE READXISOLEVP(HCARIN,K,PISOLEVP)
+! ##########################################
+!
+!!**** *READXISOLEVP* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 2/09/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+INTEGER :: K
+CHARACTER(LEN=*) :: HCARIN
+REAL,DIMENSION(:) :: PISOLEVP
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: IMASK
+INTEGER :: J,JM
+CHARACTER(LEN=LEN(HCARIN)) :: YCARIN, YCARIN2
+
+!
+!------------------------------------------------------------------------------
+YCARIN(1:LEN(YCARIN))=' '
+HCARIN=ADJUSTL(HCARIN)
+YCARIN=HCARIN
+IMASK=INDEX(YCARIN,'MASK')
+IF(IMASK /=0)THEN
+DO J=1,LEN(YCARIN)
+ IF(YCARIN(J:J) == ' ')THEN
+ JM=J-1
+ EXIT
+ ENDIF
+ENDDO
+YCARIN(1:LEN(YCARIN))=' '
+YCARIN=HCARIN(JM+2:LEN_TRIM(HCARIN))
+YCARIN=ADJUSTL(YCARIN)
+ENDIF
+JM=0
+DO J=1,LEN(YCARIN)
+ IF(YCARIN(J:J) == ' ')THEN
+ JM=J-1
+ EXIT
+ ENDIF
+ENDDO
+IF(JM /= 0)THEN
+ YCARIN2(1:LEN(YCARIN2))=' '
+ YCARIN2=YCARIN(1:JM)
+ YCARIN(1:LEN(YCARIN))=' '
+ YCARIN=ADJUSTL(YCARIN2)
+ENDIF
+!
+LISOLEVP=.FALSE.
+IF(NBISOLEVP == 0)THEN
+ LISOLEVP=.FALSE.
+ print *,' AUCUNE VALEUR USER ENREGISTREE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))&
+ ,' sous la forme XISOLEV_PROC= '
+ELSE
+ DO J=1,NBISOLEVP
+ IF(YCARIN(1:LEN_TRIM(YCARIN)) == CISOLEVP(J)(1:LEN_TRIM(CISOLEVP(J))))THEN
+ K=NLENP(J)
+ PISOLEVP(1:NLENP(J))=XISOLEVP(1:NLENP(J),J)
+ LISOLEVP=.TRUE.
+ IF(NVERBIA >= 5)THEN
+ print *,' READXISOLEVP NLENP PISOLEVP ',K,PISOLEVP(1:NLENP(J))
+ ENDIF
+ EXIT
+ ENDIF
+ ENDDO
+ IF(.NOT.LISOLEVP)THEN
+ print *,' AUCUNE VALEUR USER ENREGISTREE POUR : ',YCARIN(1:LEN_TRIM(YCARIN))&
+ ,' sous la forme XISOLEV_PROC= '
+ ELSE
+ print *,' UTILISATION DES VALEURS ENREGISTREES sous la forme XISOLEV_PROC= '
+ print *,' POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ print *,PISOLEVP(1:K-1)
+ ENDIF
+ENDIF
+!
+IF(.NOT.LISOLEVP)THEN
+ print *,' UTILISATION DES VALEURS DE XISOLEV= (si elles existent) POUR : ',YCARIN(1:LEN_TRIM(YCARIN))
+ DO J=1,SIZE(XISOLEV,1)
+ IF(XISOLEV(J) == 9999.)THEN
+ print *,XISOLEV(1:J-1)
+ EXIT
+ ENDIF
+ ENDDO
+ENDIF
+RETURN
+END SUBROUTINE READXISOLEVP
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/realloc_and_load.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/realloc_and_load.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e30abe62dfd36be0005d0f0143b17732741edfd5
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/realloc_and_load.f90
@@ -0,0 +1,467 @@
+! ######spl
+ MODULE MODI_REALLOC_AND_LOAD
+! #############################
+!
+INTERFACE
+!
+SUBROUTINE REALLOC_AND_LOAD(HGROUP)
+CHARACTER(LEN=*) :: HGROUP
+END SUBROUTINE REALLOC_AND_LOAD
+!
+END INTERFACE
+END MODULE MODI_REALLOC_AND_LOAD
+! ######spl
+ SUBROUTINE REALLOC_AND_LOAD(HGROUP)
+! ###################################
+!
+!!**** *REALLOC_AND_LOAD* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_FILES_DIACHRO
+USE MODD_RESOLVCAR
+USE MODD_TYPE_AND_LH
+USE MODD_SEVERAL_RECORDS
+USE MODI_VERIF_GROUP
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+!
+CHARACTER(LEN=*) :: HGROUP
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: J,JME,JT
+INTEGER :: II, IJ, IK,IT, IN, IP, IT1, IT2, IL
+INTEGER :: IMODJ
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: IGRIDIA
+
+REAL,DIMENSION(:,:,:,:,:,:),ALLOCATABLE :: ZVAR, ZVAR2
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: ZTRAJX, ZTRAJX2
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: ZTRAJY, ZTRAJY2
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: ZTRAJZ, ZTRAJZ2
+REAL,DIMENSION(:,:),ALLOCATABLE :: ZTRAJT, ZTRAJT2
+REAL,DIMENSION(:,:),ALLOCATABLE :: ZDATIME, ZDATIME2
+REAL,DIMENSION(:,:,:,:,:,:),ALLOCATABLE :: ZMASK, ZMASK2
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: YTITRE
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: YUNITE
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: YCOMMENT
+
+!------------------------------------------------------------------------------
+IF(ALLOCATED(XVAR))THEN
+ ALLOCATE(ZVAR(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ ZVAR(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+ENDIF
+IF(ALLOCATED(XTRAJT))THEN
+ ALLOCATE(ZTRAJT(SIZE(XTRAJT,1),SIZE(XTRAJT,2)))
+ ZTRAJT(:,:)=XTRAJT(:,:)
+ENDIF
+IF(ALLOCATED(XTRAJX))THEN
+ ALLOCATE(ZTRAJX(SIZE(XTRAJX,1),SIZE(XTRAJX,2),SIZE(XTRAJX,3)))
+ ZTRAJX(:,:,:)=XTRAJX(:,:,:)
+ENDIF
+IF(ALLOCATED(XTRAJY))THEN
+ ALLOCATE(ZTRAJY(SIZE(XTRAJY,1),SIZE(XTRAJY,2),SIZE(XTRAJY,3)))
+ ZTRAJY(:,:,:)=XTRAJY(:,:,:)
+ENDIF
+IF(ALLOCATED(XTRAJZ))THEN
+ ALLOCATE(ZTRAJZ(SIZE(XTRAJZ,1),SIZE(XTRAJZ,2),SIZE(XTRAJZ,3)))
+ ZTRAJZ(:,:,:)=XTRAJZ(:,:,:)
+ENDIF
+IF(ALLOCATED(XMASK))THEN
+ ALLOCATE(ZMASK(SIZE(XMASK,1),SIZE(XMASK,2),SIZE(XMASK,3),SIZE(XMASK,4), &
+ SIZE(XMASK,5),SIZE(XMASK,6)))
+ ZMASK(:,:,:,:,:,:)=XMASK(:,:,:,:,:,:)
+ENDIF
+IF(ALLOCATED(NGRIDIA))THEN
+ ALLOCATE(IGRIDIA(SIZE(NGRIDIA)))
+ IGRIDIA(:)=NGRIDIA(:)
+ENDIF
+IF(ALLOCATED(CTITRE))THEN
+ ALLOCATE(YTITRE(SIZE(CTITRE)))
+ YTITRE=CTITRE
+ENDIF
+IF(ALLOCATED(CUNITE))THEN
+ ALLOCATE(YUNITE(SIZE(CUNITE)))
+ YUNITE=CUNITE
+ENDIF
+IF(ALLOCATED(CCOMMENT))THEN
+ ALLOCATE(YCOMMENT(SIZE(CCOMMENT)))
+ YCOMMENT=CCOMMENT
+ENDIF
+IF(ALLOCATED(XDATIME))THEN
+ ALLOCATE(ZDATIME(SIZE(XDATIME,1),SIZE(XDATIME,2)))
+ ZDATIME(:,:)=XDATIME(:,:)
+ENDIF
+
+CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+DO J=2,NBSIMULT
+
+ JME=NINDFILESIMULT(J)
+ CALL READ_FILEHEAD(JME,CFILEDIAS(JME),CLUOUTDIAS(JME))
+ CALL VERIF_GROUP(CFILEDIAS(JME),CLUOUTDIAS(JME),HGROUP)
+ IF(LPBREAD)THEN
+ EXIT
+ ENDIF
+ IF(LGROUP)THEN
+ CALL READ_DIACHRO(CFILEDIAS(JME),CLUOUTDIAS(JME),HGROUP)
+ ENDIF
+ IMODJ=MOD(J,2)
+
+ SELECT CASE(IMODJ)
+ CASE(0)
+ IF(ALLOCATED(XVAR))THEN
+ IT1=SIZE(ZVAR,4);IT2=SIZE(XVAR,4)
+ IT=IT1+IT2
+ ALLOCATE(ZVAR2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),IT, &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ ZVAR2(:,:,:,1:IT1,:,:)=ZVAR(:,:,:,1:IT1,:,:)
+ ZVAR2(:,:,:,IT1+1:IT,:,:)=XVAR(:,:,:,:,:,:)
+ DEALLOCATE(ZVAR)
+ ENDIF
+ IF(ALLOCATED(XTRAJT))THEN
+ ALLOCATE(ZTRAJT2(IT,SIZE(XTRAJT,2)))
+ ZTRAJT2(1:IT1,:)=ZTRAJT(1:IT1,:)
+ ZTRAJT2(IT1+1:IT,:)=XTRAJT(:,:)
+ DEALLOCATE(ZTRAJT)
+ ENDIF
+ IF(ALLOCATED(XTRAJX))THEN
+ ALLOCATE(ZTRAJX2(SIZE(XTRAJX,1),IT,SIZE(XTRAJX,3)))
+ IF (CTYPE=='SSOL') THEN
+ DO JT=1,IT1
+ ZTRAJX2(:,JT,:)=ZTRAJX(:,1,:)
+ END DO
+ DO JT=IT1+1,IT
+ ZTRAJX2(:,JT,:)=XTRAJX(:,1,:)
+ END DO
+ ELSE
+ ZTRAJX2(:,1:IT1,:)=ZTRAJX(:,1:IT1,:)
+ ZTRAJX2(:,IT1+1:IT,:)=XTRAJX(:,:,:)
+ ENDIF
+ DEALLOCATE(ZTRAJX)
+ ENDIF
+ IF(ALLOCATED(XTRAJY))THEN
+ ALLOCATE(ZTRAJY2(SIZE(XTRAJY,1),IT,SIZE(XTRAJY,3)))
+ IF (CTYPE=='SSOL') THEN
+ DO JT=1,IT1
+ ZTRAJY2(:,JT,:)=ZTRAJY(:,1,:)
+ END DO
+ DO JT=IT1+1,IT
+ ZTRAJY2(:,JT,:)=XTRAJY(:,1,:)
+ END DO
+ ELSE
+ ZTRAJY2(:,1:IT1,:)=ZTRAJY(:,1:IT1,:)
+ ZTRAJY2(:,IT1+1:IT,:)=XTRAJY(:,:,:)
+ ENDIF
+ DEALLOCATE(ZTRAJY)
+ ENDIF
+ IF(ALLOCATED(XTRAJZ))THEN
+ ALLOCATE(ZTRAJZ2(SIZE(XTRAJZ,1),IT,SIZE(XTRAJZ,3)))
+ IF (CTYPE=='SSOL') THEN
+ DO JT=1,IT1
+ ZTRAJZ2(:,JT,:)=ZTRAJZ(:,1,:)
+ END DO
+ DO JT=IT1+1,IT
+ ZTRAJZ2(:,JT,:)=XTRAJZ(:,1,:)
+ END DO
+ ELSE
+ ZTRAJZ2(:,1:IT1,:)=ZTRAJZ(:,1:IT1,:)
+ ZTRAJZ2(:,IT1+1:IT,:)=XTRAJZ(:,:,:)
+ ENDIF
+ DEALLOCATE(ZTRAJZ)
+ ENDIF
+ IF(ALLOCATED(XMASK))THEN
+ ALLOCATE(ZMASK2(SIZE(XMASK,1),SIZE(XMASK,2),SIZE(XMASK,3),IT, &
+ SIZE(XMASK,5),SIZE(XMASK,6)))
+ ZMASK2(:,:,:,1:IT1,:,:)=ZMASK(:,:,:,1:IT1,:,:)
+ ZMASK2(:,:,:,IT1+1:IT,:,:)=XMASK(:,:,:,:,:,:)
+ DEALLOCATE(ZMASK)
+ ENDIF
+ IF(ALLOCATED(XDATIME))THEN
+ ALLOCATE(ZDATIME2(SIZE(XDATIME,1),IT))
+ ZDATIME2(:,1:IT1)=ZDATIME(:,1:IT1)
+ ZDATIME2(:,IT1+1:IT)=XDATIME(:,:)
+ DEALLOCATE(ZDATIME)
+ ENDIF
+! IF(ALLOCATED(CTITRE))THEN
+! ALLOCATE(YTITRE(SIZE(CTITRE)))
+! YTITRE=CTITRE
+! ENDIF
+! IF(ALLOCATED(CUNITE))THEN
+! ALLOCATE(YUNITE(SIZE(CUNITE)))
+! YUNITE=CUNITE
+! ENDIF
+! IF(ALLOCATED(CCOMMENT))THEN
+! ALLOCATE(YCOMMENT(SIZE(CCOMMENT)))
+! YCOMMENT=CCOMMENT
+! ENDIF
+
+ CASE DEFAULT
+
+ IF(ALLOCATED(XVAR))THEN
+ IT1=SIZE(ZVAR2,4);IT2=SIZE(XVAR,4)
+ IT=IT1+IT2
+
+ ALLOCATE(ZVAR(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),IT, &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ ZVAR(:,:,:,1:IT1,:,:)=ZVAR2(:,:,:,1:IT1,:,:)
+ ZVAR(:,:,:,IT1+1:IT,:,:)=XVAR(:,:,:,:,:,:)
+ DEALLOCATE(ZVAR2)
+ ENDIF
+ IF(ALLOCATED(XTRAJT))THEN
+ ALLOCATE(ZTRAJT(IT,SIZE(XTRAJT,2)))
+ ZTRAJT(1:IT1,:)=ZTRAJT2(1:IT1,:)
+ ZTRAJT(IT1+1:IT,:)=XTRAJT(:,:)
+ DEALLOCATE(ZTRAJT2)
+ ENDIF
+ IF(ALLOCATED(XTRAJX))THEN
+ ALLOCATE(ZTRAJX(SIZE(XTRAJX,1),IT,SIZE(XTRAJX,3)))
+ IF (CTYPE=='SSOL') THEN
+ DO JT=1,IT1
+ ZTRAJX(:,JT,:)=ZTRAJX2(:,1,:)
+ END DO
+ DO JT=IT1+1,IT
+ ZTRAJX(:,JT,:)=XTRAJX(:,1,:)
+ END DO
+ ELSE
+ ZTRAJX(:,1:IT1,:)=ZTRAJX2(:,1:IT1,:)
+ ZTRAJX(:,IT1+1:IT,:)=XTRAJX(:,:,:)
+ ENDIF
+ DEALLOCATE(ZTRAJX2)
+ ENDIF
+ IF(ALLOCATED(XTRAJY))THEN
+ ALLOCATE(ZTRAJY(SIZE(XTRAJY,1),IT,SIZE(XTRAJY,3)))
+ IF (CTYPE=='SSOL') THEN
+ DO JT=1,IT1
+ ZTRAJY(:,JT,:)=ZTRAJY2(:,1,:)
+ END DO
+ DO JT=IT1+1,IT
+ ZTRAJY(:,JT,:)=XTRAJY(:,1,:)
+ END DO
+ ELSE
+ ZTRAJY(:,1:IT1,:)=ZTRAJY2(:,1:IT1,:)
+ ZTRAJY(:,IT1+1:IT,:)=XTRAJY(:,:,:)
+ ENDIF
+ DEALLOCATE(ZTRAJY2)
+ ENDIF
+ IF(ALLOCATED(XTRAJZ))THEN
+ ALLOCATE(ZTRAJZ(SIZE(XTRAJZ,1),IT,SIZE(XTRAJZ,3)))
+ IF (CTYPE=='SSOL') THEN
+ DO JT=1,IT1
+ ZTRAJZ(:,JT,:)=ZTRAJZ2(:,1,:)
+ END DO
+ DO JT=IT1+1,IT
+ ZTRAJZ(:,JT,:)=XTRAJZ(:,1,:)
+ END DO
+ ELSE
+ ZTRAJZ(:,1:IT1,:)=ZTRAJZ2(:,1:IT1,:)
+ ZTRAJZ(:,IT1+1:IT,:)=XTRAJZ(:,:,:)
+ ENDIF
+ DEALLOCATE(ZTRAJZ2)
+ ENDIF
+ IF(ALLOCATED(XDATIME))THEN
+ ALLOCATE(ZDATIME(SIZE(XDATIME,1),IT))
+ ZDATIME(:,1:IT1)=ZDATIME2(:,1:IT1)
+ ZDATIME(:,IT1+1:IT)=XDATIME(:,:)
+ DEALLOCATE(ZDATIME2)
+ ENDIF
+ IF(ALLOCATED(XMASK))THEN
+ ALLOCATE(ZMASK(SIZE(XMASK,1),SIZE(XMASK,2),SIZE(XMASK,3),IT, &
+ SIZE(XMASK,5),SIZE(XMASK,6)))
+ ZMASK(:,:,:,1:IT1,:,:)=ZMASK2(:,:,:,1:IT1,:,:)
+ ZMASK(:,:,:,IT1+1:IT,:,:)=XMASK(:,:,:,:,:,:)
+ DEALLOCATE(ZMASK2)
+ ENDIF
+
+ END SELECT
+
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+ENDDO
+
+IF(MOD(NBSIMULT,2) == 0)THEN
+ II=SIZE(ZVAR2,1); IJ=SIZE(ZVAR2,2); IK=SIZE(ZVAR2,3)
+! IF(ALLOCATED(XMASK))THEN
+ IF(CTYPE == 'MASK')THEN
+ II=SIZE(ZMASK2,1); IJ=SIZE(ZMASK2,2)
+ ENDIF
+ IT=SIZE(ZVAR2,4); IN=SIZE(ZVAR2,5); IP=SIZE(ZVAR2,6)
+ELSE
+ II=SIZE(ZVAR,1); IJ=SIZE(ZVAR,2); IK=SIZE(ZVAR,3)
+! IF(ALLOCATED(XMASK))THEN
+ IF(CTYPE == 'MASK')THEN
+ II=SIZE(ZMASK,1); IJ=SIZE(ZMASK,2)
+ ENDIF
+ IT=SIZE(ZVAR,4); IN=SIZE(ZVAR,5); IP=SIZE(ZVAR,6)
+ENDIF
+
+CALL ALLOC_FORDIACHRO(II,IJ,IK,IT,IN,IP,1)
+
+IF(MOD(NBSIMULT,2) == 0)THEN
+
+ IF(ALLOCATED(XVAR))THEN
+ XVAR(:,:,:,:,:,:)=ZVAR2(:,:,:,:,:,:)
+ DEALLOCATE(ZVAR2)
+ ENDIF
+ IF(ALLOCATED(XTRAJT))THEN
+ XTRAJT(:,:)=ZTRAJT2(:,:)
+ DEALLOCATE(ZTRAJT2)
+ ENDIF
+ IF(ALLOCATED(XTRAJX))THEN
+ IF (CTYPE=='SSOL') THEN
+ !SIZE(XTRAJX,2)=1
+ XTRAJX(:,1,:)=ZTRAJX2(:,1,:)
+ ELSE
+ XTRAJX(:,:,:)=ZTRAJX2(:,:,:)
+ ENDIF
+ DEALLOCATE(ZTRAJX2)
+ ENDIF
+ IF(ALLOCATED(XTRAJY))THEN
+ IF (CTYPE=='SSOL') THEN
+ XTRAJY(:,1,:)=ZTRAJY2(:,1,:)
+ ELSE
+ XTRAJY(:,:,:)=ZTRAJY2(:,:,:)
+ ENDIF
+ DEALLOCATE(ZTRAJY2)
+ ENDIF
+ IF(ALLOCATED(XTRAJZ))THEN
+ IF (CTYPE=='SSOL') THEN
+ XTRAJZ(:,1,:)=ZTRAJZ2(:,1,:)
+ ELSE
+ XTRAJZ(:,:,:)=ZTRAJZ2(:,:,:)
+ ENDIF
+ DEALLOCATE(ZTRAJZ2)
+ ENDIF
+ IF(ALLOCATED(XMASK))THEN
+ XMASK(:,:,:,:,:,:)=ZMASK2(:,:,:,:,:,:)
+ DEALLOCATE(ZMASK2)
+ ENDIF
+ IF(ALLOCATED(XDATIME))THEN
+ XDATIME(:,:)=ZDATIME2(:,:)
+ DEALLOCATE(ZDATIME2)
+ ENDIF
+
+ELSE
+
+ IF(ALLOCATED(XVAR))THEN
+ XVAR(:,:,:,:,:,:)=ZVAR(:,:,:,:,:,:)
+ DEALLOCATE(ZVAR)
+ ENDIF
+ IF(ALLOCATED(XTRAJT))THEN
+ XTRAJT(:,:)=ZTRAJT(:,:)
+ DEALLOCATE(ZTRAJT)
+ ENDIF
+ IF(ALLOCATED(XTRAJX))THEN
+ IF (CTYPE=='SSOL') THEN
+ !SIZE(XTRAJX,2)=1
+ XTRAJX(:,1,:)=ZTRAJX(:,1,:)
+ ELSE
+ XTRAJX(:,:,:)=ZTRAJX(:,:,:)
+ ENDIF
+ DEALLOCATE(ZTRAJX)
+ ENDIF
+ IF(ALLOCATED(XTRAJY))THEN
+ IF (CTYPE=='SSOL') THEN
+ XTRAJY(:,1,:)=ZTRAJY(:,1,:)
+ ELSE
+ XTRAJY(:,:,:)=ZTRAJY(:,:,:)
+ ENDIF
+ DEALLOCATE(ZTRAJY)
+ ENDIF
+ IF(ALLOCATED(XTRAJZ))THEN
+ IF (CTYPE=='SSOL') THEN
+ XTRAJZ(:,1,:)=ZTRAJZ(:,1,:)
+ ELSE
+ XTRAJZ(:,:,:)=ZTRAJZ(:,:,:)
+ ENDIF
+ DEALLOCATE(ZTRAJZ)
+ ENDIF
+ IF(ALLOCATED(XMASK))THEN
+ XMASK(:,:,:,:,:,:)=ZMASK(:,:,:,:,:,:)
+ DEALLOCATE(ZMASK)
+ ENDIF
+ IF(ALLOCATED(XDATIME))THEN
+ XDATIME(:,:)=ZDATIME(:,:)
+ DEALLOCATE(ZDATIME)
+ ENDIF
+
+ENDIF
+
+! Traitement du recouvrement
+!
+NBRECOUV=1
+NRECOUV(1)=1
+IL=1
+DO J=2,SIZE(XTRAJT,1)
+ IF(XTRAJT(J,1) <= XTRAJT(J-1,1))THEN
+ NBRECOUV=NBRECOUV+1
+ IL=IL+1
+ NRECOUV(IL)=J-1
+ IL=IL+1
+ NRECOUV(IL)=J
+ ENDIF
+ENDDO
+IL=IL+1
+NRECOUV(IL)=SIZE(XTRAJT,1)
+
+
+IF(ALLOCATED(NGRIDIA))THEN
+ NGRIDIA(:)=IGRIDIA(:)
+ DEALLOCATE(IGRIDIA)
+ENDIF
+IF(ALLOCATED(CTITRE))THEN
+ CTITRE=YTITRE
+ DEALLOCATE(YTITRE)
+ENDIF
+IF(ALLOCATED(CUNITE))THEN
+ CUNITE=YUNITE
+ DEALLOCATE(YUNITE)
+ENDIF
+IF(ALLOCATED(CCOMMENT))THEN
+ CCOMMENT=YCOMMENT
+ DEALLOCATE(YCOMMENT)
+ENDIF
+
+RETURN
+END SUBROUTINE REALLOC_AND_LOAD
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/realloc_and_load_records.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/realloc_and_load_records.f90
new file mode 100644
index 0000000000000000000000000000000000000000..12f730b29b0f445278041cb4a30b48c7f2c5f3b6
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/realloc_and_load_records.f90
@@ -0,0 +1,411 @@
+! ######spl
+ MODULE MODI_REALLOC_AND_LOAD_RECORDS
+! ####################################
+!
+INTERFACE
+!
+SUBROUTINE REALLOC_AND_LOAD_RECORDS(HFILEDIA,HLUOUTDIA)
+CHARACTER(LEN=*) :: HFILEDIA, HLUOUTDIA
+END SUBROUTINE REALLOC_AND_LOAD_RECORDS
+!
+END INTERFACE
+END MODULE MODI_REALLOC_AND_LOAD_RECORDS
+! ######spl
+ SUBROUTINE REALLOC_AND_LOAD_RECORDS(HFILEDIA,HLUOUTDIA)
+! #######################################################
+!
+!!**** *REALLOC_AND_LOAD_RECORDS* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_FILES_DIACHRO
+USE MODD_RESOLVCAR
+USE MODD_TYPE_AND_LH
+USE MODD_SEVERAL_RECORDS
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HFILEDIA, HLUOUTDIA
+
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: J
+INTEGER :: II, IJ, IK,IT, IN, IP, IT1, IT2
+INTEGER :: IMODJ
+INTEGER :: INB, INAM
+
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: IGRIDIA
+
+REAL,DIMENSION(:,:,:,:,:,:),ALLOCATABLE :: ZVAR, ZVAR2
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: ZTRAJX, ZTRAJX2
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: ZTRAJY, ZTRAJY2
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: ZTRAJZ, ZTRAJZ2
+REAL,DIMENSION(:,:),ALLOCATABLE :: ZTRAJT, ZTRAJT2
+REAL,DIMENSION(:,:),ALLOCATABLE :: ZDATIME, ZDATIME2
+REAL,DIMENSION(:,:,:,:,:,:),ALLOCATABLE :: ZMASK, ZMASK2
+CHARACTER(LEN=16) :: YNAM
+CHARACTER(LEN=1) :: YC1
+CHARACTER(LEN=2) :: YC2
+CHARACTER(LEN=3) :: YC3
+CHARACTER(LEN=4) :: YC4
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: YTITRE
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: YUNITE
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: YCOMMENT
+
+!------------------------------------------------------------------------------
+IF(ALLOCATED(XVAR))THEN
+ ALLOCATE(ZVAR(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ ZVAR(:,:,:,:,:,:)=XVAR(:,:,:,:,:,:)
+ENDIF
+IF(ALLOCATED(XTRAJT))THEN
+ ALLOCATE(ZTRAJT(SIZE(XTRAJT,1),SIZE(XTRAJT,2)))
+ ZTRAJT(:,:)=XTRAJT(:,:)
+ENDIF
+IF(ALLOCATED(XTRAJX))THEN
+ ALLOCATE(ZTRAJX(SIZE(XTRAJX,1),SIZE(XTRAJX,2),SIZE(XTRAJX,3)))
+ ZTRAJX(:,:,:)=XTRAJX(:,:,:)
+ENDIF
+IF(ALLOCATED(XTRAJY))THEN
+ ALLOCATE(ZTRAJY(SIZE(XTRAJY,1),SIZE(XTRAJY,2),SIZE(XTRAJY,3)))
+ ZTRAJY(:,:,:)=XTRAJY(:,:,:)
+ENDIF
+IF(ALLOCATED(XTRAJZ))THEN
+ ALLOCATE(ZTRAJZ(SIZE(XTRAJZ,1),SIZE(XTRAJZ,2),SIZE(XTRAJZ,3)))
+ ZTRAJZ(:,:,:)=XTRAJZ(:,:,:)
+ENDIF
+IF(ALLOCATED(XMASK))THEN
+ ALLOCATE(ZMASK(SIZE(XMASK,1),SIZE(XMASK,2),SIZE(XMASK,3),SIZE(XMASK,4), &
+ SIZE(XMASK,5),SIZE(XMASK,6)))
+ ZMASK(:,:,:,:,:,:)=XMASK(:,:,:,:,:,:)
+ENDIF
+IF(ALLOCATED(NGRIDIA))THEN
+ ALLOCATE(IGRIDIA(SIZE(NGRIDIA)))
+ IGRIDIA(:)=NGRIDIA(:)
+ENDIF
+IF(ALLOCATED(CTITRE))THEN
+ ALLOCATE(YTITRE(SIZE(CTITRE)))
+ YTITRE=CTITRE
+ENDIF
+IF(ALLOCATED(CUNITE))THEN
+ ALLOCATE(YUNITE(SIZE(CUNITE)))
+ YUNITE=CUNITE
+ENDIF
+IF(ALLOCATED(CCOMMENT))THEN
+ ALLOCATE(YCOMMENT(SIZE(CCOMMENT)))
+ YCOMMENT=CCOMMENT
+ENDIF
+IF(ALLOCATED(XDATIME))THEN
+ ALLOCATE(ZDATIME(SIZE(XDATIME,1),SIZE(XDATIME,2)))
+ ZDATIME(:,:)=XDATIME(:,:)
+ENDIF
+
+CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+! Modifs 13/6/97
+INB=(NAM2-NAM1)/NINCRNAM+1
+IF(NVERBIA > 0)THEN
+print *,' REALLOC_AND_LOAD... NAM1,NAM2,NINCRNAM,INB ', &
+NAM1,NAM2,NINCRNAM,INB,CGPNAM1,' ',CGPNAM2
+ENDIF
+!INB=NAM2-NAM1+1
+INAM=NAM1
+
+IF(INB > 1)THEN
+
+DO J=2,INB
+
+! Modifs 13/6/97
+INAM=INAM+NINCRNAM
+!INAM=INAM+1
+! Determination du nom du groupe
+ SELECT CASE(NBCNUM)
+ CASE(:1)
+ IF(INAM < 10)THEN
+ WRITE(YC1,'(I1)')INAM
+ YNAM=ADJUSTL(ADJUSTR(CGPNAM)//YC1)
+ ELSE IF(INAM < 100)THEN
+ WRITE(YC2,'(I2)')INAM
+ YNAM=ADJUSTL(ADJUSTR(CGPNAM)//YC2)
+ ELSE IF(INAM < 1000)THEN
+ WRITE(YC3,'(I3)')INAM
+ YNAM=ADJUSTL(ADJUSTR(CGPNAM)//YC3)
+ ELSE
+ WRITE(YC4,'(I4)')INAM
+ YNAM=ADJUSTL(ADJUSTR(CGPNAM)//YC4)
+ ENDIF
+ CASE(2)
+ WRITE(YC2,'(I2.2)')INAM
+ YNAM=ADJUSTL(ADJUSTR(CGPNAM)//YC2)
+ CASE(3)
+ WRITE(YC3,'(I3.3)')INAM
+ YNAM=ADJUSTL(ADJUSTR(CGPNAM)//YC3)
+ CASE(4)
+ WRITE(YC4,'(I4.4)')INAM
+ YNAM=ADJUSTL(ADJUSTR(CGPNAM)//YC4)
+ END SELECT
+! print *,' READ_AND_LOAD_RECORDS YNAM INAM ',YNAM,INAM
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,YNAM)
+ IMODJ=MOD(J,2)
+
+ SELECT CASE(IMODJ)
+ CASE(0)
+ IF(ALLOCATED(XVAR))THEN
+ IT1=SIZE(ZVAR,4);IT2=SIZE(XVAR,4)
+ IT=IT1+IT2
+
+ ALLOCATE(ZVAR2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),IT, &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ ZVAR2(:,:,:,1:IT1,:,:)=ZVAR(:,:,:,1:IT1,:,:)
+ ZVAR2(:,:,:,IT1+1:IT,:,:)=XVAR(:,:,:,:,:,:)
+ DEALLOCATE(ZVAR)
+ ENDIF
+ IF(ALLOCATED(XTRAJT))THEN
+ ALLOCATE(ZTRAJT2(IT,SIZE(XTRAJT,2)))
+ ZTRAJT2(1:IT1,:)=ZTRAJT(1:IT1,:)
+ ZTRAJT2(IT1+1:IT,:)=XTRAJT(:,:)
+ DEALLOCATE(ZTRAJT)
+ ENDIF
+ IF(ALLOCATED(XTRAJX))THEN
+ ALLOCATE(ZTRAJX2(SIZE(XTRAJX,1),IT,SIZE(XTRAJX,3)))
+ ZTRAJX2(:,1:IT1,:)=ZTRAJX(:,1:IT1,:)
+ ZTRAJX2(:,IT1+1:IT,:)=XTRAJX(:,:,:)
+ DEALLOCATE(ZTRAJX)
+ ENDIF
+ IF(ALLOCATED(XTRAJY))THEN
+ ALLOCATE(ZTRAJY2(SIZE(XTRAJY,1),IT,SIZE(XTRAJY,3)))
+ ZTRAJY2(:,1:IT1,:)=ZTRAJY(:,1:IT1,:)
+ ZTRAJY2(:,IT1+1:IT,:)=XTRAJY(:,:,:)
+ DEALLOCATE(ZTRAJY)
+ ENDIF
+ IF(ALLOCATED(XTRAJZ))THEN
+ ALLOCATE(ZTRAJZ2(SIZE(XTRAJZ,1),IT,SIZE(XTRAJZ,3)))
+ ZTRAJZ2(:,1:IT1,:)=ZTRAJZ(:,1:IT1,:)
+ ZTRAJZ2(:,IT1+1:IT,:)=XTRAJZ(:,:,:)
+ DEALLOCATE(ZTRAJZ)
+ ENDIF
+ IF(ALLOCATED(XMASK))THEN
+ ALLOCATE(ZMASK2(SIZE(XMASK,1),SIZE(XMASK,2),SIZE(XMASK,3),IT, &
+ SIZE(XMASK,5),SIZE(XMASK,6)))
+ ZMASK2(:,:,:,1:IT1,:,:)=ZMASK(:,:,:,1:IT1,:,:)
+ ZMASK2(:,:,:,IT1+1:IT,:,:)=XMASK(:,:,:,:,:,:)
+ DEALLOCATE(ZMASK)
+ ENDIF
+ IF(ALLOCATED(XDATIME))THEN
+ ALLOCATE(ZDATIME2(SIZE(XDATIME,1),IT))
+ ZDATIME2(:,1:IT1)=ZDATIME(:,1:IT1)
+ ZDATIME2(:,IT1+1:IT)=XDATIME(:,:)
+ DEALLOCATE(ZDATIME)
+ ENDIF
+! IF(ALLOCATED(CTITRE))THEN
+! ALLOCATE(YTITRE(SIZE(CTITRE)))
+! YTITRE=CTITRE
+! ENDIF
+! IF(ALLOCATED(CUNITE))THEN
+! ALLOCATE(YUNITE(SIZE(CUNITE)))
+! YUNITE=CUNITE
+! ENDIF
+! IF(ALLOCATED(CCOMMENT))THEN
+! ALLOCATE(YCOMMENT(SIZE(CCOMMENT)))
+! YCOMMENT=CCOMMENT
+! ENDIF
+
+ CASE DEFAULT
+
+ IF(ALLOCATED(XVAR))THEN
+ IT1=SIZE(ZVAR2,4);IT2=SIZE(XVAR,4)
+ IT=IT1+IT2
+
+ ALLOCATE(ZVAR(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),IT, &
+ SIZE(XVAR,5),SIZE(XVAR,6)))
+ ZVAR(:,:,:,1:IT1,:,:)=ZVAR2(:,:,:,1:IT1,:,:)
+ ZVAR(:,:,:,IT1+1:IT,:,:)=XVAR(:,:,:,:,:,:)
+ DEALLOCATE(ZVAR2)
+ ENDIF
+ IF(ALLOCATED(XTRAJT))THEN
+ ALLOCATE(ZTRAJT(IT,SIZE(XTRAJT,2)))
+ ZTRAJT(1:IT1,:)=ZTRAJT2(1:IT1,:)
+ ZTRAJT(IT1+1:IT,:)=XTRAJT(:,:)
+ DEALLOCATE(ZTRAJT2)
+ ENDIF
+ IF(ALLOCATED(XTRAJX))THEN
+ ALLOCATE(ZTRAJX(SIZE(XTRAJX,1),IT,SIZE(XTRAJX,3)))
+ ZTRAJX(:,1:IT1,:)=ZTRAJX2(:,1:IT1,:)
+ ZTRAJX(:,IT1+1:IT,:)=XTRAJX(:,:,:)
+ DEALLOCATE(ZTRAJX2)
+ ENDIF
+ IF(ALLOCATED(XTRAJY))THEN
+ ALLOCATE(ZTRAJY(SIZE(XTRAJY,1),IT,SIZE(XTRAJY,3)))
+ ZTRAJY(:,1:IT1,:)=ZTRAJY2(:,1:IT1,:)
+ ZTRAJY(:,IT1+1:IT,:)=XTRAJY(:,:,:)
+ DEALLOCATE(ZTRAJY2)
+ ENDIF
+ IF(ALLOCATED(XTRAJZ))THEN
+ ALLOCATE(ZTRAJZ(SIZE(XTRAJZ,1),IT,SIZE(XTRAJZ,3)))
+ ZTRAJZ(:,1:IT1,:)=ZTRAJZ2(:,1:IT1,:)
+ ZTRAJZ(:,IT1+1:IT,:)=XTRAJZ(:,:,:)
+ DEALLOCATE(ZTRAJZ2)
+ ENDIF
+ IF(ALLOCATED(XDATIME))THEN
+ ALLOCATE(ZDATIME(SIZE(XDATIME,1),IT))
+ ZDATIME(:,1:IT1)=ZDATIME2(:,1:IT1)
+ ZDATIME(:,IT1+1:IT)=XDATIME(:,:)
+ DEALLOCATE(ZDATIME2)
+ ENDIF
+ IF(ALLOCATED(XMASK))THEN
+ ALLOCATE(ZMASK(SIZE(XMASK,1),SIZE(XMASK,2),SIZE(XMASK,3),IT, &
+ SIZE(XMASK,5),SIZE(XMASK,6)))
+ ZMASK(:,:,:,1:IT1,:,:)=ZMASK2(:,:,:,1:IT1,:,:)
+ ZMASK(:,:,:,IT1+1:IT,:,:)=XMASK(:,:,:,:,:,:)
+ DEALLOCATE(ZMASK2)
+ ENDIF
+
+ END SELECT
+
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+ENDDO
+
+ENDIF
+
+IF(MOD(INB,2) == 0)THEN
+ II=SIZE(ZVAR2,1); IJ=SIZE(ZVAR2,2); IK=SIZE(ZVAR2,3)
+! IF(ALLOCATED(XMASK))THEN
+ IF(CTYPE == 'MASK')THEN
+ II=SIZE(ZMASK2,1); IJ=SIZE(ZMASK2,2)
+ ENDIF
+ IT=SIZE(ZVAR2,4); IN=SIZE(ZVAR2,5); IP=SIZE(ZVAR2,6)
+ELSE
+ II=SIZE(ZVAR,1); IJ=SIZE(ZVAR,2); IK=SIZE(ZVAR,3)
+! IF(ALLOCATED(XMASK))THEN
+ IF(CTYPE == 'MASK')THEN
+ II=SIZE(ZMASK,1); IJ=SIZE(ZMASK,2)
+ ENDIF
+ IT=SIZE(ZVAR,4); IN=SIZE(ZVAR,5); IP=SIZE(ZVAR,6)
+ENDIF
+
+CALL ALLOC_FORDIACHRO(II,IJ,IK,IT,IN,IP,1)
+
+IF(MOD(INB,2) == 0)THEN
+
+ IF(ALLOCATED(XVAR))THEN
+ XVAR(:,:,:,:,:,:)=ZVAR2(:,:,:,:,:,:)
+ DEALLOCATE(ZVAR2)
+ ENDIF
+ IF(ALLOCATED(XTRAJT))THEN
+ XTRAJT(:,:)=ZTRAJT2(:,:)
+ DEALLOCATE(ZTRAJT2)
+ ENDIF
+ IF(ALLOCATED(XTRAJX))THEN
+ XTRAJX(:,:,:)=ZTRAJX2(:,:,:)
+ DEALLOCATE(ZTRAJX2)
+ ENDIF
+ IF(ALLOCATED(XTRAJY))THEN
+ XTRAJY(:,:,:)=ZTRAJY2(:,:,:)
+ DEALLOCATE(ZTRAJY2)
+ ENDIF
+ IF(ALLOCATED(XTRAJZ))THEN
+ XTRAJZ(:,:,:)=ZTRAJZ2(:,:,:)
+ DEALLOCATE(ZTRAJZ2)
+ ENDIF
+ IF(ALLOCATED(XMASK))THEN
+ XMASK(:,:,:,:,:,:)=ZMASK2(:,:,:,:,:,:)
+ DEALLOCATE(ZMASK2)
+ ENDIF
+ IF(ALLOCATED(XDATIME))THEN
+ XDATIME(:,:)=ZDATIME2(:,:)
+ DEALLOCATE(ZDATIME2)
+ ENDIF
+
+ELSE
+
+ IF(ALLOCATED(XVAR))THEN
+ XVAR(:,:,:,:,:,:)=ZVAR(:,:,:,:,:,:)
+ DEALLOCATE(ZVAR)
+ ENDIF
+ IF(ALLOCATED(XTRAJT))THEN
+ XTRAJT(:,:)=ZTRAJT(:,:)
+ DEALLOCATE(ZTRAJT)
+ ENDIF
+ IF(ALLOCATED(XTRAJX))THEN
+ XTRAJX(:,:,:)=ZTRAJX(:,:,:)
+ DEALLOCATE(ZTRAJX)
+ ENDIF
+ IF(ALLOCATED(XTRAJY))THEN
+ XTRAJY(:,:,:)=ZTRAJY(:,:,:)
+ DEALLOCATE(ZTRAJY)
+ ENDIF
+ IF(ALLOCATED(XTRAJZ))THEN
+ XTRAJZ(:,:,:)=ZTRAJZ(:,:,:)
+ DEALLOCATE(ZTRAJZ)
+ ENDIF
+ IF(ALLOCATED(XMASK))THEN
+ XMASK(:,:,:,:,:,:)=ZMASK(:,:,:,:,:,:)
+ DEALLOCATE(ZMASK)
+ ENDIF
+ IF(ALLOCATED(XDATIME))THEN
+ XDATIME(:,:)=ZDATIME(:,:)
+ DEALLOCATE(ZDATIME)
+ ENDIF
+
+ENDIF
+IF(ALLOCATED(NGRIDIA))THEN
+ NGRIDIA=IGRIDIA
+ DEALLOCATE(IGRIDIA)
+ENDIF
+IF(ALLOCATED(CTITRE))THEN
+ CTITRE=YTITRE
+ DEALLOCATE(YTITRE)
+ENDIF
+IF(ALLOCATED(CUNITE))THEN
+ CUNITE=YUNITE
+ DEALLOCATE(YUNITE)
+ENDIF
+IF(ALLOCATED(CCOMMENT))THEN
+ CCOMMENT=YCOMMENT
+ DEALLOCATE(YCOMMENT)
+ENDIF
+
+RETURN
+END SUBROUTINE REALLOC_AND_LOAD_RECORDS
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/resolv_nijinf_nijsup.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/resolv_nijinf_nijsup.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d26f393a8063124be2802acc545358447879ac57
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/resolv_nijinf_nijsup.f90
@@ -0,0 +1,149 @@
+! ######spl
+ SUBROUTINE RESOLV_NIJINF_NIJSUP
+! ###############################
+!
+!!**** *RESOLV_NIJINF_NIJSUP* - Affectation des valeurs de NIINF, NISUP,
+!! NJINF et NJSUP dans les 2 cas CH et CV
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 16/01/95
+!! Updated PM
+!-------------------------------------------------------------------------------
+USE MODD_DIM1
+USE MODD_TYPE_AND_LH
+USE MODD_PARAMETERS
+USE MODD_RESOLVCAR
+USE MODN_PARA
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!-------------------------------------------------------------------------------
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! CH Positionnement NIINF, NJINF, NISUP, NJSUP
+! Defaut : NIINF=NIL, NJINF=NJL, NISUP=NIH, NJSUP=NJH
+! Sinon valeurs fournies par l'utilisateur dans les limites (NIL,NJL NIH,
+! NJH)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ if(nverbia > 0)then
+ print *,' **resolv_ni... LCH LCV LCHXY LFT LPVKT ',LCH,LCV,LCHXY,LFT,LPVKT
+ endif
+
+ IF((LCH.AND..NOT.LCV) .OR. (LCHXY.AND..NOT.LCV))THEN
+
+ IF(NIINF == 0)THEN
+ NIINF=NIL
+ IF(NIINF == 1)NIINF=NIINF+JPHEXT
+ ELSE IF(NIINF /=0)THEN
+ print *,' NIINF DEMANDE NIL NIH ', &
+ NIINF,NIL,NIH
+ IF(NIINF < NIL .OR. NIINF > NIH)THEN
+ NIINF=NIL
+ IF(NIINF == 1)THEN
+ NIINF=NIINF+JPHEXT
+ ENDIF
+ print *,' NIINF MODIFIE ', NIINF
+ ENDIF
+ ENDIF
+
+ IF(NJINF == 0)THEN
+ NJINF=NJL
+ IF(NJINF == 1)NJINF=NJINF+JPHEXT
+ ELSE IF(NJINF /=0)THEN
+ print *,' NJINF DEMANDE NJL NJH ', &
+ NJINF,NJL,NJH
+ IF(NJINF < NJL .OR. NJINF > NJH)THEN
+ NJINF=NJL
+ IF(NJINF == 1)THEN
+ NJINF=NJINF+JPHEXT
+ ENDIF
+ print *,' NJINF MODIFIE ', NJINF
+ ENDIF
+ ENDIF
+
+ IF(NISUP == 0)THEN
+ NISUP=NIH
+ IF(NISUP > NIMAX+JPHEXT)NISUP=NIMAX+JPHEXT
+ ELSE IF(NISUP /=0)THEN
+ print *,' NISUP DEMANDE NIL NIH ', &
+ NISUP,NIL,NIH
+ IF(NISUP < NIL .OR. NISUP > NIH)THEN
+ NISUP=NIH
+ IF(NISUP > NIMAX+JPHEXT)THEN
+ NISUP=NIMAX+JPHEXT
+ ENDIF
+ print *,' NISUP MODIFIE ', NISUP
+ ENDIF
+ ENDIF
+
+ IF(NJSUP == 0)THEN
+ NJSUP=NJH
+ IF(NJSUP > NJMAX+JPHEXT)NJSUP=NJMAX+JPHEXT
+ ELSE IF(NJSUP /=0)THEN
+ print *,' NJSUP DEMANDE NJL NJH ', &
+ NJSUP,NJL,NJH
+ IF(NJSUP < NJL .OR. NJSUP > NJH)THEN
+ NJSUP=NJH
+ IF(NJSUP > NJMAX+JPHEXT)THEN
+ NJSUP=NJMAX+JPHEXT
+ ENDIF
+ print *,' NJSUP MODIFIE ', NJSUP
+ ENDIF
+ ENDIF
+
+! print *,' NIINF,NISUP,NJINF,NJSUP,NKL,NKH ', &
+! NIINF,NISUP,NJINF,NJSUP,NKL,NKH
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! CV Positionnement NIINF, NJINF, NISUP, NJSUP
+! CV Positionnement LHORIZ et LVERTI
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ELSE IF(LCV)THEN
+ LHORIZ=.FALSE.; LVERTI=.TRUE.
+ NIINF=NIL
+ NJINF=NJL
+ NISUP=NIH
+ NJSUP=NJH
+
+! print *,' NIINF,NISUP,NJINF,NJSUP,NKL,NKH ', &
+! NIINF,NISUP,NJINF,NJSUP,NKL,NKH
+ ENDIF
+
+ if(nverbia > 0)then
+ print *,' **resolv_nii.. NIINF,NISUP,NJINF,NJSUP,NIL,NIH,NJL,NJH,NKL,NKH ', &
+ NIINF,NISUP,NJINF,NJSUP,NIL,NIH,NJL,NJH,NKL,NKH
+ endif
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!
+!
+!
+RETURN
+END SUBROUTINE RESOLV_NIJINF_NIJSUP
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/resolv_times.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/resolv_times.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0452947113a74ee7ab33e552ce2d11b7a48a0ad7
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/resolv_times.f90
@@ -0,0 +1,171 @@
+! ######spl
+ SUBROUTINE RESOLV_TIMES(K)
+! ##########################
+!
+!!**** *RESOLV_TIMES* - Resolution des differentes dates du modele
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 16/01/95
+!! Updated PM
+!-------------------------------------------------------------------------------
+USE MODD_TIME
+USE MODD_TYPE_AND_LH
+USE MODD_GRID
+USE MODD_CONF
+USE MODD_TITLE
+USE MODD_TIME1
+USE MODD_ALLOC_FORDIACHRO
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy argument
+!
+INTEGER :: K
+!
+!* 0.1 local variables
+!
+
+INTEGER :: JJ
+INTEGER :: ITIM, IHOUR, IMINU, ISECD
+CHARACTER(LEN=10) :: YTIM1, YTIM2
+CHARACTER(LEN=LEN(CLEGEND)) :: YLEGEND
+!
+!-------------------------------------------------------------------------------
+!
+YLEGEND(1:LEN(YLEGEND))=' '
+TDTEXP%TDATE%YEAR=XDATIME(1,K); TDTEXP%TDATE%MONTH=XDATIME(2,K)
+TDTEXP%TDATE%DAY=XDATIME(3,K); TDTEXP%TIME=XDATIME(4,K)
+TDTSEG%TDATE%YEAR=XDATIME(5,K); TDTSEG%TDATE%MONTH=XDATIME(6,K)
+TDTSEG%TDATE%DAY=XDATIME(7,K); TDTSEG%TIME=XDATIME(8,K)
+TDTMOD%TDATE%YEAR=XDATIME(9,K); TDTMOD%TDATE%MONTH=XDATIME(10,K)
+TDTMOD%TDATE%DAY=XDATIME(11,K); TDTMOD%TIME=XDATIME(12,K)
+TDTCUR%TDATE%YEAR=XDATIME(13,K); TDTCUR%TDATE%MONTH=XDATIME(14,K)
+TDTCUR%TDATE%DAY=XDATIME(15,K); TDTCUR%TIME=XDATIME(16,K)
+
+YTIM1=' '
+YTIM2=' '
+DO JJ=1,2
+IF(JJ == 1)ITIM=TDTMOD%TIME
+IF(JJ == 2)ITIM=TDTCUR%TIME
+IHOUR=ITIM/3600
+IMINU=(ITIM-IHOUR*3600)/60
+ISECD=ITIM-(IHOUR*3600 + IMINU*60)
+ IF(JJ == 1)THEN
+ WRITE(YTIM1,'(I3,''H'',I2,''M'',I2,''S'')')IHOUR,IMINU,ISECD
+ ELSE
+ WRITE(YTIM2,'(I3,''H'',I2,''M'',I2,''S'')')IHOUR,IMINU,ISECD
+ ENDIF
+ENDDO
+
+CLEGEND2(1:LEN(CLEGEND2))=' '
+IF(CSTORAGE_TYPE /= 'PG')THEN
+WRITE(CLEGEND2,1001)TDTMOD%TDATE%YEAR,TDTMOD%TDATE%MONTH, &
+ TDTMOD%TDATE%DAY,YTIM1, &
+ TDTCUR%TDATE%YEAR,TDTCUR%TDATE%MONTH, &
+ TDTCUR%TDATE%DAY,YTIM2
+ENDIF
+
+YTIM1=' '
+YTIM2=' '
+DO JJ=1,2
+IF(JJ == 1)ITIM=TDTEXP%TIME
+IF(JJ == 2)ITIM=TDTSEG%TIME
+IHOUR=ITIM/3600
+IMINU=(ITIM-IHOUR*3600)/60
+ISECD=ITIM-(IHOUR*3600 + IMINU*60)
+ IF(JJ == 1)THEN
+ WRITE(YTIM1,'(I3,''H'',I2,''M'',I2,''S'')')IHOUR,IMINU,ISECD
+ ELSE
+ WRITE(YTIM2,'(I3,''H'',I2,''M'',I2,''S'')')IHOUR,IMINU,ISECD
+ ENDIF
+ENDDO
+
+YLEGEND=CLEGEND
+CLEGEND(1:LEN(CLEGEND))=' '
+
+SELECT CASE(CTYPE)
+
+ CASE('CART','MASK')
+
+ IF(CSTORAGE_TYPE /= 'PG')THEN
+ IF(LCARTESIAN)WRITE(CLEGEND,1000)TDTEXP%TDATE%YEAR,TDTEXP%TDATE%MONTH, &
+ TDTEXP%TDATE%DAY,YTIM1, &
+ TDTSEG%TDATE%YEAR,TDTSEG%TDATE%MONTH, &
+ TDTSEG%TDATE%DAY,YTIM2, &
+ 'CARTESIEN '
+ ENDIF
+ IF(.NOT.LCARTESIAN)THEN
+ IF(XRPK.EQ.0. .AND. CSTORAGE_TYPE /= 'PG') &
+ WRITE(CLEGEND,1000)TDTEXP%TDATE%YEAR,TDTEXP%TDATE%MONTH, &
+ TDTEXP%TDATE%DAY,YTIM1, &
+ TDTSEG%TDATE%YEAR,TDTSEG%TDATE%MONTH, &
+ TDTSEG%TDATE%DAY,YTIM2, &
+ 'MERCATOR '
+ IF(XRPK.EQ.0. .AND. CSTORAGE_TYPE == 'PG') &
+ WRITE(CLEGEND,'(2X,A29,79X)')'PROJECTION MERCATOR '
+ IF(ABS(XRPK).EQ.1. .AND. CSTORAGE_TYPE /= 'PG') &
+ WRITE(CLEGEND,1000)TDTEXP%TDATE%YEAR,TDTEXP%TDATE%MONTH, &
+ TDTEXP%TDATE%DAY,YTIM1, &
+ TDTSEG%TDATE%YEAR,TDTSEG%TDATE%MONTH, &
+ TDTSEG%TDATE%DAY,YTIM2, &
+ 'STEREOG. POLAIRE '
+ IF(ABS(XRPK).EQ.1. .AND. CSTORAGE_TYPE == 'PG') &
+ WRITE(CLEGEND,'(2X,A29,79X)')'PROJ. STEREOGRAPHIQUE POLAIRE'
+ IF(ABS(XRPK).GT.0..AND.ABS(XRPK).LT.1. .AND. CSTORAGE_TYPE /= 'PG') &
+ WRITE(CLEGEND,1000)TDTEXP%TDATE%YEAR,TDTEXP%TDATE%MONTH, &
+ TDTEXP%TDATE%DAY,YTIM1, &
+ TDTSEG%TDATE%YEAR,TDTSEG%TDATE%MONTH, &
+ TDTSEG%TDATE%DAY,YTIM2, &
+ 'LAMBERT '
+ IF(ABS(XRPK).GT.0..AND.ABS(XRPK).LT.1. .AND. CSTORAGE_TYPE == 'PG') &
+ WRITE(CLEGEND,'(2X,A29,79X)')'PROJECTION LAMBERT '
+ END IF
+
+ CASE DEFAULT
+
+ WRITE(CLEGEND,1002)TDTEXP%TDATE%YEAR,TDTEXP%TDATE%MONTH, &
+ TDTEXP%TDATE%DAY,YTIM1, &
+ TDTSEG%TDATE%YEAR,TDTSEG%TDATE%MONTH, &
+ TDTSEG%TDATE%DAY,YTIM2
+END SELECT
+CLEGEND(104:108)=YLEGEND(104:108)
+
+1000 FORMAT('DATE EXP.. ',I4,2('/',I2),1X,A10,3X, &
+ 'DATE SEG. ',I4,2('/',I2),1X,A10,3X,A26)
+1001 FORMAT('DATE MOD. ',I4,2('/',I2),1X,A10,3X, &
+ 'DATE CUR. ',I4,2('/',I2),1X,A10)
+1002 FORMAT('DATE EXP.. ',I4,2('/',I2),1X,A10,3X, &
+ 'DATE SEG. ',I4,2('/',I2),1X,A10)
+
+!
+!
+RETURN
+END SUBROUTINE RESOLV_TIMES
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/resolv_tit.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/resolv_tit.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e7d40e8adb292c0db20e8ebd4548c250f417aa4d
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/resolv_tit.f90
@@ -0,0 +1,443 @@
+! ######spl
+ MODULE MODI_RESOLV_TIT
+! ######################
+!
+INTERFACE
+!
+SUBROUTINE RESOLV_TIT(HTIT,HOUT)
+CHARACTER(LEN=*) :: HTIT, HOUT
+END SUBROUTINE RESOLV_TIT
+!
+END INTERFACE
+END MODULE MODI_RESOLV_TIT
+! ######spl
+ SUBROUTINE RESOLV_TIT(HTIT,HOUT)
+! ################################
+!
+!!**** *RESOLV_TIT* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_TIT
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HTIT, HOUT
+!
+!* 0.1 Local variables
+! ---------------
+
+
+!
+!------------------------------------------------------------------------------
+!print *,' RESOLV_TIT HTIT HOUT ',HTIT,HOUT
+IF(.NOT.LTITDEF)THEN
+ CTITALL='NODEFAULT'
+ELSE
+ CTITALL='DEFAULT'
+ENDIF
+!print *,' RESOLV_TIT CTITALL',CTITALL
+IF(CTITALL == 'DEFAULT' .OR. CTITALL == 'default' .OR. &
+ CTITALL == 'DEFAUT' .OR. CTITALL == 'defaut')THEN
+ CTITT1(1:LEN(CTITT1))=' '
+ CTITT1='DEFAULT'
+ CTITT2(1:LEN(CTITT2))=' '
+ CTITT2='DEFAULT'
+ CTITT3(1:LEN(CTITT3))=' '
+ CTITT3='DEFAULT'
+ CTITB1(1:LEN(CTITB1))=' '
+ CTITB1='DEFAULT'
+ CTITB2(1:LEN(CTITB2))=' '
+ CTITB2='DEFAULT'
+ CTITB3(1:LEN(CTITB3))=' '
+ CTITB3='DEFAULT'
+ CTITYT(1:LEN(CTITYT))=' '
+ CTITYT='DEFAULT'
+ CTITYM(1:LEN(CTITYM))=' '
+ CTITYM='DEFAULT'
+ CTITYB(1:LEN(CTITYB))=' '
+ CTITYB='DEFAULT'
+ CTITXL(1:LEN(CTITXL))=' '
+ CTITXL='DEFAULT'
+ CTITXM(1:LEN(CTITXM))=' '
+ CTITXM='DEFAULT'
+ CTITXR(1:LEN(CTITXR))=' '
+ CTITXR='DEFAULT'
+ CTITVAR1(1:LEN(CTITVAR1))=' '
+ CTITVAR1='DEFAULT'
+ CTITVAR2(1:LEN(CTITVAR2))=' '
+ CTITVAR2='DEFAULT'
+ CTITVAR3(1:LEN(CTITVAR3))=' '
+ CTITVAR3='DEFAULT'
+ CTITVAR4(1:LEN(CTITVAR4))=' '
+ CTITVAR4='DEFAULT'
+ CTITVAR5(1:LEN(CTITVAR5))=' '
+ CTITVAR5='DEFAULT'
+ CTITVAR6(1:LEN(CTITVAR6))=' '
+ CTITVAR6='DEFAULT'
+ CTITVAR7(1:LEN(CTITVAR7))=' '
+ CTITVAR7='DEFAULT'
+ CTITVAR8(1:LEN(CTITVAR8))=' '
+ CTITVAR8='DEFAULT'
+ELSE
+! print *,' HTIT '
+ IF(.NOT.LTITDEF)THEN
+ SELECT CASE(HTIT)
+ CASE('CTITT1')
+ IF(CTITT1 == 'WHITE' .OR. CTITT1 == 'white' .OR. &
+ CTITT1 == 'BLANC' .OR. CTITT1 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITT1 == 'CCOMMENT' .OR. CTITT1 == 'ccomment' .OR. &
+ CTITT1 == 'COMMENT' .OR. CTITT1 == 'comment')THEN
+ CTITT1=ADJUSTL(ADJUSTR(CCOMMENT(NLOOPP)))
+ HOUT=CTITT1
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITT1 == 'DEFAULT' .OR. CTITT1 == 'default' .OR. &
+ CTITT1 == 'DEFAUT' .OR. CTITT1 == 'defaut')THEN
+ ELSE
+ HOUT=CTITT1
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITT2')
+ IF(CTITT2 == 'WHITE' .OR. CTITT2 == 'white' .OR. &
+ CTITT2 == 'BLANC' .OR. CTITT2 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITT2 == 'CCOMMENT' .OR. CTITT2 == 'ccomment' .OR. &
+ CTITT2 == 'COMMENT' .OR. CTITT2 == 'comment')THEN
+ CTITT2=ADJUSTL(ADJUSTR(CCOMMENT(NLOOPP)))
+ HOUT=CTITT2
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITT2 == 'DEFAULT' .OR. CTITT2 == 'default' .OR. &
+ CTITT2 == 'DEFAUT' .OR. CTITT2 == 'defaut')THEN
+ ELSE
+ HOUT=CTITT2
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITT3')
+ IF(CTITT3 == 'WHITE' .OR. CTITT3 == 'white' .OR. &
+ CTITT3 == 'BLANC' .OR. CTITT3 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITT3 == 'CCOMMENT' .OR. CTITT3 == 'ccomment' .OR. &
+ CTITT3 == 'COMMENT' .OR. CTITT3 == 'comment')THEN
+ CTITT3=ADJUSTL(ADJUSTR(CCOMMENT(NLOOPP)))
+ HOUT=CTITT3
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITT3 == 'DEFAULT' .OR. CTITT3 == 'default' .OR. &
+ CTITT3 == 'DEFAUT' .OR. CTITT3 == 'defaut')THEN
+ ELSE
+ HOUT=CTITT3
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITB1')
+ IF(CTITB1 == 'WHITE' .OR. CTITB1 == 'white' .OR. &
+ CTITB1 == 'BLANC' .OR. CTITB1 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITB1 == 'CCOMMENT' .OR. CTITB1 == 'ccomment' .OR. &
+ CTITB1 == 'COMMENT' .OR. CTITB1 == 'comment')THEN
+ CTITB1=ADJUSTL(ADJUSTR(CCOMMENT(NLOOPP)))
+ HOUT=CTITB1
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITB1 == 'DEFAULT' .OR. CTITB1 == 'default' .OR. &
+ CTITB1 == 'DEFAUT' .OR. CTITB1 == 'defaut')THEN
+ ELSE
+ HOUT=CTITB1
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+! print *,' HOUT ',HOUT
+ RETURN
+ CASE('CTITB2')
+ IF(CTITB2 == 'WHITE' .OR. CTITB2 == 'white' .OR. &
+ CTITB2 == 'BLANC' .OR. CTITB2 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITB2 == 'CCOMMENT' .OR. CTITB2 == 'ccomment' .OR. &
+ CTITB2 == 'COMMENT' .OR. CTITB2 == 'comment')THEN
+ CTITB2=ADJUSTL(ADJUSTR(CCOMMENT(NLOOPP)))
+ HOUT=CTITB2
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITB2 == 'DEFAULT' .OR. CTITB2 == 'default' .OR. &
+ CTITB2 == 'DEFAUT' .OR. CTITB2 == 'defaut')THEN
+ ELSE
+ HOUT=CTITB2
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+! print *,' HOUT ',HOUT
+ RETURN
+ CASE('CTITB3')
+ IF(CTITB3 == 'WHITE' .OR. CTITB3 == 'white' .OR. &
+ CTITB3 == 'BLANC' .OR. CTITB3 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITB3 == 'CCOMMENT' .OR. CTITB3 == 'ccomment' .OR. &
+ CTITB3 == 'COMMENT' .OR. CTITB3 == 'comment')THEN
+ CTITB3=ADJUSTL(ADJUSTR(CCOMMENT(NLOOPP)))
+ HOUT=CTITB3
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITB3 == 'DEFAULT' .OR. CTITB3 == 'default' .OR. &
+ CTITB3 == 'DEFAUT' .OR. CTITB3 == 'defaut')THEN
+ ELSE
+ HOUT=CTITB3
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+! print *,' HOUT ',HOUT
+ RETURN
+ CASE('CTITYT')
+ IF(CTITYT == 'WHITE' .OR. CTITYT == 'white' .OR. &
+ CTITYT == 'BLANC' .OR. CTITYT == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITYT == 'DEFAULT' .OR. CTITYT == 'default' .OR. &
+ CTITYT == 'DEFAUT' .OR. CTITYT == 'defaut')THEN
+ ELSE
+ HOUT=CTITYT
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITYM')
+ IF(CTITYM == 'WHITE' .OR. CTITYM == 'white' .OR. &
+ CTITYM == 'BLANC' .OR. CTITYM == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITYM == 'DEFAULT' .OR. CTITYM == 'default' .OR. &
+ CTITYM == 'DEFAUT' .OR. CTITYM == 'defaut')THEN
+ ELSE
+ HOUT=CTITYM
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITYB')
+ IF(CTITYB == 'WHITE' .OR. CTITYB == 'white' .OR. &
+ CTITYB == 'BLANC' .OR. CTITYB == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITYB == 'DEFAULT' .OR. CTITYB == 'default' .OR. &
+ CTITYB == 'DEFAUT' .OR. CTITYB == 'defaut')THEN
+ ELSE
+ HOUT=CTITYB
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITXL')
+ IF(CTITXL == 'WHITE' .OR. CTITXL == 'white' .OR. &
+ CTITXL == 'BLANC' .OR. CTITXL == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITXL == 'DEFAULT' .OR. CTITXL == 'default' .OR. &
+ CTITXL == 'DEFAUT' .OR. CTITXL == 'defaut')THEN
+ ELSE
+ HOUT=CTITXL
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITXM')
+ IF(CTITXM == 'WHITE' .OR. CTITXM == 'white' .OR. &
+ CTITXM == 'BLANC' .OR. CTITXM == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITXM == 'DEFAULT' .OR. CTITXM == 'default' .OR. &
+ CTITXM == 'DEFAUT' .OR. CTITXM == 'defaut')THEN
+ ELSE
+ HOUT=CTITXM
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITXR')
+ IF(CTITXR == 'WHITE' .OR. CTITXR == 'white' .OR. &
+ CTITXR == 'BLANC' .OR. CTITXR == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITXR == 'DEFAULT' .OR. CTITXR == 'default' .OR. &
+ CTITXR == 'DEFAUT' .OR. CTITXR == 'defaut')THEN
+ ELSE
+ HOUT=CTITXR
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITVAR1')
+ IF(CTITVAR1 == 'WHITE' .OR. CTITVAR1 == 'white' .OR. &
+ CTITVAR1 == 'BLANC' .OR. CTITVAR1 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITVAR1 == 'DEFAULT' .OR. CTITVAR1 == 'default' .OR. &
+ CTITVAR1 == 'DEFAUT' .OR. CTITVAR1 == 'defaut')THEN
+ ELSE
+ HOUT=CTITVAR1
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITVAR2')
+ IF(CTITVAR2 == 'WHITE' .OR. CTITVAR2 == 'white' .OR. &
+ CTITVAR2 == 'BLANC' .OR. CTITVAR2 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITVAR2 == 'DEFAULT' .OR. CTITVAR2 == 'default' .OR. &
+ CTITVAR2 == 'DEFAUT' .OR. CTITVAR2 == 'defaut')THEN
+ ELSE
+ HOUT=CTITVAR2
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITVAR3')
+ IF(CTITVAR3 == 'WHITE' .OR. CTITVAR3 == 'white' .OR. &
+ CTITVAR3 == 'BLANC' .OR. CTITVAR3 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITVAR3 == 'DEFAULT' .OR. CTITVAR3 == 'default' .OR. &
+ CTITVAR3 == 'DEFAUT' .OR. CTITVAR3 == 'defaut')THEN
+ ELSE
+ HOUT=CTITVAR3
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITVAR4')
+ IF(CTITVAR4 == 'WHITE' .OR. CTITVAR4 == 'white' .OR. &
+ CTITVAR4 == 'BLANC' .OR. CTITVAR4 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITVAR4 == 'DEFAULT' .OR. CTITVAR4 == 'default' .OR. &
+ CTITVAR4 == 'DEFAUT' .OR. CTITVAR4 == 'defaut')THEN
+ ELSE
+ HOUT=CTITVAR4
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITVAR5')
+ IF(CTITVAR5 == 'WHITE' .OR. CTITVAR5 == 'white' .OR. &
+ CTITVAR5 == 'BLANC' .OR. CTITVAR5 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITVAR5 == 'DEFAULT' .OR. CTITVAR5 == 'default' .OR. &
+ CTITVAR5 == 'DEFAUT' .OR. CTITVAR5 == 'defaut')THEN
+ ELSE
+ HOUT=CTITVAR5
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITVAR6')
+ IF(CTITVAR6 == 'WHITE' .OR. CTITVAR6 == 'white' .OR. &
+ CTITVAR6 == 'BLANC' .OR. CTITVAR6 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITVAR6 == 'DEFAULT' .OR. CTITVAR6 == 'default' .OR. &
+ CTITVAR6 == 'DEFAUT' .OR. CTITVAR6 == 'defaut')THEN
+ ELSE
+ HOUT=CTITVAR6
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITVAR7')
+ IF(CTITVAR7 == 'WHITE' .OR. CTITVAR7 == 'white' .OR. &
+ CTITVAR7 == 'BLANC' .OR. CTITVAR7 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITVAR7 == 'DEFAULT' .OR. CTITVAR7 == 'default' .OR. &
+ CTITVAR7 == 'DEFAUT' .OR. CTITVAR7 == 'defaut')THEN
+ ELSE
+ HOUT=CTITVAR7
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ CASE('CTITVAR8')
+ IF(CTITVAR8 == 'WHITE' .OR. CTITVAR8 == 'white' .OR. &
+ CTITVAR8 == 'BLANC' .OR. CTITVAR8 == 'blanc')THEN
+ HOUT(1:LEN(HOUT))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITVAR8 == 'DEFAULT' .OR. CTITVAR8 == 'default' .OR. &
+ CTITVAR8 == 'DEFAUT' .OR. CTITVAR8 == 'defaut')THEN
+ ELSE
+ HOUT=CTITVAR8
+ CTITALL='NODEFAULT'
+ ENDIF
+!fuji HOUT=ADJUSTL(HOUT)
+ HOUT=TRIM(HOUT)
+ RETURN
+ END SELECT
+ENDIF
+ENDIF
+RETURN
+END SUBROUTINE RESOLV_TIT
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/resolv_tity.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/resolv_tity.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2ea0e6161ff178c7f2c69ae7fee37c1ba204c86e
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/resolv_tity.f90
@@ -0,0 +1,237 @@
+! ######spl
+ MODULE MODI_RESOLV_TITY
+! ######################
+!
+INTERFACE
+!
+SUBROUTINE RESOLV_TITY(HTIT,PVL,PVR,PVB,PVT,HOUT)
+REAL :: PVL, PVR, PVB, PVT
+CHARACTER(LEN=*) :: HTIT, HOUT
+END SUBROUTINE RESOLV_TITY
+!
+END INTERFACE
+END MODULE MODI_RESOLV_TITY
+! ######spl
+ SUBROUTINE RESOLV_TITY(HTIT,PVL,PVR,PVB,PVT,HOUT)
+! #################################################
+!
+!!**** *RESOLV_TITY* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODD_TIT
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+REAL :: PVL, PVR, PVB, PVT
+CHARACTER(LEN=*) :: HTIT, HOUT
+!
+!* 0.1 Local variables
+! ---------------
+
+CHARACTER(LEN=LEN(HOUT)) :: YTEM
+INTEGER :: ILEN, INBV, J, IM
+INTEGER,DIMENSION(10) :: IJM
+REAL :: ZSIZC, ZM
+REAL :: ZXPOSTITYT, ZXYPOSTITYT
+REAL :: ZXPOSTITYM, ZXYPOSTITYM
+REAL :: ZXPOSTITYB, ZXYPOSTITYB
+
+!
+!------------------------------------------------------------------------------
+YTEM=HOUT
+IF(.NOT.LTITDEF)THEN
+SELECT CASE(HTIT)
+ CASE('CTITYT')
+ IF(CTITYT == 'WHITE' .OR. CTITYT == 'white' .OR. &
+ CTITYT == 'BLANC' .OR. CTITYT == 'blanc')THEN
+ YTEM(1:LEN(YTEM))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITYT == 'DEFAULT' .OR. CTITYT == 'default' .OR. &
+ CTITYT == 'DEFAUT' .OR. CTITYT == 'defaut')THEN
+ ELSE
+ YTEM=CTITYT
+ CTITALL='NODEFAULT'
+ ENDIF
+ CASE('CTITYM')
+ IF(CTITYM == 'WHITE' .OR. CTITYM == 'white' .OR. &
+ CTITYM == 'BLANC' .OR. CTITYM == 'blanc')THEN
+ YTEM(1:LEN(YTEM))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITYM == 'DEFAULT' .OR. CTITYM == 'default' .OR. &
+ CTITYM == 'DEFAUT' .OR. CTITYM == 'defaut')THEN
+ ELSE
+ YTEM=CTITYM
+ CTITALL='NODEFAULT'
+ ENDIF
+ CASE('CTITYB')
+ IF(CTITYB == 'WHITE' .OR. CTITYB == 'white' .OR. &
+ CTITYB == 'BLANC' .OR. CTITYB == 'blanc')THEN
+ YTEM(1:LEN(YTEM))=' '
+ CTITALL='NODEFAULT'
+ ELSE IF(CTITYB == 'DEFAULT' .OR. CTITYB == 'default' .OR. &
+ CTITYB == 'DEFAUT' .OR. CTITYB == 'defaut')THEN
+ ELSE
+ YTEM=CTITYB
+ CTITALL='NODEFAULT'
+ ENDIF
+END SELECT
+ENDIF
+YTEM=ADJUSTL(YTEM)
+ILEN=LEN_TRIM(YTEM)
+IJM=0
+INBV=1; IJM(INBV)=0
+DO J =1,ILEN
+ IF(YTEM(J:J) == ';')THEN
+ INBV=INBV+1
+ IJM(INBV)=J
+ ENDIF
+ENDDO
+INBV=INBV+1
+IJM(INBV)=ILEN+1
+ZSIZC=(.9-.1)/50.
+!ZSIZC=(PVT-PVB)/50.
+print*,PVL,PVT,PVR,PVB
+DO J=2,INBV
+SELECT CASE(HTIT)
+ CASE('CTITYT')
+ IF (L90TITYT) THEN
+ ZXPOSTITYT=MAX(PVL-0.03,0.)
+ ZXYPOSTITYT=PVT-J*ZSIZC
+ IF(XPOSTITYT /= 0.)THEN
+ ZXPOSTITYT=XPOSTITYT
+ ENDIF
+ IF(XYPOSTITYT /= 0.)THEN
+ ZXYPOSTITYT=XYPOSTITYT
+ ENDIF
+ IF(XSZTITYT /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITYT,ZXYPOSTITYT,YTEM(IJM(J-1)+1:IJM(J)-1),XSZTITYT,90.,0.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITYT,ZXYPOSTITYT,YTEM(IJM(J-1)+1:IJM(J)-1),ZSIZC/2.,90.,0.)
+ ENDIF
+ ELSE
+ ZXPOSTITYT=MAX(PVL-.12,0.)
+ ZXYPOSTITYT=PVT-J*ZSIZC
+ IF(XPOSTITYT /= 0.)THEN
+ ZXPOSTITYT=XPOSTITYT
+ ENDIF
+ IF(XYPOSTITYT /= 0.)THEN
+ ZXYPOSTITYT=XYPOSTITYT
+ ENDIF
+
+ IF(XSZTITYT /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITYT,ZXYPOSTITYT,YTEM(IJM(J-1)+1:IJM(J)-1),XSZTITYT,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITYT,ZXYPOSTITYT,YTEM(IJM(J-1)+1:IJM(J)-1),ZSIZC/2.,0.,-1.)
+ ENDIF
+ ENDIF
+ CASE('CTITYM')
+ ZM=(PVB+PVT)/2.
+ IM=(INBV-1)/2
+ IF(IM /= 0)THEN
+ IM=INBV-1-IM-J
+ ENDIF
+
+ IF (L90TITYM) THEN
+ ZXPOSTITYM=MAX(PVL-0.03,0.)
+ ZXYPOSTITYM=ZM+IM*ZSIZC
+ IF(XPOSTITYM /= 0.)THEN
+ ZXPOSTITYM=XPOSTITYM
+ ENDIF
+ IF(XYPOSTITYM /= 0.)THEN
+ ZXYPOSTITYM=XYPOSTITYM
+ ENDIF
+
+ IF(XSZTITYM /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITYM,ZXYPOSTITYM,YTEM(IJM(J-1)+1:IJM(J)-1),XSZTITYM,90.,0.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITYM,ZXYPOSTITYM,YTEM(IJM(J-1)+1:IJM(J)-1),ZSIZC/2.,90.,0.)
+ ENDIF
+ ELSE
+ ZXPOSTITYM=MAX(PVL-.12,0.)
+ ZXYPOSTITYM=ZM+IM*ZSIZC
+ IF(XPOSTITYM /= 0.)THEN
+ ZXPOSTITYM=XPOSTITYM
+ ENDIF
+ IF(XYPOSTITYM /= 0.)THEN
+ ZXYPOSTITYM=XYPOSTITYM
+ ENDIF
+ IF(XSZTITYM /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITYM,ZXYPOSTITYM,YTEM(IJM(J-1)+1:IJM(J)-1),XSZTITYM,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITYM,ZXYPOSTITYM,YTEM(IJM(J-1)+1:IJM(J)-1),ZSIZC/2.,0.,-1.)
+ ENDIF
+ ENDIF
+ CASE('CTITYB')
+ IF (L90TITYB) THEN
+ ZXPOSTITYB=MAX(PVL-0.03,0.)
+ ZXYPOSTITYB=PVB+(INBV-J)*ZSIZC
+ IF(XPOSTITYB /= 0.)THEN
+ ZXPOSTITYB=XPOSTITYB
+ ENDIF
+ IF(XYPOSTITYB /= 0.)THEN
+ ZXYPOSTITYB=XYPOSTITYB
+ ENDIF
+ IF(XSZTITYB /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITYB,ZXYPOSTITYB,YTEM(IJM(J-1)+1:IJM(J)-1),XSZTITYB,90.,0.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITYB,ZXYPOSTITYB,YTEM(IJM(J-1)+1:IJM(J)-1),ZSIZC/2.,90.,0.)
+ ENDIF
+ ELSE
+ ZXPOSTITYB=MAX(PVL-.12,0.)
+ ZXYPOSTITYB=PVB+(INBV-J)*ZSIZC
+ IF(XPOSTITYB /= 0.)THEN
+ ZXPOSTITYB=XPOSTITYB
+ ENDIF
+ IF(XYPOSTITYB /= 0.)THEN
+ ZXYPOSTITYB=XYPOSTITYB
+ ENDIF
+ IF(XSZTITYB /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITYB,ZXYPOSTITYB,YTEM(IJM(J-1)+1:IJM(J)-1),XSZTITYB,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITYB,ZXYPOSTITYB,YTEM(IJM(J-1)+1:IJM(J)-1),ZSIZC/2.,0.,-1.)
+ ENDIF
+ ENDIF
+END SELECT
+ENDDO
+RETURN
+END SUBROUTINE RESOLV_TITY
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/resolvtot.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/resolvtot.f90
new file mode 100644
index 0000000000000000000000000000000000000000..24f74788099d59c42aaecb0d5cea7d5aceab5bb0
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/resolvtot.f90
@@ -0,0 +1,2665 @@
+! ######spl
+ MODULE MODI_RESOLVI
+! ###################
+!
+INTERFACE
+!
+SUBROUTINE RESOLVI(HCARIN,KI,KOUT)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KI, KOUT
+END SUBROUTINE RESOLVI
+!
+END INTERFACE
+END MODULE MODI_RESOLVI
+! ##################################
+ SUBROUTINE RESOLVI(HCARIN,KI,KOUT)
+! ##################################
+!
+!!**** *RESOLVI* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KI, KOUT
+!
+!* 0.1 Local variables
+! ---------------
+
+CHARACTER(LEN=8) :: YC8
+INTEGER :: ILENC
+INTEGER :: J,JM, I
+
+!
+!------------------------------------------------------------------------------
+ILENC=LEN_TRIM(HCARIN)
+
+DO J=KI,ILENC
+ IF(HCARIN(J:J) == '=')EXIT
+ENDDO
+
+JM=J+1
+YC8=' '
+I=0
+
+DO J=JM,ILENC
+ IF(HCARIN(J:J) == '0'.OR.HCARIN(J:J) == '1'.OR.HCARIN(J:J) == '2' &
+ .OR.HCARIN(J:J) == '3'.OR.HCARIN(J:J) == '4'.OR.HCARIN(J:J) == '5' &
+ .OR.HCARIN(J:J) == '6'.OR.HCARIN(J:J) == '7'.OR.HCARIN(J:J) == '8' &
+ .OR.HCARIN(J:J) == '9')THEN
+ YC8(1:1)=HCARIN(J:J)
+ I=1
+ IF(J+I > ILENC)EXIT
+ IF(HCARIN(J+1:J+1) /= '0' .AND. HCARIN(J+1:J+1) /= '1' .AND. &
+ HCARIN(J+1:J+1) /= '2' .AND. HCARIN(J+1:J+1) /= '3' .AND. &
+ HCARIN(J+1:J+1) /= '4' .AND. HCARIN(J+1:J+1) /= '5' .AND. &
+ HCARIN(J+1:J+1) /= '6' .AND. HCARIN(J+1:J+1) /= '7' .AND. &
+ HCARIN(J+1:J+1) /= '8' .AND. HCARIN(J+1:J+1) /= '9')THEN
+ EXIT
+ ELSE
+ YC8(2:2)=HCARIN(J+1:J+1)
+ I=2
+ IF(J+I > ILENC)EXIT
+ IF(HCARIN(J+2:J+2) /= '0' .AND. HCARIN(J+2:J+2) /= '1' .AND. &
+ HCARIN(J+2:J+2) /= '2' .AND. HCARIN(J+2:J+2) /= '3' .AND. &
+ HCARIN(J+2:J+2) /= '4' .AND. HCARIN(J+2:J+2) /= '5' .AND. &
+ HCARIN(J+2:J+2) /= '6' .AND. HCARIN(J+2:J+2) /= '7' .AND. &
+ HCARIN(J+2:J+2) /= '8' .AND. HCARIN(J+2:J+2) /= '9')THEN
+ EXIT
+ ELSE
+ YC8(3:3)=HCARIN(J+2:J+2)
+ I=3
+ IF(J+I > ILENC)EXIT
+ IF(HCARIN(J+3:J+3) /= '0' .AND. HCARIN(J+3:J+3) /= '1' .AND. &
+ HCARIN(J+3:J+3) /= '2' .AND. HCARIN(J+3:J+3) /= '3' .AND. &
+ HCARIN(J+3:J+3) /= '4' .AND. HCARIN(J+3:J+3) /= '5' .AND. &
+ HCARIN(J+3:J+3) /= '6' .AND. HCARIN(J+3:J+3) /= '7' .AND. &
+ HCARIN(J+3:J+3) /= '8' .AND. HCARIN(J+3:J+3) /= '9')THEN
+ EXIT
+ ELSE
+ YC8(4:4)=HCARIN(J+3:J+3)
+ I=4
+ IF(J+I > ILENC)EXIT
+ IF(HCARIN(J+4:J+4) /= '0' .AND. HCARIN(J+4:J+4) /= '1' .AND. &
+ HCARIN(J+4:J+4) /= '2' .AND. HCARIN(J+4:J+4) /= '3' .AND. &
+ HCARIN(J+4:J+4) /= '4' .AND. HCARIN(J+4:J+4) /= '5' .AND. &
+ HCARIN(J+4:J+4) /= '6' .AND. HCARIN(J+4:J+4) /= '7' .AND. &
+ HCARIN(J+4:J+4) /= '8' .AND. HCARIN(J+4:J+4) /= '9')THEN
+ EXIT
+ ELSE
+ YC8(5:5)=HCARIN(J+4:J+4)
+ I=5
+ IF(J+I > ILENC)EXIT
+ IF(HCARIN(J+5:J+5) /= '0' .AND. HCARIN(J+5:J+5) /= '1' .AND. &
+ HCARIN(J+5:J+5) /= '2' .AND. HCARIN(J+5:J+5) /= '3' .AND. &
+ HCARIN(J+5:J+5) /= '4' .AND. HCARIN(J+5:J+5) /= '5' .AND. &
+ HCARIN(J+5:J+5) /= '6' .AND. HCARIN(J+5:J+5) /= '7' .AND. &
+ HCARIN(J+5:J+5) /= '8' .AND. HCARIN(J+5:J+5) /= '9')THEN
+ EXIT
+ ELSE
+ YC8(6:6)=HCARIN(J+5:J+5)
+ I=6
+ IF(J+I > ILENC)EXIT
+ IF(HCARIN(J+6:J+6) /= '0' .AND. HCARIN(J+6:J+6) /= '1' .AND. &
+ HCARIN(J+6:J+6) /= '2' .AND. HCARIN(J+6:J+6) /= '3' .AND. &
+ HCARIN(J+6:J+6) /= '4' .AND. HCARIN(J+6:J+6) /= '5' .AND. &
+ HCARIN(J+6:J+6) /= '6' .AND. HCARIN(J+6:J+6) /= '7' .AND. &
+ HCARIN(J+6:J+6) /= '8' .AND. HCARIN(J+6:J+6) /= '9')THEN
+ EXIT
+ ELSE
+ YC8(7:7)=HCARIN(J+6:J+6)
+ I=7
+ IF(J+I > ILENC)EXIT
+ IF(HCARIN(J+7:J+7) /= '0' .AND. HCARIN(J+7:J+7) /= '1' .AND. &
+ HCARIN(J+7:J+7) /= '2' .AND. HCARIN(J+7:J+7) /= '3' .AND. &
+ HCARIN(J+7:J+7) /= '4' .AND. HCARIN(J+7:J+7) /= '5' .AND. &
+ HCARIN(J+7:J+7) /= '6' .AND. HCARIN(J+7:J+7) /= '7' .AND. &
+ HCARIN(J+7:J+7) /= '8' .AND. HCARIN(J+7:J+7) /= '9')THEN
+ EXIT
+ ELSE
+ YC8(8:8)=HCARIN(J+7:J+7)
+ I=8
+ IF(J+I > ILENC)EXIT
+ IF(HCARIN(J+8:J+8) /= '0' .AND. HCARIN(J+8:J+8) /= '1' .AND. &
+ HCARIN(J+8:J+8) /= '2' .AND. HCARIN(J+8:J+8) /= '3' .AND. &
+ HCARIN(J+8:J+8) /= '4' .AND. HCARIN(J+8:J+8) /= '5' .AND. &
+ HCARIN(J+8:J+8) /= '6' .AND. HCARIN(J+8:J+8) /= '8' .AND. &
+ HCARIN(J+8:J+8) /= '8' .AND. HCARIN(J+8:J+8) /= '9')THEN
+ EXIT
+ ELSE
+ print *,' PB AVEC LA VALEUR FOURNIE ', &
+ HCARIN(J-1:J+9),' VERIFIEZ LA ET RENTREZ LA A NOUVEAU ', &
+ '(8 chiffres MAXIMUM)'
+ KOUT=999999999
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ENDDO
+
+IF(I == 0)THEN
+print *,' ABSENCE DE VALEUR. VERIFIEZ ET RENTREZ LA A NOUVEAU '
+KOUT=999999999
+RETURN
+ENDIF
+READ(YC8(1:I),*)KOUT
+IF(HCARIN(J-1:J-1) == '-')KOUT=KOUT*(-1)
+
+RETURN
+END SUBROUTINE RESOLVI
+! ######spl
+ MODULE MODI_RESOLVIARRAY
+! ########################
+!
+INTERFACE
+!
+SUBROUTINE RESOLVIARRAY(HCARIN,KIND,KOUT,KIARRAY)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND, KIARRAY
+INTEGER,DIMENSION(:) :: KOUT
+END SUBROUTINE RESOLVIARRAY
+!
+END INTERFACE
+END MODULE MODI_RESOLVIARRAY
+! #################################################
+ SUBROUTINE RESOLVIARRAY(HCARIN,KIND,KOUT,KIARRAY)
+! #################################################
+!
+!!**** *RESOLVIARRAY* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODN_PARA
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND, KIARRAY
+INTEGER,DIMENSION(:) :: KOUT
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: ILENC
+INTEGER :: J,JM, JMF
+INTEGER :: INBV, IND9999
+
+!
+!------------------------------------------------------------------------------
+ILENC=LEN_TRIM(HCARIN)
+KOUT=9999
+
+DO J=KIND,ILENC
+ IF(HCARIN(J:J) == '=')EXIT
+ENDDO
+
+JM=J+1
+DO J=1,10
+ IF(HCARIN(JM:JM) == ' ')THEN
+ JM=JM+1
+ ELSE
+ EXIT
+ ENDIF
+ENDDO
+
+IND9999=INDEX(HCARIN(JM:ILENC),'9999.')
+IF(IND9999 == 0)THEN
+ IND9999=INDEX(HCARIN(JM:ILENC),'9999')
+ENDIF
+IF(IND9999 == 0)THEN
+ JMF=ILENC
+ELSE
+ JMF=IND9999+JM-1+3
+ENDIF
+INBV=0
+DO J=JM,JMF
+ IF(HCARIN(J:J) == ',')THEN
+ INBV=INBV+1
+ ENDIF
+ENDDO
+
+IF(IND9999 == 0)THEN
+ INBV=INBV+1
+ENDIF
+READ(HCARIN(JM:JMF),*)(KOUT(J),J=1,INBV)
+KIARRAY=INBV
+IF(NVERBIA >= 5)THEN
+ print *,' RESOLVIARRAY ',INBV,(KOUT(J),J=1,INBV)
+ENDIF
+RETURN
+END SUBROUTINE RESOLVIARRAY
+! ######spl
+ MODULE MODI_RESOLVK
+! ###################
+!
+INTERFACE
+!
+SUBROUTINE RESOLVK(HCARIN,KINDK,KJ)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KINDK, KJ
+END SUBROUTINE RESOLVK
+!
+END INTERFACE
+!
+END MODULE MODI_RESOLVK
+! ###################################
+ SUBROUTINE RESOLVK(HCARIN,KINDK,KJ)
+! ###################################
+!
+!!**** *RESOLVK* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KINDK, KJ
+!
+!* 0.1 Local variables
+! ---------------
+
+CHARACTER(LEN=80) :: YCART
+CHARACTER(LEN=20) :: YCAR
+INTEGER :: ILENC, ILENCART
+INTEGER :: INDKF, INDTO, INDBY, INDV, INDVM
+INTEGER :: ICAS, J
+
+!
+!------------------------------------------------------------------------------
+INDKF = 0
+INDTO = 0
+INDBY = 0
+INDV = 0
+ICAS = 0
+
+NBLVLKDIA(KJ,:)=0
+NLVLKDIA(:,KJ,:)=0
+LVLKDIALL(KJ,:)=.FALSE.
+
+IF(KINDK == 0)THEN
+ LVLKDIALL(KJ,:) = .TRUE.
+ RETURN
+END IF
+
+ILENC = LEN(HCARIN)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ INDTO = INDEX(HCARIN(KINDK+3:ILENC),'_TO_')
+ INDBY = INDEX(HCARIN(KINDK+3:ILENC),'_BY_')
+ INDKF = INDEX(HCARIN(KINDK+3:ILENC),'_')
+ IF(INDTO /= 0)THEN
+ IF(INDKF < INDTO)THEN
+!
+! ICAS = 1 Niveau K unique ou plusieurs separes par des virgules
+!
+ INDTO=0;INDBY=0
+ ICAS = 1
+ ELSE IF(INDKF == INDTO)THEN
+!
+! ICAS = 3 Niv1 _TO_ Nivn _BY_ Nivx
+!
+ IF(INDBY /= 0)THEN
+ DO J=INDTO+4+KINDK+3,INDBY+KINDK+3
+ IF(HCARIN(J:J) == '_')THEN
+ IF(HCARIN(J:J+3) == '_BY_')THEN
+ EXIT
+ ELSE
+ INDBY=0
+ EXIT
+ END IF
+ END IF
+ ENDDO
+ END IF
+ IF(INDBY /= 0)THEN
+ INDKF=INDEX(HCARIN(KINDK+3+INDBY+4:ILENC),'_')
+ IF(INDKF /= 0)INDKF=INDKF+INDBY+4
+ ICAS = 3
+ LKINCRDIA(KJ,:) = .TRUE.
+ ELSE
+!
+! ICAS = 2 Niv1 _TO_ Nivn
+!
+ INDKF=INDEX(HCARIN(KINDK+3+INDTO+4:ILENC),'_')
+ IF(INDKF /= 0)INDKF=INDKF+INDTO+4
+ ICAS = 2
+ LKINCRDIA(KJ,:) = .TRUE.
+ END IF
+ END IF
+ ELSE
+ ICAS = 1
+ END IF
+IF(INDKF == 0)THEN
+ INDKF = ILENC
+ELSE
+ INDKF = INDKF+KINDK+3-1-1
+END IF
+
+
+YCART(1:LEN(YCART))=' '
+YCAR(1:LEN(YCAR))=' '
+!
+! Extraction de la partie Niveaux K dans YCART(1:ILENCART)
+!
+!print *,' KINDK INDKF ',KINDK,INDKF
+YCART = ADJUSTL(HCARIN(KINDK+3:INDKF))
+ILENCART = LEN_TRIM(YCART)
+!print *,' YCART ',ILENCART,' ',YCART
+
+! Recherche a nouveau des chaines de car. _TO_ , _BY_ et d'une virgule
+! par rapport au debut de YCART
+
+INDTO = INDEX(YCART,'_TO_')
+INDBY = INDEX(YCART,'_BY_')
+INDV = INDEX(YCART(1:ILENCART),',')
+IF(ICAS == 1 .AND. INDV == 0)ICAS=0
+!
+! Expression des Niveaux K par mots-cles (LVLKALL ou LVLK1....)
+!
+IF(YCART(1:7) == 'LVLKALL')THEN
+ LVLKDIALL(KJ,:) = .TRUE.
+ if(nverbia >0)then
+ print *,' RESOLVK LVLKALL '
+ print *,' LVLKDIALL ',LVLKDIALL(KJ,1)
+ print *,' NBLVLKDIA ',NBLVLKDIA(KJ,1)
+ print *,' NLVLKDIA ',(NLVLKDIA(J,KJ,1),J=1,NBLVLKDIA(KJ,1))
+ endif
+ RETURN
+
+ELSE IF(YCART(1:4) == 'LVLK')THEN
+!print *,' YCART(1:4) ',YCART(1:4),' ICAS ',ICAS
+
+ NBLVLKDIA(KJ,:)=NBLVLKDIA(KJ,:)+1
+ SELECT CASE(ICAS)
+ CASE(1)
+!print *,' INDV YCART(5:5) ',INDV,YCART(5:5)
+ IF(INDV-4-1 == 1)READ(YCART(5:5),'(I1)')NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ IF(INDV-4-1 == 2)READ(YCART(5:6),'(I2)')NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ DO J = 1,100
+ INDVM=INDV
+ INDV=0
+ INDV=INDEX(YCART(INDVM+1:ILENCART),',')
+ IF(INDV == 0)THEN
+ NBLVLKDIA(KJ,:)=NBLVLKDIA(KJ,:)+1
+ IF(ILENCART-(INDVM+4) == 1)READ(YCART(INDVM+4+1:INDVM+4+1),'(I1)')NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ IF(ILENCART-(INDVM+4) == 2)READ(YCART(INDVM+4+1:ILENCART),'(I2)')NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ EXIT
+ ELSE
+ INDV=INDV+INDVM
+ NBLVLKDIA(KJ,:)=NBLVLKDIA(KJ,:)+1
+ IF(INDV-(INDVM+4)-1 == 1)READ(YCART(INDVM+4+1:INDVM+4+1),'(I1)')NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ IF(INDV-(INDVM+4)-1 == 2)READ(YCART(INDVM+4+1:INDV-1),'(I2)')NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ END IF
+ ENDDO
+
+ CASE(2)
+ IF(INDTO-4-1 == 1)READ(YCART(5:5),'(I1)')NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ IF(INDTO-4-1 == 2)READ(YCART(5:6),'(I2)')NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ NBLVLKDIA(KJ,:)=NBLVLKDIA(KJ,:)+1
+ IF(ILENCART-(INDTO+3+4) == 1)READ(YCART(INDTO+3+4+1:INDTO+3+4+1),'(I1)')NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ IF(ILENCART-(INDTO+3+4) == 2)READ(YCART(INDTO+3+4+1:ILENCART),'(I2)')NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+! 1 seul temps
+ CASE DEFAULT
+ IF(ILENCART-4 == 1)READ(YCART(5:5),'(I1)')NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ IF(ILENCART-4 == 2)READ(YCART(5:6),'(I2)')NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+
+ END SELECT
+ if(nverbia >0)then
+ print *,' RESOLVK ICAS '
+ print *,' LVLKDIALL ',LVLKDIALL(KJ,1)
+ print *,' NBLVLKDIA ',NBLVLKDIA(KJ,1)
+ print *,' NLVLKDIA ',(NLVLKDIA(J,KJ,1),J=1,NBLVLKDIA(KJ,1))
+ endif
+ RETURN
+ELSE
+
+!
+! Expression des Niveaux K en numerique
+!
+ IF(INDV == 0)THEN
+
+! Cas _TO_ _BY_
+
+ IF(INDTO /= 0)THEN
+ YCAR = ADJUSTL(YCART(1:INDTO-1))
+ NBLVLKDIA(KJ,:) = NBLVLKDIA(KJ,:)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1))
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ IF(INDBY /= 0)THEN
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDTO+4:INDBY-1))
+ NBLVLKDIA(KJ,:) = NBLVLKDIA(KJ,:)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1))
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDBY+4:ILENCART))
+ NBLVLKDIA(KJ,:) = NBLVLKDIA(KJ,:)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1))
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ ELSE
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDTO+4:ILENCART))
+ NBLVLKDIA(KJ,:) = NBLVLKDIA(KJ,:)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1))
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ END IF
+ ELSE
+
+! Cas un seul niveau en fin de chaine de car. HCARIN ou au milieu
+
+ IF(ILENCART > 9)THEN
+ print *,' PB ecriture temps '
+ STOP
+ ELSE
+ YCAR = ADJUSTL(YCART(1:ILENCART))
+ NBLVLKDIA(KJ,:) = NBLVLKDIA(KJ,:)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1))
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ END IF
+
+ END IF
+
+ ELSE
+
+! Presence de virgules
+
+ YCAR = ADJUSTL(YCART(1:INDV-1))
+ NBLVLKDIA(KJ,:) = NBLVLKDIA(KJ,:)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1))
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ DO J = 1,100
+ INDVM=INDV
+ INDV = 0
+ YCAR(1:LEN(YCAR))=' '
+ INDV = INDEX(YCART(INDVM+1:ILENCART),',')
+! print *,' INDV ',INDV
+ IF(INDV == 0)THEN
+ YCAR = ADJUSTL(YCART(INDVM+1:ILENCART))
+ NBLVLKDIA(KJ,:) = NBLVLKDIA(KJ,:)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1))
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ EXIT
+ ELSE
+ INDV=INDV+INDVM
+ YCAR = ADJUSTL(YCART(INDVM+1:INDV-1))
+ NBLVLKDIA(KJ,:) = NBLVLKDIA(KJ,:)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1))
+ NLVLKDIA(NBLVLKDIA(KJ,:),KJ,:)=NLVLKDIA(NBLVLKDIA(KJ,1),KJ,1)
+ END IF
+ ENDDO
+
+
+ END IF
+!
+END IF
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+if(nverbia >0)then
+print *,' RESOLVK '
+print *,' LVLKDIALL ',LVLKDIALL(KJ,1)
+print *,' NBLVLKDIA ',NBLVLKDIA(KJ,1)
+print *,' NLVLKDIA ',(NLVLKDIA(J,KJ,1),J=1,NBLVLKDIA(KJ,1))
+endif
+RETURN
+END SUBROUTINE RESOLVK
+! ######spl
+ MODULE MODI_RESOLVN
+! ###################
+!
+INTERFACE
+!
+SUBROUTINE RESOLVN(HCARIN,KINDN,KJ)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KINDN, KJ
+END SUBROUTINE RESOLVN
+!
+END INTERFACE
+!
+END MODULE MODI_RESOLVN
+! ###################################
+ SUBROUTINE RESOLVN(HCARIN,KINDN,KJ)
+! ###################################
+!
+!!**** *RESOLVN* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KINDN, KJ
+!
+!* 0.1 Local variables
+! ---------------
+
+CHARACTER(LEN=80) :: YCART
+CHARACTER(LEN=20) :: YCAR
+INTEGER :: ILENC, ILENCART
+INTEGER :: INDPF, INDTO, INDBY, INDV, INDVM
+INTEGER :: ICAS, J
+
+!
+!------------------------------------------------------------------------------
+INDPF = 0
+INDTO = 0
+INDBY = 0
+INDV = 0
+ICAS = 0
+
+NBNDIA(KJ)=0
+NNDIA(:,KJ)=0
+LNDIALL(KJ)=.FALSE.
+
+IF(KINDN == 0)THEN
+ LNDIALL(KJ) = .TRUE.
+ RETURN
+END IF
+
+ILENC = LEN(HCARIN)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ INDTO = INDEX(HCARIN(KINDN+3:ILENC),'_TO_')
+ INDBY = INDEX(HCARIN(KINDN+3:ILENC),'_BY_')
+ INDPF = INDEX(HCARIN(KINDN+3:ILENC),'_')
+ IF(INDTO /= 0)THEN
+ IF(INDPF < INDTO)THEN
+!
+! ICAS = 1 Num. unique ou separes par des virgules
+!
+ INDTO=0;INDBY=0
+ ICAS = 1
+ ELSE IF(INDPF == INDTO)THEN
+!
+! ICAS = 3 Proc1 _TO_ Procn _BY_ Procx
+!
+ IF(INDBY /= 0)THEN
+ DO J=INDTO+4+KINDN+3,INDBY+KINDN+3
+ IF(HCARIN(J:J) == '_')THEN
+ IF(HCARIN(J:J+3) == '_BY_')THEN
+ EXIT
+ ELSE
+ INDBY=0
+ EXIT
+ END IF
+ END IF
+ ENDDO
+ END IF
+ IF(INDBY /= 0)THEN
+ INDPF=INDEX(HCARIN(KINDN+3+INDBY+4:ILENC),'_')
+ IF(INDPF /= 0)INDPF=INDPF+INDBY+4
+ ICAS = 3
+ LPINCRDIA(KJ) = .TRUE.
+ ELSE
+!
+! ICAS = 2 Num1 _TO_ Numn
+!
+ INDPF=INDEX(HCARIN(KINDN+3+INDTO+4:ILENC),'_')
+ IF(INDPF /= 0)INDPF=INDPF+INDTO+4
+ ICAS = 2
+ LPINCRDIA(KJ) = .TRUE.
+ END IF
+ END IF
+ ELSE
+ ICAS = 1
+ END IF
+IF(INDPF == 0)THEN
+ INDPF = ILENC
+ELSE
+ INDPF = INDPF+KINDN+3-1-1
+END IF
+
+
+YCART(1:LEN(YCART))=' '
+YCAR(1:LEN(YCAR))=' '
+!
+! Extraction de la partie Numeros (masques ou traj.) dans YCART(1:ILENCART)
+!
+!print *,' KINDN INDPF ',KINDN,INDPF
+YCART = ADJUSTL(HCARIN(KINDN+3:INDPF))
+ILENCART = LEN_TRIM(YCART)
+!print *,' YCART ',ILENCART,' ',YCART
+
+! Recherche a nouveau des chaines de car. _TO_ , _BY_ et d'une virgule
+! par rapport au debut de YCART
+
+INDTO = INDEX(YCART,'_TO_')
+INDBY = INDEX(YCART,'_BY_')
+INDV = INDEX(YCART(1:ILENCART),',')
+IF(ICAS == 1 .AND. INDV == 0)ICAS=0
+!
+! Expression des Numeros par mots-cles (NALL ou N1....)
+!
+IF(YCART(1:4) == 'NALL')THEN
+ LNDIALL(KJ) = .TRUE.
+ if (nverbia>0) then
+ print *,' RESOLVN NALL '
+ print *,' LNDIALL ',LNDIALL(KJ)
+ print *,' NBNDIA ',NBNDIA(KJ)
+ print *,' NNDIA ',(NNDIA(J,KJ),J=1,NBNDIA(KJ))
+ endif
+ RETURN
+
+ELSE IF(YCART(1:1) == 'N')THEN
+!print *,' YCART(1:1) ',YCART(1:1),' ICAS ',ICAS
+
+ NBNDIA(KJ)=NBNDIA(KJ)+1
+ SELECT CASE(ICAS)
+ CASE(1)
+!print *,' INDV YCART(2:2) ',INDV,YCART(2:2)
+ IF(INDV-1-1 == 1)READ(YCART(2:2),'(I1)')NNDIA(NBNDIA(KJ),KJ)
+ IF(INDV-1-1 == 2)READ(YCART(2:3),'(I2)')NNDIA(NBNDIA(KJ),KJ)
+ DO J = 1,100
+ INDVM=INDV
+ INDV=0
+ INDV=INDEX(YCART(INDVM+1:ILENCART),',')
+ IF(INDV == 0)THEN
+ NBNDIA(KJ)=NBNDIA(KJ)+1
+ IF(ILENCART-(INDVM+1) == 1)READ(YCART(INDVM+1+1:INDVM+1+1),'(I1)')NNDIA(NBNDIA(KJ),KJ)
+ IF(ILENCART-(INDVM+1) == 2)READ(YCART(INDVM+1+1:ILENCART),'(I2)')NNDIA(NBNDIA(KJ),KJ)
+ EXIT
+ ELSE
+ INDV=INDV+INDVM
+ NBNDIA(KJ)=NBNDIA(KJ)+1
+ IF(INDV-(INDVM+1)-1 == 1)READ(YCART(INDVM+1+1:INDVM+1+1),'(I1)')NNDIA(NBNDIA(KJ),KJ)
+ IF(INDV-(INDVM+1)-1 == 2)READ(YCART(INDVM+1+1:INDV-1),'(I2)')NNDIA(NBNDIA(KJ),KJ)
+ END IF
+ ENDDO
+
+ CASE(2)
+ IF(INDTO-1-1 == 1)READ(YCART(2:2),'(I1)')NNDIA(NBNDIA(KJ),KJ)
+ IF(INDTO-1-1 == 2)READ(YCART(2:3),'(I2)')NNDIA(NBNDIA(KJ),KJ)
+ NBNDIA(KJ)=NBNDIA(KJ)+1
+ IF(ILENCART-(INDTO+3+1) == 1)READ(YCART(INDTO+3+1+1:INDTO+3+1+1),'(I1)')NNDIA(NBNDIA(KJ),KJ)
+ IF(ILENCART-(INDTO+3+1) == 2)READ(YCART(INDTO+3+1+1:ILENCART),'(I2)')NNDIA(NBNDIA(KJ),KJ)
+! 1 seul temps
+ CASE DEFAULT
+ IF(ILENCART-1 == 1)READ(YCART(2:2),'(I1)')NNDIA(NBNDIA(KJ),KJ)
+ IF(ILENCART-1 == 2)READ(YCART(2:3),'(I2)')NNDIA(NBNDIA(KJ),KJ)
+
+ END SELECT
+ if (nverbia>0) then
+ print *,' RESOLVN ICAS '
+ print *,' LNDIALL ',LNDIALL(KJ)
+ print *,' NBNDIA ',NBNDIA(KJ)
+ print *,' NNDIA ',(NNDIA(J,KJ),J=1,NBNDIA(KJ))
+ endif
+ RETURN
+ELSE
+
+!
+! Expression des numeros en numerique
+!
+ IF(INDV == 0)THEN
+
+! Cas _TO_ _BY_
+
+ IF(INDTO /= 0)THEN
+ YCAR = ADJUSTL(YCART(1:INDTO-1))
+ NBNDIA(KJ) = NBNDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NNDIA(NBNDIA(KJ),KJ))
+ IF(INDBY /= 0)THEN
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDTO+4:INDBY-1))
+ NBNDIA(KJ) = NBNDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NNDIA(NBNDIA(KJ),KJ))
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDBY+4:ILENCART))
+ NBNDIA(KJ) = NBNDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NNDIA(NBNDIA(KJ),KJ))
+ ELSE
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDTO+4:ILENCART))
+ NBNDIA(KJ) = NBNDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NNDIA(NBNDIA(KJ),KJ))
+ END IF
+ ELSE
+
+! Cas un seul processus en fin de chaine de car. HCARIN ou au milieu
+
+ IF(ILENCART > 9)THEN
+ print *,' PB ecriture temps '
+ STOP
+ ELSE
+ YCAR = ADJUSTL(YCART(1:ILENCART))
+ NBNDIA(KJ) = NBNDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NNDIA(NBNDIA(KJ),KJ))
+ END IF
+
+ END IF
+
+ ELSE
+
+! Presence de virgules
+
+ YCAR = ADJUSTL(YCART(1:INDV-1))
+ NBNDIA(KJ) = NBNDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NNDIA(NBNDIA(KJ),KJ))
+ DO J = 1,100
+ INDVM=INDV
+ INDV = 0
+ YCAR(1:LEN(YCAR))=' '
+ INDV = INDEX(YCART(INDVM+1:ILENCART),',')
+! print *,' INDV ',INDV
+ IF(INDV == 0)THEN
+ YCAR = ADJUSTL(YCART(INDVM+1:ILENCART))
+ NBNDIA(KJ) = NBNDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NNDIA(NBNDIA(KJ),KJ))
+ EXIT
+ ELSE
+ INDV=INDV+INDVM
+ YCAR = ADJUSTL(YCART(INDVM+1:INDV-1))
+ NBNDIA(KJ) = NBNDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NNDIA(NBNDIA(KJ),KJ))
+ END IF
+ ENDDO
+
+
+ END IF
+!
+END IF
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+if (nverbia>0) then
+print *,' end of RESOLVN '
+print *,' LNDIALL ',LNDIALL(KJ)
+print *,' NBNDIA ',NBNDIA(KJ)
+print *,' NNDIA ',(NNDIA(J,KJ),J=1,NBNDIA(KJ))
+endif
+RETURN
+END SUBROUTINE RESOLVN
+! ######spl
+ MODULE MODI_RESOLVON
+! ####################
+!
+INTERFACE
+!
+SUBROUTINE RESOLVON(HCARIN,KINDON)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KINDON
+END SUBROUTINE RESOLVON
+!
+END INTERFACE
+!
+END MODULE MODI_RESOLVON
+! ##################################
+ SUBROUTINE RESOLVON(HCARIN,KINDON)
+! ##################################
+!
+!!**** *RESOLVON* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KINDON
+!
+!* 0.1 Local variables
+! ---------------
+
+CHARACTER(LEN=LEN_TRIM(HCARIN)) :: YCARIN
+INTEGER :: ILENC, INDON, INDONM, ILONMS, INDMINUS, INDPLUS
+INTEGER :: J
+LOGICAL :: OMINUS, OPLUS
+
+!
+!------------------------------------------------------------------------------
+OMINUS=LMINUS
+OPLUS=LPLUS
+LSUPERDIA=.TRUE.
+NSUPERDIA=NSUPERDIA+1
+ILENC=LEN_TRIM(HCARIN)
+CARSUP(NSUPERDIA)(1:KINDON-1)=HCARIN(1:KINDON-1)
+INDONM=KINDON
+IF(LMINUS)THEN
+ ILONMS=7
+ NBPM=NBPM+1
+ NUMPM(NBPM)=2
+ELSE IF(LPLUS)THEN
+ ILONMS=6
+ NBPM=NBPM+1
+ NUMPM(NBPM)=1
+ELSE
+ ILONMS=4
+ NBPM=NBPM+1
+ NUMPM(NBPM)=3
+ENDIF
+DO J=1,100
+YCARIN(1:LEN(YCARIN))=' '
+YCARIN(1:ILENC-INDONM-ILONMS+1)=ADJUSTL(HCARIN(INDONM+ILONMS:ILENC))
+INDONM=INDONM+(ILONMS-1)
+INDON=INDEX(YCARIN,'_ON_')
+INDMINUS=INDEX(YCARIN,'_MINUS_')
+INDPLUS=INDEX(YCARIN,'_PLUS_')
+IF(INDON == 0)THEN
+ IF(INDMINUS == 0)THEN
+ IF(INDPLUS == 0)THEN
+ ELSE
+ INDON=INDPLUS
+ NBPM=NBPM+1
+ NUMPM(NBPM)=1
+ ILONMS=6
+ ENDIF
+ ELSE
+ IF(INDPLUS == 0)THEN
+ INDON=INDMINUS
+ NBPM=NBPM+1
+ NUMPM(NBPM)=2
+ ILONMS=7
+ ELSE
+ IF(INDMINUS < INDPLUS)THEN
+ INDON=INDMINUS
+ NBPM=NBPM+1
+ NUMPM(NBPM)=2
+ ILONMS=7
+ ELSE
+ INDON=INDPLUS
+ NBPM=NBPM+1
+ NUMPM(NBPM)=1
+ ILONMS=6
+ ENDIF
+ ENDIF
+ ENDIF
+
+ELSE
+
+! INDON =/= 0
+
+ IF(INDMINUS == 0 .AND. INDPLUS == 0)THEN
+ NBPM=NBPM+1
+ NUMPM(NBPM)=3
+ ILONMS=4
+ ELSE
+ IF(INDMINUS == 0)THEN
+ IF(INDON < INDPLUS)THEN
+ NBPM=NBPM+1
+ NUMPM(NBPM)=3
+ ILONMS=4
+ ELSE
+ INDON=INDPLUS
+ NBPM=NBPM+1
+ NUMPM(NBPM)=1
+ ILONMS=6
+ ENDIF
+ ELSE
+ IF(INDPLUS == 0)THEN
+ IF(INDON < INDMINUS)THEN
+ NBPM=NBPM+1
+ NUMPM(NBPM)=3
+ ILONMS=4
+ ELSE
+ INDON=INDMINUS
+ NBPM=NBPM+1
+ NUMPM(NBPM)=2
+ ILONMS=7
+ ENDIF
+ ELSE
+! ON + et -
+ IF(INDON < INDMINUS .AND. INDON < INDPLUS)THEN
+ NBPM=NBPM+1
+ NUMPM(NBPM)=3
+ ILONMS=4
+ ELSE IF(INDMINUS < INDON .AND. INDMINUS < INDPLUS)THEN
+ INDON=INDMINUS
+ NBPM=NBPM+1
+ NUMPM(NBPM)=2
+ ILONMS=7
+ ELSE IF(INDPLUS < INDON .AND. INDPLUS < INDMINUS)THEN
+ INDON=INDPLUS
+ NBPM=NBPM+1
+ NUMPM(NBPM)=1
+ ILONMS=6
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ENDIF
+IF(INDON == 0)THEN
+ NSUPERDIA=NSUPERDIA+1
+ CARSUP(NSUPERDIA)(1:LEN_TRIM(YCARIN))=ADJUSTL(YCARIN(1:LEN_TRIM(YCARIN)))
+EXIT
+ELSE
+ NSUPERDIA=NSUPERDIA+1
+ CARSUP(NSUPERDIA)(1:INDON-1)=ADJUSTL(YCARIN(1:INDON-1))
+ INDONM=INDONM+INDON
+ENDIF
+ENDDO
+NBPMT=0
+DO J=1,NBPM
+ IF(NUMPM(J) == 1 .OR. NUMPM(J) == 2)THEN
+ NBPMT=NBPMT+1
+ ENDIF
+ENDDO
+LMINUS=OMINUS
+LPLUS=OPLUS
+!print *,' resolvon NBPM NUMPM ',NBPM,NUMPM(1:NBPM)
+if(nverbia >0)then
+print *,'resolvon NBPM NUMPM ',NBPM,NUMPM(1:NBPM)
+endif
+RETURN
+END SUBROUTINE RESOLVON
+! ######spl
+ MODULE MODI_RESOLVP
+! ###################
+!
+INTERFACE
+!
+SUBROUTINE RESOLVP(HCARIN,KINDP,KJ)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KINDP, KJ
+END SUBROUTINE RESOLVP
+!
+END INTERFACE
+!
+END MODULE MODI_RESOLVP
+! ###################################
+ SUBROUTINE RESOLVP(HCARIN,KINDP,KJ)
+! ###################################
+!
+!!**** *RESOLVP* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KINDP, KJ
+!
+!* 0.1 Local variables
+! ---------------
+
+CHARACTER(LEN=80) :: YCART
+CHARACTER(LEN=20) :: YCAR
+INTEGER :: ILENC, ILENCART
+INTEGER :: INDPF, INDTO, INDBY, INDV, INDVM
+INTEGER :: ICAS, J
+
+!
+!------------------------------------------------------------------------------
+INDPF = 0
+INDTO = 0
+INDBY = 0
+INDV = 0
+ICAS = 0
+
+NBPROCDIA(KJ)=0
+NPROCDIA(:,KJ)=0
+LPROCDIALL(KJ)=.FALSE.
+
+IF(KINDP == 0)THEN
+ LPROCDIALL(KJ) = .TRUE.
+ RETURN
+END IF
+
+ILENC = LEN(HCARIN)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ INDTO = INDEX(HCARIN(KINDP+3:ILENC),'_TO_')
+ INDBY = INDEX(HCARIN(KINDP+3:ILENC),'_BY_')
+ INDPF = INDEX(HCARIN(KINDP+3:ILENC),'_')
+ IF(INDTO /= 0)THEN
+ IF(INDPF < INDTO)THEN
+!
+! ICAS = 1 Proc. unique ou separes par des virgules
+!
+ INDTO=0;INDBY=0
+ ICAS = 1
+ ELSE IF(INDPF == INDTO)THEN
+!
+! ICAS = 3 Proc1 _TO_ Procn _BY_ Procx
+!
+ IF(INDBY /= 0)THEN
+ DO J=INDTO+4+KINDP+3,INDBY+KINDP+3
+ IF(HCARIN(J:J) == '_')THEN
+ IF(HCARIN(J:J+3) == '_BY_')THEN
+ EXIT
+ ELSE
+ INDBY=0
+ EXIT
+ END IF
+ END IF
+ ENDDO
+ END IF
+ IF(INDBY /= 0)THEN
+ INDPF=INDEX(HCARIN(KINDP+3+INDBY+4:ILENC),'_')
+ IF(INDPF /= 0)INDPF=INDPF+INDBY+4
+ ICAS = 3
+ LPINCRDIA(KJ) = .TRUE.
+ ELSE
+!
+! ICAS = 2 Proc1 _TO_ Procn
+!
+ INDPF=INDEX(HCARIN(KINDP+3+INDTO+4:ILENC),'_')
+ IF(INDPF /= 0)INDPF=INDPF+INDTO+4
+ ICAS = 2
+ LPINCRDIA(KJ) = .TRUE.
+ END IF
+ END IF
+ ELSE
+ ICAS = 1
+ END IF
+IF(INDPF == 0)THEN
+ INDPF = ILENC
+ELSE
+ INDPF = INDPF+KINDP+3-1-1
+END IF
+
+
+YCART(1:LEN(YCART))=' '
+YCAR(1:LEN(YCAR))=' '
+!
+! Extraction de la partie Processus dans YCART(1:ILENCART)
+!
+!print *,' KINDP INDPF ',KINDP,INDPF
+YCART = ADJUSTL(HCARIN(KINDP+3:INDPF))
+ILENCART = LEN_TRIM(YCART)
+!print *,' YCART ',ILENCART,' ',YCART
+
+! Recherche a nouveau des chaines de car. _TO_ , _BY_ et d'une virgule
+! par rapport au debut de YCART
+
+INDTO = INDEX(YCART,'_TO_')
+INDBY = INDEX(YCART,'_BY_')
+INDV = INDEX(YCART(1:ILENCART),',')
+IF(ICAS == 1 .AND. INDV == 0)ICAS=0
+!
+! Expression des Processus par mots-cles (PROCALL ou PROC1....)
+!
+IF(YCART(1:7) == 'PROCALL')THEN
+ LPROCDIALL(KJ) = .TRUE.
+ print *,' RESOLVP PROCALL '
+ print *,' LPROCDIALL ',LPROCDIALL(KJ)
+ print *,' NBPROCDIA ',NBPROCDIA(KJ)
+ print *,' NPROCDIA ',(NPROCDIA(J,KJ),J=1,NBPROCDIA(KJ))
+ RETURN
+
+ELSE IF(YCART(1:4) == 'PROC')THEN
+!print *,' YCART(1:4) ',YCART(1:4),' ICAS ',ICAS
+
+ NBPROCDIA(KJ)=NBPROCDIA(KJ)+1
+ SELECT CASE(ICAS)
+ CASE(1)
+!print *,' INDV YCART(5:5) ',INDV,YCART(5:5)
+ IF(INDV-4-1 == 1)READ(YCART(5:5),'(I1)')NPROCDIA(NBPROCDIA(KJ),KJ)
+ IF(INDV-4-1 == 2)READ(YCART(5:6),'(I2)')NPROCDIA(NBPROCDIA(KJ),KJ)
+ DO J = 1,100
+ INDVM=INDV
+ INDV=0
+ INDV=INDEX(YCART(INDVM+1:ILENCART),',')
+ IF(INDV == 0)THEN
+ NBPROCDIA(KJ)=NBPROCDIA(KJ)+1
+ IF(ILENCART-(INDVM+4) == 1)READ(YCART(INDVM+4+1:INDVM+4+1),'(I1)')NPROCDIA(NBPROCDIA(KJ),KJ)
+ IF(ILENCART-(INDVM+4) == 2)READ(YCART(INDVM+4+1:ILENCART),'(I2)')NPROCDIA(NBPROCDIA(KJ),KJ)
+ EXIT
+ ELSE
+ INDV=INDV+INDVM
+ NBPROCDIA(KJ)=NBPROCDIA(KJ)+1
+ IF(INDV-(INDVM+4)-1 == 1)READ(YCART(INDVM+4+1:INDVM+4+1),'(I1)')NPROCDIA(NBPROCDIA(KJ),KJ)
+ IF(INDV-(INDVM+4)-1 == 2)READ(YCART(INDVM+4+1:INDV-1),'(I2)')NPROCDIA(NBPROCDIA(KJ),KJ)
+ END IF
+ ENDDO
+
+ CASE(2)
+ IF(INDTO-4-1 == 1)READ(YCART(5:5),'(I1)')NPROCDIA(NBPROCDIA(KJ),KJ)
+ IF(INDTO-4-1 == 2)READ(YCART(5:6),'(I2)')NPROCDIA(NBPROCDIA(KJ),KJ)
+ NBPROCDIA(KJ)=NBPROCDIA(KJ)+1
+ IF(ILENCART-(INDTO+3+4) == 1)READ(YCART(INDTO+3+4+1:INDTO+3+4+1),'(I1)')NPROCDIA(NBPROCDIA(KJ),KJ)
+ IF(ILENCART-(INDTO+3+4) == 2)READ(YCART(INDTO+3+4+1:ILENCART),'(I2)')NPROCDIA(NBPROCDIA(KJ),KJ)
+! 1 seul temps
+ CASE DEFAULT
+ IF(ILENCART-4 == 1)READ(YCART(5:5),'(I1)')NPROCDIA(NBPROCDIA(KJ),KJ)
+ IF(ILENCART-4 == 2)READ(YCART(5:6),'(I2)')NPROCDIA(NBPROCDIA(KJ),KJ)
+
+ END SELECT
+ print *,' RESOLVP ICAS '
+ print *,' LPROCDIALL ',LPROCDIALL(KJ)
+ print *,' NBPROCDIA ',NBPROCDIA(KJ)
+ print *,' NPROCDIA ',(NPROCDIA(J,KJ),J=1,NBPROCDIA(KJ))
+ RETURN
+ELSE
+
+!
+! Expression des processus en numerique
+!
+ IF(INDV == 0)THEN
+
+! Cas _TO_ _BY_
+
+ IF(INDTO /= 0)THEN
+ YCAR = ADJUSTL(YCART(1:INDTO-1))
+ NBPROCDIA(KJ) = NBPROCDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NPROCDIA(NBPROCDIA(KJ),KJ))
+ IF(INDBY /= 0)THEN
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDTO+4:INDBY-1))
+ NBPROCDIA(KJ) = NBPROCDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NPROCDIA(NBPROCDIA(KJ),KJ))
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDBY+4:ILENCART))
+ NBPROCDIA(KJ) = NBPROCDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NPROCDIA(NBPROCDIA(KJ),KJ))
+ ELSE
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDTO+4:ILENCART))
+ NBPROCDIA(KJ) = NBPROCDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NPROCDIA(NBPROCDIA(KJ),KJ))
+ END IF
+ ELSE
+
+! Cas un seul processus en fin de chaine de car. HCARIN ou au milieu
+
+ IF(ILENCART > 9)THEN
+ print *,' PB ecriture temps '
+ STOP
+ ELSE
+ YCAR = ADJUSTL(YCART(1:ILENCART))
+ NBPROCDIA(KJ) = NBPROCDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NPROCDIA(NBPROCDIA(KJ),KJ))
+ END IF
+
+ END IF
+
+ ELSE
+
+! Presence de virgules
+
+ YCAR = ADJUSTL(YCART(1:INDV-1))
+ NBPROCDIA(KJ) = NBPROCDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NPROCDIA(NBPROCDIA(KJ),KJ))
+ DO J = 1,100
+ INDVM=INDV
+ INDV = 0
+ YCAR(1:LEN(YCAR))=' '
+ INDV = INDEX(YCART(INDVM+1:ILENCART),',')
+! print *,' INDV ',INDV
+ IF(INDV == 0)THEN
+ YCAR = ADJUSTL(YCART(INDVM+1:ILENCART))
+ NBPROCDIA(KJ) = NBPROCDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NPROCDIA(NBPROCDIA(KJ),KJ))
+ EXIT
+ ELSE
+ INDV=INDV+INDVM
+ YCAR = ADJUSTL(YCART(INDVM+1:INDV-1))
+ NBPROCDIA(KJ) = NBPROCDIA(KJ)+1
+ CALL CARINT(YCAR(1:LEN_TRIM(YCAR)),NPROCDIA(NBPROCDIA(KJ),KJ))
+ END IF
+ ENDDO
+
+
+ END IF
+!
+END IF
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+print *,' RESOLVP '
+print *,' LPROCDIALL ',LPROCDIALL(KJ)
+print *,' NBPROCDIA ',NBPROCDIA(KJ)
+print *,' NPROCDIA ',(NPROCDIA(J,KJ),J=1,NBPROCDIA(KJ))
+RETURN
+END SUBROUTINE RESOLVP
+! ######spl
+ MODULE MODI_RESOLVX
+! ###################
+!
+INTERFACE
+!
+SUBROUTINE RESOLVX(HCARIN,KIND,POUT)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND
+REAL :: POUT
+END SUBROUTINE RESOLVX
+!
+END INTERFACE
+!
+END MODULE MODI_RESOLVX
+! ########################################
+ SUBROUTINE RESOLVX(HCARIN,KIND,POUT)
+! ########################################
+!
+!!**** *RESOLVX* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODN_PARA
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND
+REAL :: POUT
+!
+!* 0.1 Local variables
+! ---------------
+
+CHARACTER(LEN=15) :: YC15
+INTEGER :: ILENC, ILENC15
+INTEGER :: J,JM
+
+!
+!------------------------------------------------------------------------------
+ILENC=LEN_TRIM(HCARIN)
+
+DO J=KIND,ILENC
+ IF(HCARIN(J:J) == '=')EXIT
+ENDDO
+
+JM=J+1
+DO J=1,10
+ IF(HCARIN(JM:JM) == ' ')THEN
+ JM=JM+1
+ ELSE
+ EXIT
+ ENDIF
+ENDDO
+YC15=' '
+
+DO J=JM,ILENC
+ IF(HCARIN(J:J) == '0'.OR.HCARIN(J:J) == '1'.OR.HCARIN(J:J) == '2' &
+ .OR.HCARIN(J:J) == '3'.OR.HCARIN(J:J) == '4'.OR.HCARIN(J:J) == '5' &
+ .OR.HCARIN(J:J) == '6'.OR.HCARIN(J:J) == '7'.OR.HCARIN(J:J) == '8' &
+ .OR.HCARIN(J:J) == '9'.OR.HCARIN(J:J) == '.' .OR. &
+ HCARIN(J:J) == '+' .OR.HCARIN(J:J) == '-' .OR.HCARIN(J:J) == 'E' &
+ .OR.HCARIN(J:J) == 'e')THEN
+ YC15(1:1)=HCARIN(J:J)
+ IF(J+1 > ILENC)EXIT
+ IF(HCARIN(J+1:J+1) /= '0' .AND. HCARIN(J+1:J+1) /= '1' .AND. &
+ HCARIN(J+1:J+1) /= '2' .AND. HCARIN(J+1:J+1) /= '3' .AND. &
+ HCARIN(J+1:J+1) /= '4' .AND. HCARIN(J+1:J+1) /= '5' .AND. &
+ HCARIN(J+1:J+1) /= '6' .AND. HCARIN(J+1:J+1) /= '7' .AND. &
+ HCARIN(J+1:J+1) /= '8' .AND. HCARIN(J+1:J+1) /= '9' .AND. &
+ HCARIN(J+1:J+1) /= '+' .AND. HCARIN(J+1:J+1) /= '-' .AND. &
+ HCARIN(J+1:J+1) /= 'E' .AND. HCARIN(J+1:J+1) /= 'e' .AND. &
+ HCARIN(J+1:J+1) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(2:2)=HCARIN(J+1:J+1)
+ IF(J+2 > ILENC)EXIT
+ IF(HCARIN(J+2:J+2) /= '0' .AND. HCARIN(J+2:J+2) /= '1' .AND. &
+ HCARIN(J+2:J+2) /= '2' .AND. HCARIN(J+2:J+2) /= '3' .AND. &
+ HCARIN(J+2:J+2) /= '4' .AND. HCARIN(J+2:J+2) /= '5' .AND. &
+ HCARIN(J+2:J+2) /= '6' .AND. HCARIN(J+2:J+2) /= '7' .AND. &
+ HCARIN(J+2:J+2) /= '8' .AND. HCARIN(J+2:J+2) /= '9' .AND. &
+ HCARIN(J+2:J+2) /= '+' .AND. HCARIN(J+2:J+2) /= '-' .AND. &
+ HCARIN(J+2:J+2) /= 'E' .AND. HCARIN(J+2:J+2) /= 'e' .AND. &
+ HCARIN(J+2:J+2) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(3:3)=HCARIN(J+2:J+2)
+ IF(J+3 > ILENC)EXIT
+ IF(HCARIN(J+3:J+3) /= '0' .AND. HCARIN(J+3:J+3) /= '1' .AND. &
+ HCARIN(J+3:J+3) /= '2' .AND. HCARIN(J+3:J+3) /= '3' .AND. &
+ HCARIN(J+3:J+3) /= '4' .AND. HCARIN(J+3:J+3) /= '5' .AND. &
+ HCARIN(J+3:J+3) /= '6' .AND. HCARIN(J+3:J+3) /= '7' .AND. &
+ HCARIN(J+3:J+3) /= '8' .AND. HCARIN(J+3:J+3) /= '9' .AND. &
+ HCARIN(J+3:J+3) /= '+' .AND. HCARIN(J+3:J+3) /= '-' .AND. &
+ HCARIN(J+3:J+3) /= 'E' .AND. HCARIN(J+3:J+3) /= 'e' .AND. &
+ HCARIN(J+3:J+3) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(4:4)=HCARIN(J+3:J+3)
+ IF(J+4 > ILENC)EXIT
+ IF(HCARIN(J+4:J+4) /= '0' .AND. HCARIN(J+4:J+4) /= '1' .AND. &
+ HCARIN(J+4:J+4) /= '2' .AND. HCARIN(J+4:J+4) /= '3' .AND. &
+ HCARIN(J+4:J+4) /= '4' .AND. HCARIN(J+4:J+4) /= '5' .AND. &
+ HCARIN(J+4:J+4) /= '6' .AND. HCARIN(J+4:J+4) /= '7' .AND. &
+ HCARIN(J+4:J+4) /= '8' .AND. HCARIN(J+4:J+4) /= '9' .AND. &
+ HCARIN(J+4:J+4) /= '+' .AND. HCARIN(J+4:J+4) /= '-' .AND. &
+ HCARIN(J+4:J+4) /= 'E' .AND. HCARIN(J+4:J+4) /= 'e' .AND. &
+ HCARIN(J+4:J+4) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(5:5)=HCARIN(J+4:J+4)
+ IF(J+5 > ILENC)EXIT
+ IF(HCARIN(J+5:J+5) /= '0' .AND. HCARIN(J+5:J+5) /= '1' .AND. &
+ HCARIN(J+5:J+5) /= '2' .AND. HCARIN(J+5:J+5) /= '3' .AND. &
+ HCARIN(J+5:J+5) /= '4' .AND. HCARIN(J+5:J+5) /= '5' .AND. &
+ HCARIN(J+5:J+5) /= '6' .AND. HCARIN(J+5:J+5) /= '7' .AND. &
+ HCARIN(J+5:J+5) /= '8' .AND. HCARIN(J+5:J+5) /= '9' .AND. &
+ HCARIN(J+5:J+5) /= '+' .AND. HCARIN(J+5:J+5) /= '-' .AND. &
+ HCARIN(J+5:J+5) /= 'E' .AND. HCARIN(J+5:J+5) /= 'e' .AND. &
+ HCARIN(J+5:J+5) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(6:6)=HCARIN(J+5:J+5)
+ IF(J+6 > ILENC)EXIT
+ IF(HCARIN(J+6:J+6) /= '0' .AND. HCARIN(J+6:J+6) /= '1' .AND. &
+ HCARIN(J+6:J+6) /= '2' .AND. HCARIN(J+6:J+6) /= '3' .AND. &
+ HCARIN(J+6:J+6) /= '4' .AND. HCARIN(J+6:J+6) /= '5' .AND. &
+ HCARIN(J+6:J+6) /= '6' .AND. HCARIN(J+6:J+6) /= '7' .AND. &
+ HCARIN(J+6:J+6) /= '8' .AND. HCARIN(J+6:J+6) /= '9' .AND. &
+ HCARIN(J+6:J+6) /= '+' .AND. HCARIN(J+6:J+6) /= '-' .AND. &
+ HCARIN(J+6:J+6) /= 'E' .AND. HCARIN(J+6:J+6) /= 'e' .AND. &
+ HCARIN(J+6:J+6) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(7:7)=HCARIN(J+6:J+6)
+ IF(J+7 > ILENC)EXIT
+ IF(HCARIN(J+7:J+7) /= '0' .AND. HCARIN(J+7:J+7) /= '1' .AND.&
+ HCARIN(J+7:J+7) /= '2' .AND. HCARIN(J+7:J+7) /= '3' .AND.&
+ HCARIN(J+7:J+7) /= '4' .AND. HCARIN(J+7:J+7) /= '5' .AND.&
+ HCARIN(J+7:J+7) /= '6' .AND. HCARIN(J+7:J+7) /= '7' .AND.&
+ HCARIN(J+7:J+7) /= '8' .AND. HCARIN(J+7:J+7) /= '9' .AND.&
+ HCARIN(J+7:J+7) /= '+' .AND. HCARIN(J+7:J+7) /= '-' .AND.&
+ HCARIN(J+7:J+7) /= 'E' .AND. HCARIN(J+7:J+7) /= 'e' .AND.&
+ HCARIN(J+7:J+7) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(8:8)=HCARIN(J+7:J+7)
+ IF(J+8 > ILENC)EXIT
+ IF(HCARIN(J+8:J+8) /= '0' .AND. &
+ HCARIN(J+8:J+8) /= '1' .AND. &
+ HCARIN(J+8:J+8) /= '2' .AND. &
+ HCARIN(J+8:J+8) /= '3' .AND. &
+ HCARIN(J+8:J+8) /= '4' .AND. &
+ HCARIN(J+8:J+8) /= '5' .AND. &
+ HCARIN(J+8:J+8) /= '6' .AND. &
+ HCARIN(J+8:J+8) /= '7' .AND. &
+ HCARIN(J+8:J+8) /= '8' .AND. &
+ HCARIN(J+8:J+8) /= '9' .AND. &
+ HCARIN(J+8:J+8) /= '+' .AND. &
+ HCARIN(J+8:J+8) /= '-' .AND. &
+ HCARIN(J+8:J+8) /= 'E' .AND. &
+ HCARIN(J+8:J+8) /= 'e' .AND. &
+ HCARIN(J+8:J+8) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(9:9)=HCARIN(J+8:J+8)
+ IF(J+9 > ILENC)EXIT
+ IF(HCARIN(J+9:J+9) /= '0' .AND. &
+ HCARIN(J+9:J+9) /= '1' .AND. &
+ HCARIN(J+9:J+9) /= '2' .AND. &
+ HCARIN(J+9:J+9) /= '3' .AND. &
+ HCARIN(J+9:J+9) /= '4' .AND. &
+ HCARIN(J+9:J+9) /= '5' .AND. &
+ HCARIN(J+9:J+9) /= '6' .AND. &
+ HCARIN(J+9:J+9) /= '7' .AND. &
+ HCARIN(J+9:J+9) /= '8' .AND. &
+ HCARIN(J+9:J+9) /= '9' .AND. &
+ HCARIN(J+9:J+9) /= '+' .AND. &
+ HCARIN(J+9:J+9) /= '-' .AND. &
+ HCARIN(J+9:J+9) /= 'E' .AND. &
+ HCARIN(J+9:J+9) /= 'e' .AND. &
+ HCARIN(J+9:J+9) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(10:10)=HCARIN(J+9:J+9)
+ IF(J+10 > ILENC)EXIT
+ IF(HCARIN(J+10:J+10) /= '0' .AND. &
+ HCARIN(J+10:J+10) /= '1' .AND. &
+ HCARIN(J+10:J+10) /= '2' .AND. &
+ HCARIN(J+10:J+10) /= '3' .AND. &
+ HCARIN(J+10:J+10) /= '4' .AND. &
+ HCARIN(J+10:J+10) /= '5' .AND. &
+ HCARIN(J+10:J+10) /= '6' .AND. &
+ HCARIN(J+10:J+10) /= '7' .AND. &
+ HCARIN(J+10:J+10) /= '8' .AND. &
+ HCARIN(J+10:J+10) /= '9' .AND. &
+ HCARIN(J+10:J+10) /= '+' .AND. &
+ HCARIN(J+10:J+10) /= '-' .AND. &
+ HCARIN(J+10:J+10) /= 'E' .AND. &
+ HCARIN(J+10:J+10) /= 'e' .AND. &
+ HCARIN(J+10:J+10) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(11:11)=HCARIN(J+10:J+10)
+ IF(J+11 > ILENC)EXIT
+ IF(HCARIN(J+11:J+11) /= '0' .AND. &
+ HCARIN(J+11:J+11) /= '1' .AND. &
+ HCARIN(J+11:J+11) /= '2' .AND. &
+ HCARIN(J+11:J+11) /= '3' .AND. &
+ HCARIN(J+11:J+11) /= '4' .AND. &
+ HCARIN(J+11:J+11) /= '5' .AND. &
+ HCARIN(J+11:J+11) /= '6' .AND. &
+ HCARIN(J+11:J+11) /= '7' .AND. &
+ HCARIN(J+11:J+11) /= '8' .AND. &
+ HCARIN(J+11:J+11) /= '9' .AND. &
+ HCARIN(J+11:J+11) /= '+' .AND. &
+ HCARIN(J+11:J+11) /= '-' .AND. &
+ HCARIN(J+11:J+11) /= 'E' .AND. &
+ HCARIN(J+11:J+11) /= 'e' .AND. &
+ HCARIN(J+11:J+11) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(12:12)=HCARIN(J+11:J+11)
+ IF(J+12 > ILENC)EXIT
+ IF(HCARIN(J+12:J+12) /= '0' .AND. &
+ HCARIN(J+12:J+12) /= '1' .AND. &
+ HCARIN(J+12:J+12) /= '2' .AND. &
+ HCARIN(J+12:J+12) /= '3' .AND. &
+ HCARIN(J+12:J+12) /= '4' .AND. &
+ HCARIN(J+12:J+12) /= '5' .AND. &
+ HCARIN(J+12:J+12) /= '6' .AND. &
+ HCARIN(J+12:J+12) /= '7' .AND. &
+ HCARIN(J+12:J+12) /= '8' .AND. &
+ HCARIN(J+12:J+12) /= '9' .AND. &
+ HCARIN(J+12:J+12) /= '+' .AND. &
+ HCARIN(J+12:J+12) /= '-' .AND. &
+ HCARIN(J+12:J+12) /= 'E' .AND. &
+ HCARIN(J+12:J+12) /= 'e' .AND. &
+ HCARIN(J+12:J+12) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(13:13)=HCARIN(J+12:J+12)
+ IF(J+13 > ILENC)EXIT
+ IF(HCARIN(J+13:J+13) /= '0' .AND. &
+ HCARIN(J+13:J+13) /= '1' .AND. &
+ HCARIN(J+13:J+13) /= '2' .AND. &
+ HCARIN(J+13:J+13) /= '3' .AND. &
+ HCARIN(J+13:J+13) /= '4' .AND. &
+ HCARIN(J+13:J+13) /= '5' .AND. &
+ HCARIN(J+13:J+13) /= '6' .AND. &
+ HCARIN(J+13:J+13) /= '7' .AND. &
+ HCARIN(J+13:J+13) /= '8' .AND. &
+ HCARIN(J+13:J+13) /= '9' .AND. &
+ HCARIN(J+13:J+13) /= '+' .AND. &
+ HCARIN(J+13:J+13) /= '-' .AND. &
+ HCARIN(J+13:J+13) /= 'E' .AND. &
+ HCARIN(J+13:J+13) /= 'e' .AND. &
+ HCARIN(J+13:J+13) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(14:14)=HCARIN(J+13:J+13)
+ IF(J+14 > ILENC)EXIT
+ IF(HCARIN(J+14:J+14) /= '0' .AND. &
+ HCARIN(J+14:J+14) /= '1' .AND. &
+ HCARIN(J+14:J+14) /= '2' .AND. &
+ HCARIN(J+14:J+14) /= '3' .AND. &
+ HCARIN(J+14:J+14) /= '4' .AND. &
+ HCARIN(J+14:J+14) /= '5' .AND. &
+ HCARIN(J+14:J+14) /= '6' .AND. &
+ HCARIN(J+14:J+14) /= '7' .AND. &
+ HCARIN(J+14:J+14) /= '8' .AND. &
+ HCARIN(J+14:J+14) /= '9' .AND. &
+ HCARIN(J+14:J+14) /= '+' .AND. &
+ HCARIN(J+14:J+14) /= '-' .AND. &
+ HCARIN(J+14:J+14) /= 'E' .AND. &
+ HCARIN(J+14:J+14) /= 'e' .AND. &
+ HCARIN(J+14:J+14) /= '.')THEN
+ EXIT
+ ELSE
+ YC15(15:15)=HCARIN(J+11:J+11)
+ IF(J+15 > ILENC)EXIT
+ IF(HCARIN(J+15:J+15) /= '0' .AND. &
+ HCARIN(J+15:J+15) /= '1' .AND. &
+ HCARIN(J+15:J+15) /= '2' .AND. &
+ HCARIN(J+15:J+15) /= '3' .AND. &
+ HCARIN(J+15:J+15) /= '4' .AND. &
+ HCARIN(J+15:J+15) /= '5' .AND. &
+ HCARIN(J+15:J+15) /= '6' .AND. &
+ HCARIN(J+15:J+15) /= '7' .AND. &
+ HCARIN(J+15:J+15) /= '8' .AND. &
+ HCARIN(J+15:J+15) /= '9' .AND. &
+ HCARIN(J+15:J+15) /= '+' .AND. &
+ HCARIN(J+15:J+15) /= '-' .AND. &
+ HCARIN(J+15:J+15) /= 'E' .AND. &
+ HCARIN(J+15:J+15) /= 'e' .AND. &
+ HCARIN(J+15:J+15) /= '.')THEN
+ EXIT
+ ELSE
+ print *,' PB AVEC LA VALEUR FOURNIE ', &
+ HCARIN(J:J+15),' ARRET PG. VERIFIEZ SA VALEUR '
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ENDDO
+
+
+YC15=ADJUSTL(YC15)
+ILENC15 = LEN_TRIM(YC15)
+!print *, ' ILENC15 ',ILENC15,YC15
+READ(YC15,*)POUT
+
+RETURN
+END SUBROUTINE RESOLVX
+! ######spl
+ MODULE MODI_RESOLVXISOLEV
+! #########################
+!
+INTERFACE
+!
+SUBROUTINE RESOLVXISOLEV(HCARIN,KIND,POUT)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND
+REAL,DIMENSION(:) :: POUT
+END SUBROUTINE RESOLVXISOLEV
+!
+END INTERFACE
+!
+END MODULE MODI_RESOLVXISOLEV
+! ########################################
+ SUBROUTINE RESOLVXISOLEV(HCARIN,KIND,POUT)
+! ########################################
+!
+!!**** *RESOLVXISOLEV* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODN_PARA
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KIND
+REAL,DIMENSION(:) :: POUT
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: ILENC
+INTEGER :: J,JM, JMF
+INTEGER :: INBV, IND9999
+
+!
+!------------------------------------------------------------------------------
+ILENC=LEN_TRIM(HCARIN)
+POUT=9999.
+
+DO J=KIND,ILENC
+ IF(HCARIN(J:J) == '=')EXIT
+ENDDO
+
+JM=J+1
+DO J=1,10
+ IF(HCARIN(JM:JM) == ' ')THEN
+ JM=JM+1
+ ELSE
+ EXIT
+ ENDIF
+ENDDO
+
+IND9999=INDEX(HCARIN(JM:ILENC),'9999.')
+JMF=IND9999+JM-1+3
+INBV=0
+IF(NVERBIA >= 5)THEN
+ print *,' RESOLVXISOLEV carin: ',ind9999,jm,jmf,HCARIN(JM:JMF)
+ENDIF
+DO J=JM,JMF
+ IF(HCARIN(J:J) == ',')THEN
+ INBV=INBV+1
+ ENDIF
+ENDDO
+
+READ(HCARIN(JM:JMF),*)(POUT(J),J=1,INBV+1)
+IF(NVERBIA >= 5)THEN
+ print *,' RESOLVXISOLEV ',INBV+1,(POUT(J),J=1,INBV+1)
+ENDIF
+RETURN
+END SUBROUTINE RESOLVXISOLEV
+! ######spl
+ MODULE MODI_RESOLVT
+! ###################
+!
+INTERFACE
+!
+SUBROUTINE RESOLVT(HCARIN,KINDT,KJ)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KINDT, KJ
+END SUBROUTINE RESOLVT
+!
+END INTERFACE
+!
+END MODULE MODI_RESOLVT
+! ##################################
+ SUBROUTINE RESOLVT(HCARIN,KINDT,KJ)
+! ###################################
+!
+!!**** *RESOLVT* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KINDT, KJ
+!
+!* 0.1 Local variables
+! ---------------
+
+CHARACTER(LEN=LEN(HCARIN)) :: YCART
+CHARACTER(LEN=20) :: YCAR
+INTEGER :: ILENC, ILENCART
+INTEGER :: INDTF, INDTO, INDBY, INDV, INDVM
+INTEGER :: ICAS, J
+
+!
+!------------------------------------------------------------------------------
+INDTF = 0
+INDTO = 0
+INDBY = 0
+INDV = 0
+ICAS = 0
+
+NBTIMEDIA(KJ,:)=0
+NTIMEDIA(:,KJ,:)=0
+XTIMEDIA(:,KJ,:)=0.
+LTIMEDIALL(KJ,:)=.FALSE.
+LTINCRDIA(KJ,:)=.FALSE.
+
+IF(KINDT == 0)THEN
+ LTIMEDIALL(KJ,:) = .TRUE.
+ RETURN
+END IF
+
+ILENC = LEN(HCARIN)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+INDTO = INDEX(HCARIN(KINDT+3:ILENC),'_TO_')
+INDBY = INDEX(HCARIN(KINDT+3:ILENC),'_BY_')
+INDTF = INDEX(HCARIN(KINDT+3:ILENC),'_')
+IF(INDTO /= 0)THEN
+ IF(INDTF < INDTO)THEN
+!
+! ICAS = 1 Temps unique ou separes par des virgules
+!
+ INDTO=0;INDBY=0
+ ICAS = 1
+ ELSE IF(INDTF == INDTO)THEN
+!
+! ICAS = 3 Temps1 _TO_ Tempsn _BY_ Tempsx
+!
+ IF(INDBY /= 0)THEN
+ DO J=INDTO+4+KINDT+3,INDBY+KINDT+3
+ IF(HCARIN(J:J) == '_')THEN
+ IF(HCARIN(J:J+3) == '_BY_')THEN
+ EXIT
+ ELSE
+ INDBY=0
+ EXIT
+ END IF
+ END IF
+ ENDDO
+ END IF
+ IF(INDBY /= 0)THEN
+ INDTF=INDEX(HCARIN(KINDT+3+INDBY+4:ILENC),'_')
+ IF(INDTF /= 0)INDTF=INDTF+INDBY+4
+ ICAS = 3
+ LTINCRDIA(KJ,:) = .TRUE.
+ ELSE
+!
+! ICAS = 2 Temps1 _TO_ Tempsn
+!
+ INDTF=INDEX(HCARIN(KINDT+3+INDTO+4:ILENC),'_')
+ IF(INDTF /= 0)INDTF=INDTF+INDTO+4
+ ICAS = 2
+ LTINCRDIA(KJ,:) = .TRUE.
+ END IF
+ END IF
+ELSE
+ ICAS = 1
+END IF
+
+IF(INDTF == 0)THEN
+ INDTF = ILENC
+ELSE
+ INDTF = INDTF+KINDT+3-1-1
+END IF
+
+
+YCART(1:LEN(YCART))=' '
+YCAR(1:LEN(YCAR))=' '
+!
+! Extraction de la partie Temps dans YCART(1:ILENCART)
+!
+YCART = ADJUSTL(HCARIN(KINDT+3:INDTF))
+ILENCART = LEN_TRIM(YCART)
+if (nverbia >0) then
+ print *,' ICAS KINDT INDTF ',ICAS,KINDT,INDTF
+ print *,' YCART ',ILENCART,' ',YCART
+endif
+
+! Recherche a nouveau des chaines de car. _TO_ , _BY_ et d'une virgule
+! par rapport au debut de YCART
+
+INDTO = INDEX(YCART,'_TO_')
+INDBY = INDEX(YCART,'_BY_')
+INDV = INDEX(YCART(1:ILENCART),',')
+IF(ICAS == 1 .AND. INDV == 0)ICAS=0
+!
+! Expression du temps par mots-cles (TIMEALL ou TIME1....)
+!
+IF(YCART(1:7) == 'TIMEALL')THEN
+ LTIMEDIALL(KJ,:) = .TRUE.
+if (nverbia >0) then
+ print *,' RESOLVT TIMEALL '
+ print *,' LTIMEDIALL(KJ,1) ',LTIMEDIALL(KJ,1)
+ print *,' NBTIMEDIA(KJ,1) ',NBTIMEDIA(KJ,1)
+ print *,' NTIMEDIA ',(NTIMEDIA(J,KJ,1),J=1,NBTIMEDIA(KJ,1))
+ print *,' XTIMEDIA ',(XTIMEDIA(J,KJ,1),J=1,NBTIMEDIA(KJ,1))
+endif
+ RETURN
+
+ELSE IF(YCART(1:4) == 'TIME')THEN
+!print *,' YCART(1:4) ',YCART(1:4),' ICAS ',ICAS
+
+ NBTIMEDIA(KJ,:)=NBTIMEDIA(KJ,:)+1
+ SELECT CASE(ICAS)
+ CASE(1)
+!print *,' INDV YCART(5:5) ',INDV,YCART(5:5)
+ READ(YCART(5:INDV-1),*)NTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ NTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=NTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ DO J = 1,100
+ INDVM=INDV
+ INDV=0
+ INDV=INDEX(YCART(INDVM+1:ILENCART),',')
+ IF(INDV == 0)THEN
+ NBTIMEDIA(KJ,:)=NBTIMEDIA(KJ,:)+1
+ READ(YCART(INDVM+4+1:ILENCART),*)NTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ NTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=NTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ EXIT
+ ELSE
+ INDV=INDV+INDVM
+ NBTIMEDIA(KJ,:)=NBTIMEDIA(KJ,:)+1
+ READ(YCART(INDVM+4+1:INDV-1),*)NTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ NTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=NTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ END IF
+ ENDDO
+
+ CASE(2)
+ READ(YCART(5:INDTO-1),*)NTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ NTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=NTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ NBTIMEDIA(KJ,:)=NBTIMEDIA(KJ,:)+1
+ READ(YCART(INDTO+3+4+1:ILENCART),*)NTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ NTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=NTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+! 1 seul temps
+ CASE DEFAULT
+ READ(YCART(5:ILENCART),*)NTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ NTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=NTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+
+ END SELECT
+if (nverbia >0) then
+ print *,' RESOLVT ICAS '
+ print *,' LTIMEDIALL(KJ,1) ',LTIMEDIALL(KJ,1)
+ print *,' NBTIMEDIA(KJ,1) ',NBTIMEDIA(KJ,1)
+ print *,' NTIMEDIA ',(NTIMEDIA(J,KJ,1),J=1,NBTIMEDIA(KJ,1))
+ print *,' XTIMEDIA ',(XTIMEDIA(J,KJ,1),J=1,NBTIMEDIA(KJ,1))
+endif
+ RETURN
+ELSE
+
+!
+! Expression du temps en numerique
+!
+ IF(INDV == 0)THEN
+
+! Cas _TO_ _BY_
+
+ IF(INDTO /= 0)THEN
+ YCAR = ADJUSTL(YCART(1:INDTO-1))
+ NBTIMEDIA(KJ,:) = NBTIMEDIA(KJ,:)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1))
+ XTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ IF(INDBY /= 0)THEN
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDTO+4:INDBY-1))
+ NBTIMEDIA(KJ,:) = NBTIMEDIA(KJ,:)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1))
+ XTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDBY+4:ILENCART))
+ NBTIMEDIA(KJ,:) = NBTIMEDIA(KJ,:)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1))
+ XTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ ELSE
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDTO+4:ILENCART))
+ NBTIMEDIA(KJ,:) = NBTIMEDIA(KJ,:)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1))
+ XTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ END IF
+ ELSE
+
+! Cas un seul temps en fin de chaine de car. HCARIN ou au milieu
+
+ IF(ILENCART > 9)THEN
+ print *,' PB ecriture temps '
+ STOP
+ ELSE
+ YCAR = ADJUSTL(YCART(1:ILENCART))
+ NBTIMEDIA(KJ,:) = NBTIMEDIA(KJ,:)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1))
+ XTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ END IF
+
+ END IF
+
+ ELSE
+
+! Presence de virgules
+
+ YCAR = ADJUSTL(YCART(1:INDV-1))
+ NBTIMEDIA(KJ,:) = NBTIMEDIA(KJ,:)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1))
+ XTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ DO J = 1,100
+ INDVM=INDV
+ INDV = 0
+ YCAR(1:LEN(YCAR))=' '
+ INDV = INDEX(YCART(INDVM+1:ILENCART),',')
+! print *,' INDV ',INDV
+ IF(INDV == 0)THEN
+ YCAR = ADJUSTL(YCART(INDVM+1:ILENCART))
+ NBTIMEDIA(KJ,:) = NBTIMEDIA(KJ,:)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1))
+ XTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ EXIT
+ ELSE
+ INDV=INDV+INDVM
+ YCAR = ADJUSTL(YCART(INDVM+1:INDV-1))
+ NBTIMEDIA(KJ,:) = NBTIMEDIA(KJ,:)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1))
+ XTIMEDIA(NBTIMEDIA(KJ,:),KJ,:)=XTIMEDIA(NBTIMEDIA(KJ,1),KJ,1)
+ END IF
+ ENDDO
+
+
+ END IF
+!
+END IF
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+if (nverbia >0) then
+print *,' end of RESOLVT '
+print *,' LTIMEDIALL(KJ,1) ',LTIMEDIALL(KJ,1)
+print *,' NBTIMEDIA(KJ,1) ',NBTIMEDIA(KJ,1)
+print *,' NTIMEDIA ',(NTIMEDIA(J,KJ,1),J=1,NBTIMEDIA(KJ,1))
+print *,' XTIMEDIA ',(XTIMEDIA(J,KJ,1),J=1,NBTIMEDIA(KJ,1))
+endif
+RETURN
+END SUBROUTINE RESOLVT
+! ######spl
+ MODULE MODI_RESOLVL
+! ###################
+!
+INTERFACE
+!
+SUBROUTINE RESOLVL(HCARIN,K,OLOGIC)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: K
+LOGICAL :: OLOGIC
+END SUBROUTINE RESOLVL
+!
+END INTERFACE
+!
+END MODULE MODI_RESOLVL
+! ###################################
+ SUBROUTINE RESOLVL(HCARIN,K,OLOGIC)
+! ###################################
+!
+!!**** *RESOLVL* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODN_NCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: K
+LOGICAL :: OLOGIC
+!
+!* 0.1 Local variables
+! ---------------
+
+CHARACTER(LEN=3) :: YC3
+INTEGER :: ILENC
+INTEGER :: J,JM, I
+
+!
+!------------------------------------------------------------------------------
+ILENC=LEN_TRIM(HCARIN)
+
+if(nverbia >0)then
+ print *,' HCARIN K RESOLVL ',HCARIN,K
+endif
+DO J=K,ILENC
+ IF(HCARIN(J:J) == '=')EXIT
+ENDDO
+
+JM=J+1
+YC3=' '
+I=0
+
+if(nverbia >0)then
+print *,' RESOLVL JM,ILENC ',JM,ILENC
+endif
+DO J=JM,ILENC
+ IF(HCARIN(J:J) == 'T'.OR.HCARIN(J:J) == 'F')THEN
+ YC3(1:1)=HCARIN(J:J)
+ I=1
+ EXIT
+ ENDIF
+ENDDO
+
+IF(I == 0)THEN
+print *,' PB AVEC LA VALEUR FOURNIE DE ',HCARIN(1:JM-2),' ', &
+ HCARIN(1:LEN_TRIM(HCARIN)),' VERIFIEZ SA VALEUR '
+ RETURN
+ENDIF
+if(nverbia >0)then
+ print *,' RESOLVL YC3 ',YC3
+endif
+IF(I == 1)READ(YC3(1:1),'(L1)')OLOGIC
+print *,HCARIN(1:JM-2),' FOURNI ',OLOGIC
+RETURN
+END SUBROUTINE RESOLVL
+! ######spl
+ MODULE MODI_RESOLVZ
+! ###################
+!
+INTERFACE
+!
+SUBROUTINE RESOLVZ(HCARIN,KINDZ,KJ)
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KINDZ, KJ
+END SUBROUTINE RESOLVZ
+!
+END INTERFACE
+!
+END MODULE MODI_RESOLVZ
+! ###################################
+ SUBROUTINE RESOLVZ(HCARIN,KINDZ,KJ)
+! ###################################
+!
+!!**** *RESOLVZ* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+INTEGER :: KINDZ, KJ
+!
+!* 0.1 Local variables
+! ---------------
+
+CHARACTER(LEN=80) :: YCART
+CHARACTER(LEN=20) :: YCAR
+INTEGER :: ILENC, ILENCART
+INTEGER :: INDTF, INDTO, INDBY, INDV, INDVM
+INTEGER :: ICAS, J
+
+!
+!------------------------------------------------------------------------------
+INDTF = 0
+INDTO = 0
+INDBY = 0
+INDV = 0
+ICAS = 0
+
+NBLVLZDIA(KJ)=0
+NLVLZDIA(:,KJ)=0
+XLVLZDIA(:,KJ)=0.
+LZINCRDIA(KJ)=.FALSE.
+
+ILENC = LEN(HCARIN)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ INDTO = INDEX(HCARIN(KINDZ+3:ILENC),'_TO_')
+ INDBY = INDEX(HCARIN(KINDZ+3:ILENC),'_BY_')
+ INDTF = INDEX(HCARIN(KINDZ+3:ILENC),'_')
+ IF(INDTO /= 0)THEN
+ IF(INDTF < INDTO)THEN
+!
+! ICAS = 1 Niveau Z unique ou plusieurs separes par des virgules
+!
+ INDTO=0;INDBY=0
+ ICAS = 1
+ ELSE IF(INDTF == INDTO)THEN
+!
+! ICAS = 3 NivZ1 _TO_ NivZn _BY_ NivZx
+!
+ IF(INDBY /= 0)THEN
+ DO J=INDTO+4+KINDZ+3,INDBY+KINDZ+3
+ IF(HCARIN(J:J) == '_')THEN
+ IF(HCARIN(J:J+3) == '_BY_')THEN
+ EXIT
+ ELSE
+ INDBY=0
+ EXIT
+ END IF
+ END IF
+ ENDDO
+ END IF
+ IF(INDBY /= 0)THEN
+ INDTF=INDEX(HCARIN(KINDZ+3+INDBY+4:ILENC),'_')
+ IF(INDTF /= 0)INDTF=INDTF+INDBY+4
+ ICAS = 3
+ LZINCRDIA(KJ) = .TRUE.
+ ELSE
+!
+! ICAS = 2 NivZ1 _TO_ NivZn
+!
+ INDTF=INDEX(HCARIN(KINDZ+3+INDTO+4:ILENC),'_')
+ IF(INDTF /= 0)INDTF=INDTF+INDTO+4
+ ICAS = 2
+ LZINCRDIA(KJ) = .TRUE.
+ END IF
+ END IF
+ ELSE
+ ICAS = 1
+ END IF
+IF(INDTF == 0)THEN
+ INDTF = ILENC
+ELSE
+ INDTF = INDTF+KINDZ+3-1-1
+END IF
+
+
+YCART(1:LEN(YCART))=' '
+YCAR(1:LEN(YCAR))=' '
+!
+! Extraction de la partie Niveaux Z dans YCART(1:ILENCART)
+!
+!print *,' KINDZ INDTF ',KINDZ,INDTF
+YCART = ADJUSTL(HCARIN(KINDZ+3:INDTF))
+ILENCART = LEN_TRIM(YCART)
+!print *,' YCART ',ILENCART,' ',YCART
+
+! Recherche a nouveau des chaines de car. _TO_ , _BY_ et d'une virgule
+! par rapport au debut de YCART
+
+INDTO = INDEX(YCART,'_TO_')
+INDBY = INDEX(YCART,'_BY_')
+INDV = INDEX(YCART(1:ILENCART),',')
+IF(ICAS == 1 .AND. INDV == 0)ICAS=0
+!
+! Expression des niveaux Z par mots-cles (LVLZ1....)
+!
+IF(YCART(1:4) == 'LVLZ')THEN
+!print *,' YCART(1:4) ',YCART(1:4),' ICAS ',ICAS
+
+ NBLVLZDIA(KJ)=NBLVLZDIA(KJ)+1
+ SELECT CASE(ICAS)
+ CASE(1)
+!print *,' INDV YCART(5:5) ',INDV,YCART(5:5)
+ IF(INDV-4-1 == 1)READ(YCART(5:5),'(I1)')NLVLZDIA(NBLVLZDIA(KJ),KJ)
+ IF(INDV-4-1 == 2)READ(YCART(5:6),'(I2)')NLVLZDIA(NBLVLZDIA(KJ),KJ)
+ DO J = 1,100
+ INDVM=INDV
+ INDV=0
+ INDV=INDEX(YCART(INDVM+1:ILENCART),',')
+ IF(INDV == 0)THEN
+ NBLVLZDIA(KJ)=NBLVLZDIA(KJ)+1
+ IF(ILENCART-(INDVM+4) == 1)READ(YCART(INDVM+4+1:INDVM+4+1),'(I1)')NLVLZDIA(NBLVLZDIA(KJ),KJ)
+ IF(ILENCART-(INDVM+4) == 2)READ(YCART(INDVM+4+1:ILENCART),'(I2)')NLVLZDIA(NBLVLZDIA(KJ),KJ)
+ EXIT
+ ELSE
+ INDV=INDV+INDVM
+ NBLVLZDIA(KJ)=NBLVLZDIA(KJ)+1
+ IF(INDV-(INDVM+4)-1 == 1)READ(YCART(INDVM+4+1:INDVM+4+1),'(I1)')NLVLZDIA(NBLVLZDIA(KJ),KJ)
+ IF(INDV-(INDVM+4)-1 == 2)READ(YCART(INDVM+4+1:INDV-1),'(I2)')NLVLZDIA(NBLVLZDIA(KJ),KJ)
+ END IF
+ ENDDO
+
+ CASE(2)
+ IF(INDTO-4-1 == 1)READ(YCART(5:5),'(I1)')NLVLZDIA(NBLVLZDIA(KJ),KJ)
+ IF(INDTO-4-1 == 2)READ(YCART(5:6),'(I2)')NLVLZDIA(NBLVLZDIA(KJ),KJ)
+ NBLVLZDIA(KJ)=NBLVLZDIA(KJ)+1
+ IF(ILENCART-(INDTO+3+4) == 1)READ(YCART(INDTO+3+4+1:INDTO+3+4+1),'(I1)')NLVLZDIA(NBLVLZDIA(KJ),KJ)
+ IF(ILENCART-(INDTO+3+4) == 2)READ(YCART(INDTO+3+4+1:ILENCART),'(I2)')NLVLZDIA(NBLVLZDIA(KJ),KJ)
+! 1 seul temps
+ CASE DEFAULT
+ IF(ILENCART-4 == 1)READ(YCART(5:5),'(I1)')NLVLZDIA(NBLVLZDIA(KJ),KJ)
+ IF(ILENCART-4 == 2)READ(YCART(5:6),'(I2)')NLVLZDIA(NBLVLZDIA(KJ),KJ)
+
+ END SELECT
+ print *,' RESOLVZ ICAS '
+ print *,' NBLVLZDIA ',NBLVLZDIA(KJ)
+ print *,' NLVLZDIA ',(NLVLZDIA(J,KJ),J=1,NBLVLZDIA(KJ))
+ print *,' XLVLZDIA ',(XLVLZDIA(J,KJ),J=1,NBLVLZDIA(KJ))
+ RETURN
+ELSE
+
+!
+! Expression des niveaux Z en numerique
+!
+ IF(INDV == 0)THEN
+
+! Cas _TO_ _BY_
+
+ IF(INDTO /= 0)THEN
+ YCAR = ADJUSTL(YCART(1:INDTO-1))
+ NBLVLZDIA(KJ) = NBLVLZDIA(KJ)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XLVLZDIA(NBLVLZDIA(KJ),KJ))
+ IF(INDBY /= 0)THEN
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDTO+4:INDBY-1))
+ NBLVLZDIA(KJ) = NBLVLZDIA(KJ)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XLVLZDIA(NBLVLZDIA(KJ),KJ))
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDBY+4:ILENCART))
+ NBLVLZDIA(KJ) = NBLVLZDIA(KJ)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XLVLZDIA(NBLVLZDIA(KJ),KJ))
+ ELSE
+ YCAR(1:LEN(YCAR))=' '
+ YCAR = ADJUSTL(YCART(INDTO+4:ILENCART))
+ NBLVLZDIA(KJ) = NBLVLZDIA(KJ)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XLVLZDIA(NBLVLZDIA(KJ),KJ))
+ END IF
+ ELSE
+
+! Cas un seul niveau Z en fin de chaine de car. HCARIN ou au milieu
+
+ IF(ILENCART > 9)THEN
+ print *,' PB ecriture temps '
+ STOP
+ ELSE
+ YCAR = ADJUSTL(YCART(1:ILENCART))
+ NBLVLZDIA(KJ) = NBLVLZDIA(KJ)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XLVLZDIA(NBLVLZDIA(KJ),KJ))
+ END IF
+
+ END IF
+
+ ELSE
+
+! Presence de virgules
+
+ YCAR = ADJUSTL(YCART(1:INDV-1))
+ NBLVLZDIA(KJ) = NBLVLZDIA(KJ)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XLVLZDIA(NBLVLZDIA(KJ),KJ))
+ DO J = 1,100
+ INDVM=INDV
+ INDV = 0
+ YCAR(1:LEN(YCAR))=' '
+ INDV = INDEX(YCART(INDVM+1:ILENCART),',')
+! print *,' INDV ',INDV
+ IF(INDV == 0)THEN
+ YCAR = ADJUSTL(YCART(INDVM+1:ILENCART))
+ NBLVLZDIA(KJ) = NBLVLZDIA(KJ)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XLVLZDIA(NBLVLZDIA(KJ),KJ))
+ EXIT
+ ELSE
+ INDV=INDV+INDVM
+ YCAR = ADJUSTL(YCART(INDVM+1:INDV-1))
+ NBLVLZDIA(KJ) = NBLVLZDIA(KJ)+1
+ CALL CAREAL(YCAR(1:LEN_TRIM(YCAR)),XLVLZDIA(NBLVLZDIA(KJ),KJ))
+ END IF
+ ENDDO
+
+
+ END IF
+!
+END IF
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+print *,' RESOLVZ '
+print *,' NBLVLZDIA ',NBLVLZDIA(KJ)
+print *,' NLVLZDIA ',(NLVLZDIA(J,KJ),J=1,NBLVLZDIA(KJ))
+print *,' XLVLZDIA ',(XLVLZDIA(J,KJ),J=1,NBLVLZDIA(KJ))
+RETURN
+END SUBROUTINE RESOLVZ
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/rota.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/rota.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0be9097955b386111cad1cd62bda37f1fb041427
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/rota.f90
@@ -0,0 +1,173 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/post/s.rota.f90, Version:1.2, Date:98/10/02, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ######spl
+ SUBROUTINE ROTA(PTEM1,PTEMV)
+! ############################
+!
+!!**** *ROTA* - For the vertical oblique cross-sections, rotates the wind
+!!**** components from the model frame to the section natural frame
+!!
+!! PURPOSE
+!! -------
+! In the case of oblique vertical cross-sections, computes the
+! longitudinal and transverse components of the wind with respect
+! to the section plane.
+!
+!!** METHOD
+!! ------
+!! To make a physically meanigfull rotation, the u and v components
+!! of the wind are interpolated back to be colocated at the mass gridpoint.
+!!
+!! EXTERNAL
+!! --------
+!! COS ! trigonometric functions
+!! SIN !
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist (former PARA common)
+!! NLANGLE : Angle between X Meso-NH axis and
+!! cross-section direction in degrees
+!! (Integer value anticlockwise)
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 13/01/95
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODN_PARA
+USE MODD_DEFCV
+USE MODD_MEMGRIUV
+USE MODD_RESOLVCAR
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments and results
+!
+ ! On entry, model x-y components
+ ! of the wind. 1 stands for U,
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PTEM1 ! V stands for V. On return,
+REAL, DIMENSION(:,:), INTENT(INOUT) :: PTEMV ! longitudinal, transverse
+ ! wind components with respect
+ ! to the current olblique
+ ! vertical section plane.
+!
+!* 0.2 Local variables
+!
+INTEGER :: IWIU, IWJU
+INTEGER :: J, JA
+!
+REAL :: ZU, ZV
+REAL :: ZRANGLE, ZCANGLE, ZSANGLE
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTING THE LONGITUDINAL AND TRANSVERSE COMPONENTS
+! ----------------------------------------------------
+!
+!* 1.1 Array sizes calculations
+!
+IWIU=SIZE(PTEM1,1)
+IWJU=SIZE(PTEM1,2)
+!
+!* 1.2 Wind component are interpolated back to the mass point:
+!* only colocated u-v components can be mixed in a rotation
+!* in a physically meaningfull way to obtain lonitudinal and
+!* transverse components
+!
+!! Nov 2001 sauf si ce n'est deja fait
+IF(NGRIU == 1 .AND. NGRIV == 1)THEN
+ print *,' ** Rota NGRIU=',NGRIU,' NGRIV=',NGRIV,' pas de repositionnement sur la grille de masse (deja fait) GRP=',CGROUP
+ELSE
+!! Nov 2001 sauf si ce n'est deja fait
+PTEM1(1:IWIU-1,:)=.5*(PTEM1(1:IWIU-1,:)+PTEM1(2:IWIU,:))
+PTEM1(IWIU,:)=2.*PTEM1(IWIU-1,:)-PTEM1(IWIU-2,:)
+PTEMV(:,1:IWJU-1)=.5*(PTEMV(:,1:IWJU-1)+PTEMV(:,2:IWJU))
+PTEMV(:,IWJU)=2.*PTEMV(:,IWJU-1)-PTEMV(:,IWJU-2)
+!! Nov 2001 sauf si ce n'est deja fait
+ENDIF
+!! Nov 2001 sauf si ce n'est deja fait
+!
+!* 1.3 Rotation to the natural frame of the oblique section
+!
+!!! Essai Nov 2001 pour prise en compte PH A suivre... 29/11/2001
+IF(((LCH.AND.LULM).OR.(LCH.AND.LULT).OR.(LCH.AND.LVTM).OR. &
+ (LCH.AND.LVTT)) .AND. .NOT.LCV)THEN
+!IF((LCH.AND.LULM).OR.(LCH.AND.LULT).OR.(LCH.AND.LVTM).OR. &
+! (LCH.AND.LVTT))THEN
+!!! Essai Nov 2001 pour prise en compte PH A suivre... 29/11/2001
+ ZRANGLE=XANGULVT*ACOS(-1.)/180.
+ELSE
+IF(LDEFCV2CC)THEN
+ ZRANGLE=XANGLECV
+ELSE
+ ZRANGLE=FLOAT(NLANGLE)*ACOS(-1.)/180. ! NLANGLE is the section direction
+ENDIF
+ENDIF
+ZCANGLE=COS(ZRANGLE)
+ZSANGLE=SIN(ZRANGLE)
+!!! Essai Nov 2001 pour prise en compte PH A suivre... 29/11/2001
+IF(((LCH.AND.LULM).OR.(LCH.AND.LULT).OR.(LCH.AND.LVTM).OR. &
+ (LCH.AND.LVTT)) .AND. .NOT.LCV)THEN
+!IF((LCH.AND.LULM).OR.(LCH.AND.LULT).OR.(LCH.AND.LVTM).OR. &
+! (LCH.AND.LVTT))THEN
+!!! Essai Nov 2001 pour prise en compte PH A suivre... 29/11/2001
+ IF(XANGULVT == 0. .OR. XANGULVT == 180.)ZSANGLE=0.
+ IF(XANGULVT == 90. .OR. XANGULVT == 270.)ZCANGLE=0.
+ELSE
+IF(.NOT.LDEFCV2CC)THEN
+ IF(NLANGLE.EQ.0.OR.NLANGLE.EQ.180)ZSANGLE=0.
+ IF(NLANGLE.EQ.90.OR.NLANGLE.EQ.270)ZCANGLE=0.
+ELSE
+ IF(XANGLECV == 0. .OR. XANGLECV/ACOS(-1.)*180. == 180.)ZSANGLE=0.
+ IF(XANGLECV/ACOS(-1.)*180. == 90. .OR.XANGLECV/ACOS(-1.)*180. == 270.)ZCANGLE=0.
+ENDIF
+ENDIF
+IF(nverbia > 0)THEN
+ print *,' ** rota XANGULVT,ZSANGLE,ZCANGLE ',XANGULVT,ZSANGLE,ZCANGLE
+endif
+DO J=1,IWIU
+DO JA=1,IWJU
+ZU=PTEM1(J,JA)
+ZV=PTEMV(J,JA)
+PTEM1(J,JA)=ZU*ZCANGLE+ZV*ZSANGLE
+PTEMV(J,JA)=-ZU*ZSANGLE+ZV*ZCANGLE
+ENDDO
+ENDDO
+!
+!* 1.4 Rotated components re-interpolated back to their nominal
+!* Meso-NH locations
+!
+! Suppression debut Avril 99 a la demande de Joel, Nicole et les autres..
+!PTEM1(2:IWIU,:)=.5*(PTEM1(1:IWIU-1,:)+PTEM1(2:IWIU,:))
+!PTEM1(1,:)=2.*PTEM1(2,:)-PTEM1(3,:)
+!PTEMV(:,2:IWJU)=.5*(PTEMV(:,1:IWJU-1)+PTEMV(:,2:IWJU))
+!PTEMV(:,1)=2.*PTEMV(:,2)-PTEMV(:,3)
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE ROTA
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/rotauw.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/rotauw.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b345bd465307c671f69a5ce57626df9cf1391c29
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/rotauw.f90
@@ -0,0 +1,119 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/post/s.rotauw.f90, Version:1.2, Date:98/10/02, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ######spl
+ SUBROUTINE ROTAUW(PTEM1,PTEMV)
+! ##############################
+!
+!!**** *ROTAUW* - For the vertical oblique cross-sections, rotates the wind
+!!**** components from the model frame to the section natural frame
+!!
+!! PURPOSE
+!! -------
+! In the case of oblique vertical cross-sections, computes the
+! longitudinal and transverse components of the wind with respect
+! to the section plane.
+!
+!!** METHOD
+!! ------
+!! To make a physically meanigfull rotation, the u and v components
+!! of the wind are interpolated back to be colocated at the mass gridpoint.
+!!
+!! EXTERNAL
+!! --------
+!! COS ! trigonometric functions
+!! SIN !
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist (former PARA common)
+!! NLANGLE : Angle between X Meso-NH axis and
+!! cross-section direction in degrees
+!! (Integer value anticlockwise)
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 13/01/95
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODN_PARA
+USE MODD_DEFCV
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments and results
+!
+ ! On entry, model x-y components
+ ! of the wind. 1 stands for U,
+REAL, DIMENSION(:), INTENT(INOUT) :: PTEM1 ! V stands for V. On return,
+REAL, DIMENSION(:), INTENT(INOUT) :: PTEMV ! longitudinal, transverse
+ ! wind components with respect
+ ! to the current olblique
+ ! vertical section plane.
+!
+!* 0.2 Local variables
+!
+INTEGER :: IWIU
+INTEGER :: J
+!
+REAL :: ZU, ZV
+REAL :: ZRANGLE, ZCANGLE, ZSANGLE
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. COMPUTING THE LONGITUDINAL AND TRANSVERSE COMPONENTS
+! ----------------------------------------------------
+!
+!* 1.1 Array sizes calculations
+!
+IWIU=SIZE(PTEM1,1)
+!
+!* 1.2 Rotation to the natural frame of the oblique section
+!
+IF(LDEFCV2CC)THEN
+ ZRANGLE=XANGLECV
+ELSE
+ZRANGLE=FLOAT(NLANGLE)*ACOS(-1.)/180. ! NLANGLE is the section direction
+ENDIF
+ZCANGLE=COS(ZRANGLE)
+ZSANGLE=SIN(ZRANGLE)
+IF(.NOT.LDEFCV2CC)THEN
+ IF(NLANGLE.EQ.0.OR.NLANGLE.EQ.180)ZSANGLE=0.
+ IF(NLANGLE.EQ.90.OR.NLANGLE.EQ.270)ZCANGLE=0.
+ELSE
+ IF(XANGLECV == 0. .OR. XANGLECV/ACOS(-1.)*180. == 180.)ZSANGLE=0.
+ IF(XANGLECV/ACOS(-1.)*180. == 90. .OR.XANGLECV/ACOS(-1.)*180. == 270.)ZCANGLE=0.
+ENDIF
+DO J=1,IWIU
+ZU=PTEM1(J)
+ZV=PTEMV(J)
+PTEM1(J)=ZU*ZCANGLE+ZV*ZSANGLE
+PTEMV(J)=-ZU*ZSANGLE+ZV*ZCANGLE
+ENDDO
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE ROTAUW
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/subspxy.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/subspxy.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e9e5290bee51fc888e9c7b44079d10672bed6882
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/subspxy.f90
@@ -0,0 +1,2407 @@
+! #########################
+ SUBROUTINE SUBSPXY(KLOOP)
+! #########################
+!
+!
+!!
+!! PURPOSE
+!! -------
+!
+! Traite les informations de type SPXY et envoyees sous forme
+! d'un vecteur de coefficients spectraux ou d'un plan
+! Partie retiree de OPER_PROCESS devenue trop volumineuse pour
+! la compilation
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!!
+!! NIOFFD : Label normalisation (=0 none, =/=0 active)
+!! NULBLL : Nb of contours between 2 labelled contours
+!! NIOFFM : =0 --> message at picture bottom
+!! =/= 0 --> no message
+!! NIOFFP : Special point value detection
+!! (=0 none, =/=0 active)
+!! NHI : Extrema detection
+!! (=0 --> H+L, <0 nothing)
+!! NINITA : For streamlimes
+!! NINITB : Not yet implemented
+!! NIGRNC : Not yet implemented
+!! NDOT : Line style
+!! (=0|1|1023|65535 --> solid lines;
+!! <0 --> solid lines for positive values and
+!! dotted lines(ABS(NDOT))for negative values;
+!! >0 --> dotted lines(ABS(NDOT)) )
+!! NIFDC : Coastline data style (0 none, 1 NCAR, 2 IGN)
+!! NLPCAR : Number of land-mark points to be plotted
+!! NIMNMX : Contour selection option
+!! (=-1 Min, max and inc. automatically set;
+!! =0 Min, max automatically set; inc. given;
+!! >0 Min, max, inc. given by user)
+!! NISKIP : Rate for drawing velocity vectors
+!! CTYPHOR : Horizontal cross-section type
+!! (='K' --> model level section;
+!! ='Z' --> constant-altitude section;
+!! ='P' --> isobar section (planned)
+!! ='T' --> isentrope section (planned)
+!! XSPVAL : Special value
+!! XSIZEL : Label size
+!! XLATCAR, XLONCAR : Lat. and Long. of land-mark points
+!! LXY : If =.TRUE., plots a grid-mesh stencil background
+!! LXZ : If =.TRUE., plots a model-level stencil background
+!!
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist
+!! (former PARA common)
+!!
+!! XIDEBCOU, XJDEBCOU : Origin of a vertical cross-section
+!! in cartesian (or conformal) real values
+!! XHMIN : Altitude of the vert. cross-section
+!! bottom (in meters above sea-level)
+!! XHMAX : Altitude of the vert. cross-section
+!! top (in meters above sea-level)
+!!
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/05/00
+!! Updated PM 02/12/94
+!! VM 05/04/06 abscisse:2pi/j*OMEGA ET j*OMEGA
+!! et Module (apres Phase dans les cas PHALO,PHAO)
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODD_FILES_DIACHRO
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODI_TRACEH_FORDIACHRO
+USE MODD_TYPE_AND_LH
+USE MODD_DIM1
+USE MODD_TIT
+USE MODD_GRID1
+USE MODD_NMGRID
+USE MODD_CVERT
+USE MODD_MASK3D
+USE MODD_TITLE
+USE MODD_PARAMETERS
+USE MODD_EXPERIM
+USE MODN_NCAR
+USE MODN_PARA
+USE MODI_PRECOU_FORDIACHRO
+USE MODI_TRACEV_FORDIACHRO
+!USE MODI_VARFCT
+!USE MODI_PVFCT
+!USE MODI_CLOSF
+USE MODI_LOADUNITIT
+!USE MODI_TRAPRO_FORDIACHRO
+USE MODD_COORD
+USE MODD_CONF
+USE MODD_SUPER
+USE MODD_CST
+USE MODD_PVT
+USE MODD_DEFCV
+USE MODE_GRIDPROJ
+
+IMPLICIT NONE
+
+INTERFACE
+ SUBROUTINE IMCOU_FORDIACHRO(PTABV,PINT,HLEGEND,HTEXT)
+ REAL,DIMENSION(:,:) :: PTABV
+ REAL :: PINT
+ CHARACTER(LEN=*) :: HTEXT, HLEGEND
+ END SUBROUTINE IMCOU_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE INTERP_FORDIACHRO(KLREF,KD,KF,PTAB,PTABREF)
+ REAL,DIMENSION(:,:,:), INTENT(IN) :: PTAB
+ REAL,DIMENSION(SIZE(PTAB,1),SIZE(PTAB,2)) :: PTABREF
+ INTEGER :: KLREF
+ END SUBROUTINE INTERP_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE IMAGE_FORDIACHRO(PTAB,KLREF,PTABINT,KNHI,KNDOT,HTEXTE)
+ CHARACTER(LEN=*) :: HTEXTE
+ REAL :: PTABINT
+ REAL,DIMENSION(:,:) :: PTAB
+ INTEGER :: KNHI, KNDOT, KLREF
+ END SUBROUTINE IMAGE_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE TRAXY(PTEMX,PTEMY,KLOOP,HTITX,HTITY,PTIMED,PTIMEF)
+ INTEGER :: KLOOP
+ REAL,DIMENSION(:) :: PTEMX, PTEMY
+ REAL :: PTIMED, PTIMEF
+ CHARACTER(LEN=*) :: HTITX, HTITY
+ END SUBROUTINE TRAXY
+END INTERFACE
+COMMON/TEMV/XZWORKZ,XZZDS,NINX,NINY
+COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+#include "big.h"
+REAL,DIMENSION(N2DVERTX,2500) :: XZWORKZ
+!REAL,DIMENSION(1000,400) :: XZWORKZ
+REAL,DIMENSION(N2DVERTX) :: XZZDS
+!REAL,DIMENSION(1000) :: XZZDS
+INTEGER :: NINX, NINY
+LOGICAL :: LVERT, LHOR, LPT, LXABS
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+INTEGER :: KLOOP
+
+!
+!* 0.1 Local variables
+! ---------------
+!
+INTEGER :: J, JJ
+INTEGER :: II, IJ, IK, IKU, IKB, IKE, IIU, IJU
+INTEGER :: JLOOPP, JLOOPN, JLOOPT, JLOOPK, JLOOPZ
+INTEGER :: IZ, IOMEGA, IEGAL
+INTEGER :: ILENT, ILENU
+INTEGER :: ISUP, IJSUP, IINF, IJINF
+INTEGER :: IIB, IIE, IJB, IJE, IL
+INTEGER :: ID
+INTEGER,SAVE :: INUM, IRESP
+
+REAL :: ZWL, ZWR, ZWB, ZWT
+REAL :: ZVL, ZVR, ZVB, ZVT
+REAL :: ZOMEGA
+REAL :: ZMIN, ZMAX, ZZMIN, ZZMAX
+REAL :: ZXPOSTITT1, ZXYPOSTITT1, ZXPOSTITT2, ZXYPOSTITT2
+REAL :: ZXPOSTITT3, ZXYPOSTITT3
+REAL :: ZXPOSTITB1, ZXYPOSTITB1, ZXPOSTITB2, ZXYPOSTITB2
+REAL :: ZXPOSTITB3, ZXYPOSTITB3
+
+
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: ZWORK3D
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZTEMCV
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZTEM1, ZTEMV
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZTEM1D, ZWORKZ, ZTEMLO
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZTE, ZWO
+
+CHARACTER(LEN=40) :: YTEXTE
+!CHARACTER(LEN=LEN(CTITGAL)) :: YTITGAL
+CHARACTER(LEN=4) :: YC5S3='-5/3'
+CHARACTER(LEN=16) :: YTITX, YTITY
+CHARACTER(LEN=60) :: YTEM
+!CHARACTER(LEN=60) :: YTEMP
+
+LOGICAL :: GOMEGAZOK, GOMEGAXOK, GOMEGAYOK
+!------------------------------------------------------------------------------
+
+!*****************************************************************************
+!*****************************************************************************
+! CASE('SPXY')
+
+ print *,'SUBSPSY entree NIMAX NJMAX NIL NJL NIH NJH NKL NKH ',NIMAX,NJMAX,NIL,NJL,NIH,NJH,NKL,NKH
+ GOMEGAXOK=.FALSE.
+ GOMEGAYOK=.FALSE.
+ GOMEGAZOK=.FALSE.
+ LSPX=.FALSE.
+ LSPY=.FALSE.
+ LSPZ=.FALSE.
+ LSPSECTXY=.FALSE.
+ LSPSECTXZ=.FALSE.
+ LSPSECTYZ=.FALSE.
+ IIB=1+JPHEXT; IIE=NIMAX+JPHEXT
+ IJB=1+JPHEXT; IJE=NJMAX+JPHEXT
+ IKU=NKMAX+2*JPVEXT
+ IKB=1+JPVEXT; IKE=IKU-JPVEXT
+
+ II=SIZE(XVAR,1)
+ IJ=SIZE(XVAR,2)
+ IK=SIZE(XVAR,3)
+
+!!!!! UNIDIMENSIONNELS (Eventuellement sur plusieurs niveaux)
+ IF(.NOT. LSPSECT)THEN !iiiiiiiiiiiiiiiiiiiiiiii
+!*************************************************************************
+! PV // Z
+!*************************************************************************
+ IF(II == 1 .AND. IJ == 1 .AND. IK /= 1)THEN
+ print *,' unidimensionnel1: II,IJ,IK=',II,IJ,IK
+
+ LSPZ=.TRUE.
+ ALLOCATE(ZTEM1D(SIZE(XVAR,3)),ZWORKZ(SIZE(XVAR,3)))
+
+!+++++++++ Boucle processus +++++++++++++++++++++++++++++++++++
+
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+ CALL LOADUNITIT(JLOOPP,KLOOP)
+ IOMEGA=INDEX(CCOMMENT(NLOOPP),'DOMEGAZ')
+ IF(IOMEGA == 0)THEN
+ IOMEGA=INDEX(CCOMMENT(NLOOPP),'Domegaz')
+ IF(IOMEGA == 0)THEN
+ IOMEGA=INDEX(CCOMMENT(NLOOPP),'domegaz')
+ ENDIF
+ ENDIF
+ IF(IOMEGA == 0)THEN
+ PRINT *,' Delta OmegaZ (pulsation) non trouve dans le champ commentaire '
+ PRINT *,' On trace en indices de tableau'
+ DO J=1,SIZE(ZTEM1D)
+ ZTEM1D(J)=J
+ ENDDO
+ GOMEGAZOK=.FALSE.
+ ZOMEGA=1.
+
+ ELSE
+
+ IEGAL=INDEX(CCOMMENT(NLOOPP)(IOMEGA:LEN_TRIM(CCOMMENT(NLOOPP))),'=')
+ READ(CCOMMENT(NLOOPP)(IOMEGA+IEGAL:LEN_TRIM(CCOMMENT(NLOOPP))),*)XOMEGAZ
+
+ IF(XOMEGAZ == 0.)THEN
+ PRINT *,' Delta OmegaZ (pulsation) = 0'
+ PRINT *,' On trace en indices de tableau'
+ DO J=1,SIZE(ZTEM1D)
+ ZTEM1D(J)=J
+ ENDDO
+ GOMEGAZOK=.FALSE.
+ ZOMEGA=1.
+
+ ELSE
+
+ DO J=1,SIZE(ZTEM1D)
+ ZTEM1D(J)=J*XOMEGAZ
+ ENDDO
+ GOMEGAZOK=.TRUE.
+ ZOMEGA=XOMEGAZ
+ ENDIF
+ ENDIF
+
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN !TTTTTTTTTTTTTTTTTTTTTT
+
+!+++++++++ Boucle temps +++++++++++++++++++++++++++++++++++
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+ CALL RESOLV_TIMES(NLOOPT)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NLOOPT,1)
+! Partie reelle
+ ZWORKZ(:)=XVAR(1,1,:,NLOOPT,1,NLOOPP)
+ ZMIN=MINVAL(ZTEM1D);ZMAX=MAXVAL(ZTEM1D)
+ ZZMIN=MINVAL(ZWORKZ);ZZMAX=MAXVAL(ZWORKZ)
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ CALL AGSETF('FRA.',2.)
+ CALL AGSETC('LAB/NAME.','B')
+ CALL AGSETR('LAB/SU.',1.)
+ CALL AGSETC('LAB/NAME.','L')
+ CALL AGSETR('LAB/SU.',1.)
+ CALL PCSETC('FC',':')
+ IF(GOMEGAZOK)THEN !......................
+
+!------
+! _SPO_
+!------
+ IF(LSPO)THEN
+
+ CALL AGSETF('SET.',4.)
+! Traitement de la partie reelle
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PGL:X:PRL:Z:',.015,0.,1.)
+ call plchhq(0., .85,':PRU:(R):',.015,0.,-1.)
+
+! Traitement de la partie imaginaire
+ IF(SIZE(XVAR,5) == 2)THEN
+ CALL FRAME
+ ZWORKZ(:)=XVAR(1,1,:,NLOOPT,2,NLOOPP)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PGL:X:PRL:Z:',.015,0.,1.)
+ call plchhq(0., .85,':PRU:(I):',.015,0.,-1.)
+ ENDIF
+
+!---------------
+! _OSPLO_ (/log)
+!---------------
+ ELSE IF(LOSPLO)THEN
+
+ ZMIN=LOG10(ZMIN)
+ ZMAX=LOG10(ZMAX)
+ ZZMIN=MINVAL(ZWORKZ(:)*ZOMEGA)
+ ZZMAX=MAXVAL(ZWORKZ(:)*ZOMEGA)
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(LOG10(ZTEM1D),ZWORKZ*ZOMEGA,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:Z:PRU:):',.015,0.,1.)
+ call plchhq(0., .85,':PGL:X:PRU:*(R):',.015,0.,-1.)
+
+!------------------
+! _LSPLO_ (Log/log)
+!------------------
+ ELSE IF(LSPLO)THEN
+
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ CALL AGSETF('SET.',2.)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:Z:PRU:):',.015,0.,1.)
+ call plchhq(0., .85,':PRU:Log(R):',.015,0.,-1.)
+ IF(LM5S3)THEN
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ print*,'out GETSET',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID
+ CALL SET(ZVR-.3,ZVR-.05,ZVT-.3,ZVT-.05,0.,5.,0.,5.,1)
+ CALL FRSTPT(3.,0.)
+ CALL VECTOR(0.,5.)
+ CALL GSCHH(.2)
+ CALL GTX(0.+.5,5.-.4,YC5S3)
+ ENDIF
+
+!---------------
+! _PHALO_ (/log)
+!---------------
+ ELSE IF(LPHALO)THEN
+
+ ZMIN=LOG10(ZMIN)
+ ZMAX=LOG10(ZMAX)
+ IF(SIZE(XVAR,5) < 2)THEN
+ print *,' Absence partie imaginaire. Representation impossible sous cette forme'
+ ELSE
+ ZWORKZ(:)=ATAN2(XVAR(1,1,:,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ZZMIN=MINVAL(ZWORKZ)
+ ZZMAX=MAXVAL(ZWORKZ)
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:Z:PRU:):',.015,0.,1.)
+ call plchhq(0., .85,':PRU:Phase:',.015,0.,-1.)
+ ENDIF
+
+!-------
+! _PHAO_
+!-------
+ ELSE IF(LPHAO)THEN
+
+ IF(SIZE(XVAR,5) < 2)THEN
+ print *,' Absence partie imaginaire. Representation impossible sous cette forme'
+ ELSE
+ ZWORKZ(:)=ATAN2(XVAR(1,1,:,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ZZMIN=MINVAL(ZWORKZ)
+ ZZMAX=MAXVAL(ZWORKZ)
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PGL:X:PRL:Z:',.015,0.,1.)
+ call plchhq(0., .85,':PRU:Phase:',.015,0.,-1.)
+ ENDIF
+ ENDIF
+
+ ELSE !......................
+
+ IF(LSPO)THEN
+ CALL AGSETF('SET.',4.)
+! Traitement de la partie reelle
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PRU:Ind(:PRL:Z:PRU:):',.015,0.,1.)
+ call plchhq(0., .85,':PRU:(R):',.015,0.,-1.)
+
+! Traitement de la partie imaginaire
+ IF(SIZE(XVAR,5) == 2)THEN
+ CALL FRAME
+ ZWORKZ(:)=XVAR(1,1,:,NLOOPT,2,NLOOPP)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PRU:Ind(:PRL:Z:PRU:):',.015,0.,1.)
+ call plchhq(0., .85,':PRU:(I):',.015,0.,-1.)
+ ENDIF
+ ELSE
+ ENDIF
+
+ ENDIF !......................
+ CALL FRAME
+
+!!!!!!!!!!!!!!!!!Mai 2002!!!!!!!!!!!!!!!!!!!!!!!!
+ IF(LPRINT)THEN
+
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+
+ WRITE(INUM,'(''SP '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'')')CGROUP,&
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ IF(SIZE(XVAR,5) < 2)THEN
+ IF(GOMEGAZOK)THEN
+ WRITE(INUM,'(''Partie reelle uniquement DOMEGAZ= '',F6.1)')ZOMEGA
+ ELSE
+ WRITE(INUM,'(''Partie reelle uniquement DOMEGAZ= '',F6.1,'' -> Trace en indices de grille'')')ZOMEGA
+ ENDIF
+ ELSE
+ IF(GOMEGAZOK)THEN
+ WRITE(INUM,'(''Parties reelle + imaginaire DOMEGAZ= '',F6.1)')ZOMEGA
+ ELSE
+ WRITE(INUM,'(''Parties reelle + imaginaire DOMEGAZ= '',F6.1,'' -> Trace en indices de grille'')')ZOMEGA
+ ENDIF
+ ENDIF
+ WRITE(INUM,'(''NBVAL en K '',i4 )')SIZE(ZTEM1D,1)
+
+ IF(SIZE(XVAR,5) < 2)THEN
+ WRITE(INUM,'(36(''*''))')
+ WRITE(INUM,'(10X,''X(K)'',9X,''Y(VAL.R)'')')
+ WRITE(INUM,'(36(''*''))')
+ DO J=1,SIZE(ZTEM1D,1)
+ WRITE(INUM,'(I4,2X,F8.1,(5X,E15.8))')J,ZTEM1D(J),ZWORKZ(J)
+ ENDDO
+ ELSE
+ WRITE(INUM,'(55(''*''))')
+ WRITE(INUM,'(10X,''X(=K)'',8X,''Y(VAL.R)'',11X,''Y(VAL.Im)'')')
+ WRITE(INUM,'(55(''*''))')
+ DO J=1,SIZE(ZTEM1D,1)
+ WRITE(INUM,'(I4,2X,F8.1,(5X,E15.8))')J,ZTEM1D(J),XVAR(1,1,J,NLOOPT,1,NLOOPP),ZWORKZ(J)
+ ENDDO
+ ENDIF
+ IF(SIZE(XVAR,5) < 2)THEN
+
+ WRITE(INUM,'(36(''*''))')
+ ELSE
+ WRITE(INUM,'(55(''*''))')
+ ENDIF
+
+ ENDIF
+!!!!!!!!!!!!!!!!!Mai 2002!!!!!!!!!!!!!!!!!!!!!!!!
+ ENDDO
+
+ ELSE !TTTTTTTTTTTTTTTTTTTTTT
+
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+ CALL RESOLV_TIMES(NLOOPT)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NLOOPT,1)
+! Partie reelle
+ ZWORKZ(:)=XVAR(1,1,:,NLOOPT,1,NLOOPP)
+ ZMIN=MINVAL(ZTEM1D);ZMAX=MAXVAL(ZTEM1D)
+ ZZMIN=MINVAL(ZWORKZ);ZZMAX=MAXVAL(ZWORKZ)
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ CALL AGSETF('FRA.',2.)
+ CALL AGSETC('LAB/NAME.','B')
+ CALL AGSETR('LAB/SU.',1.)
+ CALL AGSETC('LAB/NAME.','L')
+ CALL AGSETR('LAB/SU.',1.)
+ CALL PCSETC('FC',':')
+ IF(GOMEGAZOK)THEN !......................
+
+!------
+! _SPO_
+!------
+ IF(LSPO)THEN
+
+ CALL AGSETF('SET.',4.)
+! Traitement de la partie reelle
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PGL:X:PRL:Z:',.015,0.,1.)
+ call plchhq(0., .85,':PRU:(R):',.015,0.,-1.)
+
+! Traitement de la partie imaginaire
+ IF(SIZE(XVAR,5) == 2)THEN
+ ZWORKZ(:)=XVAR(1,1,:,NLOOPT,2,NLOOPP)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PGL:X:PRL:Z:',.015,0.,1.)
+ call plchhq(0., .85,':PRU:(I):',.015,0.,-1.)
+ ENDIF
+
+!---------------
+! _OSPLO_ (/log)
+!---------------
+ ELSE IF(LOSPLO)THEN
+
+ ZMIN=LOG10(ZMIN)
+ ZMAX=LOG10(ZMAX)
+ ZZMIN=MINVAL(ZWORKZ(:)*ZOMEGA)
+ ZZMAX=MAXVAL(ZWORKZ(:)*ZOMEGA)
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(LOG10(ZTEM1D),ZWORKZ*ZOMEGA,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:Z:PRU:):',.015,0.,1.)
+ call plchhq(0., .85,':PGL:X:PRU:*(R):',.015,0.,-1.)
+
+!------------------
+! _LSPLO_ (Log/log)
+!------------------
+ ELSE IF(LSPLO)THEN
+
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ CALL AGSETF('SET.',2.)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:Z:PRU:):',.015,0.,1.)
+ call plchhq(0., .85,':PRU:Log(R):',.015,0.,-1.)
+ IF(LM5S3)THEN
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ print*,'out GETSET',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID
+ CALL SET(ZVR-.3,ZVR-.05,ZVT-.3,ZVT-.05,0.,5.,0.,5.,1)
+ CALL FRSTPT(3.,0.)
+ CALL VECTOR(0.,5.)
+ CALL GSCHH(.2)
+ CALL GTX(0.+.5,5.-.4,YC5S3)
+ ENDIF
+
+!---------------
+! _PHALO_ (/log)
+!---------------
+ ELSE IF(LPHALO)THEN
+
+ ZMIN=LOG10(ZMIN)
+ ZMAX=LOG10(ZMAX)
+ IF(SIZE(XVAR,5) < 2)THEN
+ print *,' Absence partie imaginaire. Representation impossible sous cette forme'
+ ELSE
+ ZWORKZ(:)=ATAN2(XVAR(1,1,:,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ZZMIN=MINVAL(ZWORKZ)
+ ZZMAX=MAXVAL(ZWORKZ)
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:Z:PRU:):',.015,0.,1.)
+ call plchhq(0., .85,':PRU:Phase:',.015,0.,-1.)
+ ENDIF
+
+!-------
+! _PHAO_
+!-------
+ ELSE IF(LPHAO)THEN
+
+ IF(SIZE(XVAR,5) < 2)THEN
+ print *,' Absence partie imaginaire. Representation impossible sous cette forme'
+ ELSE
+ ZWORKZ(:)=ATAN2(XVAR(1,1,:,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ZZMIN=MINVAL(ZWORKZ)
+ ZZMAX=MAXVAL(ZWORKZ)
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PGL:X:PRL:Z:',.015,0.,1.)
+ call plchhq(0., .85,':PRU:Phase:',.015,0.,-1.)
+ ENDIF
+ ENDIF
+
+ ELSE !......................
+
+ IF(LSPO)THEN
+ CALL AGSETF('SET.',4.)
+! Traitement de la partie reelle
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PRU:Ind(:PRL:Z:PRU:):',.015,0.,1.)
+ call plchhq(0., .85,':PRU:(R):',.015,0.,-1.)
+
+! Traitement de la partie imaginaire
+ IF(SIZE(XVAR,5) == 2)THEN
+ ZWORKZ(:)=XVAR(1,1,:,NLOOPT,2,NLOOPP)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call plchhq(.9,.05,':PRU:Ind(:PRL:Z:PRU:):',.015,0.,1.)
+ call plchhq(0., .85,':PRU:(I):',.015,0.,-1.)
+ ENDIF
+ ELSE
+ ENDIF
+
+ ENDIF !......................
+ CALL FRAME
+
+!!!!!!!!!!!!!!!!!Mai 2002!!!!!!!!!!!!!!!!!!!!!!!!
+ IF(LPRINT)THEN
+
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+
+ WRITE(INUM,'(''SP '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'')')CGROUP,&
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+ IF(SIZE(XVAR,5) < 2)THEN
+ IF(GOMEGAZOK)THEN
+ WRITE(INUM,'(''Partie reelle uniquement DOMEGAZ= '',F6.1)')ZOMEGA
+ ELSE
+ WRITE(INUM,'(''Partie reelle uniquement DOMEGAZ= '',F6.1,'' -> Trace en indices de grille'')')ZOMEGA
+ ENDIF
+ ELSE
+ IF(GOMEGAZOK)THEN
+ WRITE(INUM,'(''Parties reelle + imaginaire DOMEGAZ= '',F6.1)')ZOMEGA
+ ELSE
+ WRITE(INUM,'(''Parties reelle + imaginaire DOMEGAZ= '',F6.1,'' -> Trace en indices de grille'')')ZOMEGA
+ ENDIF
+ ENDIF
+ WRITE(INUM,'(''NBVAL en K '',i4 )')SIZE(ZTEM1D,1)
+
+ IF(SIZE(XVAR,5) < 2)THEN
+ WRITE(INUM,'(36(''*''))')
+ WRITE(INUM,'(10X,''X(K)'',9X,''Y(VAL.R)'')')
+ WRITE(INUM,'(36(''*''))')
+ DO J=1,SIZE(ZTEM1D,1)
+ WRITE(INUM,'(I4,2X,F8.1,(5X,E15.8))')J,ZTEM1D(J),ZWORKZ(J)
+ ENDDO
+ ELSE
+ WRITE(INUM,'(55(''*''))')
+ WRITE(INUM,'(10X,''X(=K)'',8X,''Y(VAL.R)'',11X,''Y(VAL.Im)'')')
+ WRITE(INUM,'(55(''*''))')
+ DO J=1,SIZE(ZTEM1D,1)
+ WRITE(INUM,'(I4,2X,F8.1,(5X,E15.8))')J,ZTEM1D(J),XVAR(1,1,J,NLOOPT,1,NLOOPP),ZWORKZ(J)
+ ENDDO
+ ENDIF
+ IF(SIZE(XVAR,5) < 2)THEN
+
+ WRITE(INUM,'(36(''*''))')
+ ELSE
+ WRITE(INUM,'(55(''*''))')
+ ENDIF
+
+ ENDIF
+!!!!!!!!!!!!!!!!!Mai 2002!!!!!!!!!!!!!!!!!!!!!!!!
+ ENDDO
+
+!+++++++++ Boucle temps +++++++++++++++++++++++++++++++++++
+
+ ENDIF !TTTTTTTTTTTTTTTTTTTTTT
+ ENDDO
+
+!+++++++++ Boucle processus +++++++++++++++++++++++++++++++++++
+
+ DEALLOCATE(ZWORKZ,ZTEM1D)
+
+!*************************************************************************
+! PH // X ou // Y
+!*************************************************************************
+ ELSE IF((II /= 1 .AND. IJ == 1) .OR. (II == 1 .AND. IJ /= 1))THEN
+! ELSE IF(II /= 1 .AND. IJ == 1 .AND. IK == 1)THEN
+ print *,' unidimensionnel2: II,IJ,IK=',II,IJ,IK
+
+ IF(IJ == 1)THEN
+! Disposition particuliere pour l'exploitation d'un fichier mal enregistre
+! Juin 2001 c.a.d que le vecteur// Y est sur l'indice 1 de XVAR alors que
+! NIL=NIH et NJL =/= NJH
+ IF(NJL == NJH)THEN
+! Cas normal
+ LSPX=.TRUE.
+ ELSE
+! Cas anormal
+! Disposition particuliere pour le traitement des vecteurs // Y mal enreg.
+ LSPY=.TRUE.
+ ENDIF
+ ELSEIF(II == 1)THEN
+ LSPY=.TRUE.
+ ENDIF
+ IF(LSPX)THEN
+ print*,'cas LPSX=',LSPX
+ ALLOCATE(ZTEM1D(SIZE(XVAR,1)),ZTEMLO(SIZE(XVAR,1)),ZWORKZ(SIZE(XVAR,1)))
+ ELSE
+! Disposition particuliere pour le traitement des vecteurs // Y mal enreg.
+! Cas anormal
+ IF(IJ == 1 .AND. NJL /= NJH)THEN
+ print*,'cas anormal LPSY=',LSPY
+ ALLOCATE(ZTEM1D(SIZE(XVAR,1)),ZTEMLO(SIZE(XVAR,1)),ZWORKZ(SIZE(XVAR,1)))
+ ELSE
+!ooooooooooooooooo
+! Cas normal
+ print*,'cas normal LPSY=',LSPY
+ ALLOCATE(ZTEM1D(SIZE(XVAR,2)),ZTEMLO(SIZE(XVAR,2)),ZWORKZ(SIZE(XVAR,2)))
+ ENDIF
+ ENDIF
+ if(nverbia > 0)then
+ print *,' **subspxy LSPX,LSPY ',LSPX,LSPY
+ endif
+
+!+++++++++ Boucle processus +++++++++++++++++++++++++++++++++++
+
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+ print *,'subspxy NLOOPP',NLOOPP
+ CALL LOADUNITIT(JLOOPP,KLOOP)
+
+!..............
+ IF(LSPX)THEN
+ IOMEGA=INDEX(CCOMMENT(NLOOPP),'DOMEGAX')
+ IF(IOMEGA == 0)THEN
+ IOMEGA=INDEX(CCOMMENT(NLOOPP),'Domegax')
+ IF(IOMEGA == 0)THEN
+ IOMEGA=INDEX(CCOMMENT(NLOOPP),'domegax')
+ ENDIF
+ ENDIF
+ IF(IOMEGA == 0)THEN
+ PRINT *,' Delta OmegaX (pulsation) non trouve dans le champ commentaire '
+ PRINT *,' On trace en indices de tableau'
+ DO J=1,SIZE(ZTEM1D)
+ ZTEM1D(J)=J
+ ENDDO
+ GOMEGAXOK=.FALSE.
+ ZOMEGA=1.
+
+ ELSE
+
+ IEGAL=INDEX(CCOMMENT(NLOOPP)(IOMEGA:LEN_TRIM(CCOMMENT(NLOOPP))),'=')
+ READ(CCOMMENT(NLOOPP)(IOMEGA+IEGAL:LEN_TRIM(CCOMMENT(NLOOPP))),*)XOMEGAX
+ print *,' tracé abscisse:j*OMEGAX ou 2pi/j*OMEGAX avec OMEGAX=',XOMEGAX
+ IF(XOMEGAX == 0.)THEN
+ PRINT *,' Delta OmegaX (pulsation) = 0'
+ PRINT *,' On trace en indices de tableau'
+ DO J=1,SIZE(ZTEM1D)
+ ZTEM1D(J)=J
+ ENDDO
+ ZTEMLO(:)=ZTEM1D(:)
+ GOMEGAXOK=.FALSE.
+ ZOMEGA=1.
+ ELSE
+ DO J=1,SIZE(ZTEM1D)
+ ZTEM1D(J)=J*XOMEGAX ! lambda pour lin
+ ZTEMLO(J)=2*XPI/(J*XOMEGAX) ! 2pi/lambda pour log
+ ENDDO
+ ZOMEGA=XOMEGAX
+ GOMEGAXOK=.TRUE.
+ ENDIF
+ ENDIF
+
+!..............
+ ELSE
+
+ IOMEGA=INDEX(CCOMMENT(NLOOPP),'DOMEGAY')
+ IF(IOMEGA == 0)THEN
+ IOMEGA=INDEX(CCOMMENT(NLOOPP),'Domegay')
+ IF(IOMEGA == 0)THEN
+ IOMEGA=INDEX(CCOMMENT(NLOOPP),'domegay')
+ ENDIF
+ ENDIF
+ if(nverbia > 0)then
+ print *,' **subspxy IOMEGA ',IOMEGA
+ endif
+ IF(IOMEGA == 0)THEN
+ PRINT *,' Delta OmegaY (pulsation) non trouve dans le champ commentaire '
+ PRINT *,' On trace en indices de tableau'
+ DO J=1,SIZE(ZTEM1D)
+ ZTEM1D(J)=J
+ ENDDO
+ GOMEGAYOK=.FALSE.
+ ZOMEGA=1.
+ ELSE
+ IEGAL=INDEX(CCOMMENT(NLOOPP)(IOMEGA:LEN_TRIM(CCOMMENT(NLOOPP))),'=')
+ READ(CCOMMENT(NLOOPP)(IOMEGA+IEGAL:LEN_TRIM(CCOMMENT(NLOOPP))),*)XOMEGAY
+ print *,' tracé abscisse:j*OMEGAY ou 2pi/j*OMEGAY avec OMEGAY=',XOMEGAY
+ IF(XOMEGAY == 0.)THEN
+ PRINT *,' Delta OmegaY (pulsation) = 0 '
+ PRINT *,' On trace en indices de tableau'
+ DO J=1,SIZE(ZTEM1D)
+ ZTEM1D(J)=J
+ ENDDO
+ ZTEMLO(:)=ZTEM1D(:)
+ GOMEGAYOK=.FALSE.
+ ZOMEGA=1
+ ELSE
+ DO J=1,SIZE(ZTEM1D)
+ ZTEM1D(J)=J*XOMEGAY ! lambda pour lin
+ ZTEMLO(J)=2*XPI/(J*XOMEGAY) ! 2pi/lambda pour Log
+ ENDDO
+ ZOMEGA=XOMEGAY
+ GOMEGAYOK=.TRUE.
+ ENDIF
+ ENDIF
+ ENDIF
+!..............
+ IF(GOMEGAXOK .OR. GOMEGAYOK) THEN
+ IF (LSPO .OR. LPHAO) THEN ! lin
+ ZMIN=MINVAL(ZTEM1D);ZMAX=MAXVAL(ZTEM1D)
+ ELSE IF (LSPLO .OR. LOSPLO .OR. LPHALO) THEN ! Log
+ ZMAX=MAXVAL(ZTEMLO)
+ ! Elimination des valeurs <=0 a cause du Log
+ ZMIN=ZMAX
+ DO J=1,SIZE(ZTEMLO)
+ IF(ZTEMLO(J) > 0.)THEN
+ ZMIN=MIN(ZMIN,ZTEMLO(J))
+ ENDIF
+ ENDDO
+ where(ZTEMLO <= 0.)ZTEMLO=1.e36
+ END IF
+ print *,' ZMIN,ZMAX ',ZMIN,ZMAX
+ ENDIF
+
+!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!+++++++++ Boucle sur N +++++++++++++++++++++++++++++++++++
+!++++++++++Parties reelle et imaginaire++++++++++++++++++++
+
+ DO JLOOPN=1,NBNDIA(KLOOP)
+ NLOOPN=NNDIA(JLOOPN,KLOOP)
+ print *,'subspxy NLOOPN',NLOOPN
+
+!+++++++++ Boucle sur K +++++++++++++++++++++++++++++++++++
+ DO JLOOPK=1,NBLVLKDIA(KLOOP,NLOOPN)
+ NLOOPK=NLVLKDIA(JLOOPK,KLOOP,NLOOPN)
+! print *,'subspxy jloopk,NLOOPK ',JLOOPK,NLOOPK
+
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN !TTTTTTTTTTTTTTTTTTTTTT
+ print *,'subspxy temps ',LTINCRDIA(KLOOP,1)
+
+!+++++++++ Boucle temps +++++++++++++++++++++++++++++++++++
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+ CALL RESOLV_TIMES(NLOOPT)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NLOOPT,1)
+
+! Partie reelle et imaginaire (suivant valeur de NLOOPN)
+ IF(LSPX)THEN
+ ZWORKZ(:)=XVAR(:,1,NLOOPK,NLOOPT,NLOOPN,NLOOPP)
+ ELSE
+!ooooooooooooooooooooooo
+! PROVI pour lire vecteurs // Y mal ecrits chez VM
+! Disposition particuliere pour le traitement des vecteurs // Y mal enreg.
+! Cas anormal
+ IF(IJ == 1 .AND. NJL /= NJH)THEN
+ ZWORKZ(:)=XVAR(:,1,NLOOPK,NLOOPT,NLOOPN,NLOOPP)
+ ELSE
+! Cas normal
+ ZWORKZ(:)=XVAR(1,:,NLOOPK,NLOOPT,NLOOPN,NLOOPP)
+ ENDIF
+ ENDIF
+ ZZMIN=MINVAL(ZWORKZ);ZZMAX=MAXVAL(ZWORKZ)
+ print *,' ZZMIN,ZZMAX initiaux ',ZZMIN,ZZMAX
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ ENDIF
+ CALL AGSETF('FRA.',2.)
+ CALL AGSETC('LAB/NAME.','B')
+ CALL AGSETR('LAB/SU.',1.)
+ CALL AGSETC('LAB/NAME.','L')
+ CALL AGSETR('LAB/SU.',1.)
+ CALL PCSETC('FC',':')
+
+ IF((GOMEGAXOK .AND. LSPX) .OR. (GOMEGAYOK .AND. LSPY))THEN !......................
+
+!------
+! _SPO_
+!------
+ IF(LSPO)THEN
+
+ CALL AGSETF('SET.',4.)
+! Traitement de la partie reelle (ou imaginaire)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Ligne 0
+ CALL GSCLIP(1)
+ CALL GSLN(2)
+ CALL FRSTPT(ZMIN,0.)
+ CALL VECTOR(ZMAX,0.)
+ CALL SFLUSH
+ CALL GSLN(1)
+! Titres
+
+
+!---------------
+! _OSPLO_ (/log)
+!---------------
+ ELSE IF(LOSPLO)THEN
+
+ ZZMIN=MINVAL(ZWORKZ(:)*ZOMEGA)
+ ZZMAX=MAXVAL(ZWORKZ(:)*ZOMEGA)
+ print *,' ZZMIN,ZZMAX *omega ',ZZMIN,ZZMAX
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,3)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,3)
+ ENDIF
+!Ds AGSETF, 4 signifie que l'on prend en compte les parametres de SET
+! 2 que l'on prend en compte le seul dernier parametre et les 4 1ers
+!Ds SET: 3 -> X Log + Y lin. 1 -> X+Y lin. 2-> X lin. + Y log 4 -> X log + Y Log
+! CALL AGSETF('SET.',2.)
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEMLO,ZWORKZ*ZOMEGA,SIZE(ZTEMLO),0)
+! Ligne 0
+ CALL GSCLIP(1)
+ CALL GSLN(2)
+ CALL FRSTPT(ZMIN,0.)
+ CALL VECTOR(ZMAX,0.)
+ CALL SFLUSH
+ CALL GSLN(1)
+! Titres
+
+
+!------------------
+! _LSPLO_ (Log/log)
+!------------------
+ ELSE IF(LSPLO)THEN
+ IF (ZZMAX <=0.) THEN
+ IF (NLOOPN==1) PRINT*,' LSPLO partie reelle <=0'
+ IF (NLOOPN==2) PRINT*,' LSPLO partie imaginaire <=0'
+ CYCLE
+ END IF
+ ! Elimination des valeurs <=0 a cause du Log
+ ZZMIN=ZZMAX
+ DO J=1,SIZE(ZWORKZ)
+ IF(ZWORKZ(J) > 0.)THEN
+ ZZMIN=MIN(ZZMIN,ZWORKZ(J))
+ ENDIF
+ ENDDO
+ IF (ZZMIN ==ZZMAX) THEN
+ IF (NLOOPN==1) PRINT*,' LSPLO partie reelle>0 cst ',ZZMIN
+ IF (NLOOPN==2) PRINT*,' LSPLO partie imaginaire>0 cst ',ZZMIN
+ CYCLE
+ END IF
+ where(ZWORKZ <= 0.)ZWORKZ=1.e36
+ print *,' ZZMIN,ZZMAX corrigés ',ZZMIN,ZZMAX
+
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ ENDIF
+! Verifier qu'avec 4 les limites sont mieux (NON)
+ CALL AGSETF('SET.',2.)
+! CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEMLO,ZWORKZ,SIZE(ZTEMLO),0)
+ IF(LM5S3)THEN
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ print*,'out GETSET',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID
+ CALL SET(ZVR-.3,ZVR-.05,ZVT-.3,ZVT-.05,0.,5.,0.,5.,1)
+ CALL FRSTPT(3.,0.)
+ CALL VECTOR(0.,5.)
+ CALL GSCHH(.2)
+ CALL GTX(0.+.5,5.-.4,YC5S3)
+ ENDIF
+! Titres
+
+!---------------
+! _PHALO_ (/log)
+!---------------
+ ELSE IF(LPHALO)THEN
+ !!VM IF(NLOOPN == 2)exit
+
+ IF(SIZE(XVAR,5) < 2)THEN
+ print *,' Absence partie imaginaire. Representation impossible sous cette forme'
+ ELSE
+ IF(NLOOPN == 1) THEN ! Phase
+ IF(LSPX)THEN
+ ZWORKZ(:)=ATAN2(-XVAR(:,1,NLOOPK,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ELSE
+!ooooooooooooooooooooooooooo
+! Disposition particuliere pour le traitement des vecteurs // Y mal enreg.
+! Cas anormal
+ IF(IJ == 1 .AND. NJL /= NJH)THEN
+ ZWORKZ(:)=ATAN2(-XVAR(:,1,NLOOPK,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ELSE
+! Cas normal
+ ZWORKZ(:)=ATAN2(-XVAR(1,:,NLOOPK,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ENDIF
+ ENDIF
+! print *,' PHALO ZWORKZ ',ZWORKZ
+! print *,' PHALO ZWORKZ EN DEGRES ',ZWORKZ*45./ATAN(1.)
+ DO J=2,SIZE(ZWORKZ)
+ IF(ABS(ZWORKZ(J-1) - ZWORKZ(J)) >= ATAN(1.)*8.)THEN
+ IF(ZWORKZ(J) > 0.)ZWORKZ(J)=ZWORKZ(J)+ATAN(1.)*8.
+ IF(ZWORKZ(J) < 0.)ZWORKZ(J)=ZWORKZ(J)-ATAN(1.)*8.
+ ENDIF
+ ENDDO
+! print *,' PHALO ZWORKZ AP DEROULEMENT PHASE ',ZWORKZ
+! print *,' PHALO ZWORKZ AP DEROULEMENT PHASE EN DEGRES ',ZWORKZ*45./ATAN(1.)
+ ZZMIN=MINVAL(ZWORKZ)
+ ZZMAX=MAXVAL(ZWORKZ)
+ print *,' ZZMIN,ZZMAX de la phase ',ZZMIN,ZZMAX
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,3)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,3)
+ ENDIF
+ CALL AGSETF('SET.',4.)
+! print *,' PHALO AV EZXY '
+ CALL EZXY(ZTEMLO,ZWORKZ,SIZE(ZTEMLO),0)
+! print *,' PHALO AP EZXY '
+ ELSE IF(NLOOPN == 2) THEN ! Module
+ IF(LSPX)THEN
+ ZWORKZ(:)=XVAR(:,1,NLOOPK,NLOOPT,1,NLOOPP)
+ ZWORKZ(:)=SQRT(ZWORKZ(:)*ZWORKZ(:) + &
+ XVAR(:,1,NLOOPK,NLOOPT,2,NLOOPP)*&
+ XVAR(:,1,NLOOPK,NLOOPT,2,NLOOPP) )
+ ELSE
+ IF(IJ == 1 .AND. NJL /= NJH)THEN
+ ZWORKZ(:)=XVAR(:,1,NLOOPK,NLOOPT,1,NLOOPP)
+ ZWORKZ(:)=SQRT(ZWORKZ(:)*ZWORKZ(:) + &
+ XVAR(:,1,NLOOPK,NLOOPT,2,NLOOPP)*&
+ XVAR(:,1,NLOOPK,NLOOPT,2,NLOOPP) )
+ ELSE
+ ZWORKZ(:)=XVAR(1,:,NLOOPK,NLOOPT,1,NLOOPP)
+ ZWORKZ(:)=SQRT(ZWORKZ(:)*ZWORKZ(:) + &
+ XVAR(1,:,NLOOPK,NLOOPT,2,NLOOPP)*&
+ XVAR(1,:,NLOOPK,NLOOPT,2,NLOOPP) )
+ ENDIF
+ ENDIF
+ ZZMIN=MINVAL(ZWORKZ)
+ ZZMAX=MAXVAL(ZWORKZ)
+ print *,' ZZMIN,ZZMAX du module ',ZZMIN,ZZMAX
+ ! 4 (log X, log Y) plutot que 3 (log X, linear Y)
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ ENDIF
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEMLO,ZWORKZ,SIZE(ZTEMLO),0)
+ IF(LM5S3)THEN
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ print*,'out GETSET',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID
+ CALL SET(ZVR-.3,ZVR-.05,ZVT-.3,ZVT-.05,0.,5.,0.,5.,1)
+ CALL FRSTPT(3.,0.)
+ CALL VECTOR(0.,5.)
+ CALL GSCHH(.2)
+ CALL GTX(0.+.5,5.-.4,YC5S3)
+ ENDIF
+ ENDIF ! fin NLOOPN
+ ENDIF ! fin (SIZE(XVAR,5) < 2)
+
+!-------
+! _PHAO_
+!-------
+ ELSE IF(LPHAO)THEN
+ !!VM IF(NLOOPN == 2)exit
+
+ IF(SIZE(XVAR,5) < 2)THEN
+ print *,' Absence partie imaginaire. Representation impossible sous cette forme'
+ ELSE
+ IF(NLOOPN == 1) THEN ! Phase
+ IF(LSPX)THEN
+ ZWORKZ(:)=ATAN2(-XVAR(:,1,NLOOPK,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ELSE
+!ooooooooooooooooooooooooooo
+! Disposition particuliere pour le traitement des vecteurs // Y mal enreg.
+! Cas anormal
+ IF(IJ == 1 .AND. NJL /= NJH)THEN
+ ZWORKZ(:)=ATAN2(-XVAR(:,1,NLOOPK,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ELSE
+! Cas normal
+ ZWORKZ(:)=ATAN2(-XVAR(1,:,NLOOPK,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ENDIF
+ ENDIF
+! print *,' PHAO ZWORKZ ',ZWORKZ
+ DO J=2,SIZE(ZWORKZ)
+ IF(ABS(ZWORKZ(J-1) - ZWORKZ(J)) >= ATAN(1.)*8.)THEN
+ IF(ZWORKZ(J) > 0.)ZWORKZ(J)=ZWORKZ(J)+ATAN(1.)*8.
+ IF(ZWORKZ(J) < 0.)ZWORKZ(J)=ZWORKZ(J)-ATAN(1.)*8.
+ ENDIF
+ ENDDO
+! print *,' PHAO ZWORKZ AP DEROULEMENT PHASE ',ZWORKZ
+ ZZMIN=MINVAL(ZWORKZ)
+ ZZMAX=MAXVAL(ZWORKZ)
+ print *,' ZZMIN,ZZMAX de la phase ',ZZMIN,ZZMAX
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ ENDIF
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+ ELSE IF(NLOOPN == 2) THEN ! Module *k
+ IF(LSPX)THEN
+ ZWORKZ(:)=XVAR(:,1,NLOOPK,NLOOPT,1,NLOOPP)
+ ZWORKZ(:)=SQRT(ZWORKZ(:)*ZWORKZ(:) + &
+ XVAR(:,1,NLOOPK,NLOOPT,2,NLOOPP)*&
+ XVAR(:,1,NLOOPK,NLOOPT,2,NLOOPP) )
+ ELSE
+ IF(IJ == 1 .AND. NJL /= NJH)THEN
+ ZWORKZ(:)=XVAR(:,1,NLOOPK,NLOOPT,1,NLOOPP)
+ ZWORKZ(:)=SQRT(ZWORKZ(:)*ZWORKZ(:) + &
+ XVAR(:,1,NLOOPK,NLOOPT,2,NLOOPP)*&
+ XVAR(:,1,NLOOPK,NLOOPT,2,NLOOPP) )
+ ELSE
+ ZWORKZ(:)=XVAR(1,:,NLOOPK,NLOOPT,1,NLOOPP)
+ ZWORKZ(:)=SQRT(ZWORKZ(:)*ZWORKZ(:) + &
+ XVAR(1,:,NLOOPK,NLOOPT,2,NLOOPP)*&
+ XVAR(1,:,NLOOPK,NLOOPT,2,NLOOPP) )
+ ENDIF
+ ENDIF
+ ! Module * k
+ ZWORKZ(:)=ZWORKZ(:)*ZTEMLO(:)
+ ZZMIN=MINVAL(ZWORKZ)
+ ZZMAX=MAXVAL(ZWORKZ)
+ print *,' ZZMIN,ZZMAX du Module *K ',ZZMIN,ZZMAX
+ ! 4 (log X, log Y)
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ ENDIF
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEMLO,ZWORKZ,SIZE(ZTEMLO),0)
+ IF(LM5S3)THEN
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ print*,'out GETSET',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID
+ CALL SET(ZVR-.3,ZVR-.05,ZVT-.3,ZVT-.05,0.,5.,0.,5.,1)
+ CALL FRSTPT(3.,0.)
+ CALL VECTOR(0.,5.)
+ CALL GSCHH(.2)
+ CALL GTX(0.+.5,5.-.4,YC5S3)
+ ENDIF
+ ENDIF ! fin boucle NLOOPN
+ ENDIF ! fin (SIZE(XVAR,5) < 2)
+ ENDIF ! fin LSPO,LOSPLO,LSPLO,LPHALO,LPHAO
+
+ ELSE !......................
+
+ IF(LSPO)THEN
+ CALL AGSETF('SET.',4.)
+! Traitement de la partie reelle
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Titres
+
+ ELSE
+ ENDIF
+
+ ENDIF !......................
+
+ IF(GOMEGAXOK .OR. GOMEGAYOK)THEN !GGGGGGGGGGGGGGG
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call gsclip(0)
+! Titres en X et Y
+ IF(LSPO)THEN
+ IF(GOMEGAXOK)THEN
+ call plchhq(.9,.05,':PGL:X:PRL:X:',.015,0.,1.)
+ ELSEIF(GOMEGAYOK)THEN
+ call plchhq(.9,.05,':PGL:X:PRL:Y:',.015,0.,1.)
+ ELSE
+ IF(LSPX)THEN
+ call plchhq(.9,.05,':PRU:Ind(:PRL:X:PRU:):',.015,0.,1.)
+ ELSE
+ call plchhq(.9,.05,':PRU:Ind(:PRL:Y:PRU:):',.015,0.,1.)
+ ENDIF
+ ENDIF
+ ELSEIF(LOSPLO)THEN
+ IF(LSPX)THEN
+ !!VM call plchhq(.9,.05,':PGL:X:PRL:X:PRU:',.015,0.,1.)
+ call plchhq(.9,.05,':PRL:K:PRL:X:PRU:',.015,0.,1.)
+ ELSE
+ !!VM call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:Y:PRU:):',.015,0.,1.)
+ call plchhq(.9,.05,':PRL:K:PRL:Y:PRU:',.015,0.,1.)
+ ENDIF
+ ELSEIF(LSPLO)THEN
+ IF(LSPX)THEN
+ !!VM call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:X:PRU:):',.015,0.,1.)
+ call plchhq(.9,.05,':PRL:K:PRL:X:PRU:',.015,0.,1.)
+ ELSE
+ !!VM call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:Y:PRU:):',.015,0.,1.)
+ call plchhq(.9,.05,':PRL:K:PRL:Y:PRU:',.015,0.,1.)
+ ENDIF
+ ELSEIF(LPHALO)THEN
+ IF(LSPX)THEN
+ !!VM call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:X:PRU:):',.015,0.,1.)
+ call plchhq(.9,.05,':PRL:K:PRL:X:PRU:',.015,0.,1.)
+ ELSE
+ !!VM call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:Y:PRU:):',.015,0.,1.)
+ call plchhq(.9,.05,':PRL:K:PRL:Y:PRU:',.015,0.,1.)
+ ENDIF
+ ELSEIF(LPHAO)THEN
+ IF(LSPX)THEN
+ call plchhq(.9,.05,':PGL:X:PRL:X:',.015,0.,1.)
+ ELSE
+ call plchhq(.9,.05,':PGL:X:PRL:Y:',.015,0.,1.)
+ ENDIF
+ ENDIF
+ IF(NLOOPN == 2)THEN
+ IF(LSPO)THEN
+ call plchhq(0., .87,':PRU:(I):',.015,0.,-1.)
+ ELSEIF(LOSPLO)THEN
+ call plchhq(0., .87,':PGL:X:PRU:*(I):',.015,0.,-1.)
+ ELSEIF(LSPLO)THEN
+ call plchhq(0., .87,':PRU:(I):',.015,0.,-1.)
+ ELSEIF(LPHALO)THEN
+ call plchhq(0., .85,':PRU:Module:',.015,0.,-1.)
+ ELSEIF(LPHAO)THEN
+ call plchhq(0., .85,':PRU:K*Module:',.015,0.,-1.)
+ ENDIF
+ ELSE
+ IF(LSPO)THEN
+ call plchhq(0., .87,':PRU:(R):',.015,0.,-1.)
+ ELSEIF(LOSPLO)THEN
+ call plchhq(0., .87,':PGL:X:PRU:*(R):',.015,0.,-1.)
+ ELSEIF(LSPLO)THEN
+ call plchhq(0., .87,':PRU:(R):',.015,0.,-1.)
+ ELSEIF(LPHALO)THEN
+ call plchhq(0., .85,':PRU:Phase:',.015,0.,-1.)
+ ELSEIF(LPHAO)THEN
+ call plchhq(0., .85,':PRU:Phase:',.015,0.,-1.)
+ ENDIF
+ ENDIF
+! Titres top et bottom
+! Top1
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT1',YTEM)
+ ZXPOSTITT1=.002
+ ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM,.008,0.,-1.)
+ ENDIF
+ ELSE
+ YTEM=CGROUP(1:LEN_TRIM(CGROUP))
+ YTEM=ADJUSTL(YTEM)
+ IL=LEN_TRIM(YTEM)
+ YTEM(IL+3:IL+5)='K ='
+ IL=IL+6
+ WRITE(YTEM(IL:IL+2),'(I3)')NLOOPK
+ call plchhq(.05,.98,YTEM(1:LEN_TRIM(YTEM)),.015,0.,-1.)
+! call plchhq(.05,.98,CGROUP(1:LEN_TRIM(CGROUP)),.015,0.,-1.)
+ ENDIF
+! Top2
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.95
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+! Top3
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT3',YTEM)
+ ZXPOSTITT3=.002
+ ZXYPOSTITT3=.93
+ IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ ENDIF
+ IF(XYPOSTITT3 /= 0.)THEN
+ ZXYPOSTITT3=XYPOSTITT3
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+! Titres Bottom
+! Titre N1 BOTTOM
+ YTEM(1:LEN(YTEM))=' '
+ YTEM=CTIMEC
+ YTEM=ADJUSTL(YTEM)
+ CALL RESOLV_TIT('CTITB1',YTEM)
+ ZXPOSTITB1=.002
+ ZXYPOSTITB1=.005
+ IF(XPOSTITB1 /= 0.)THEN
+ ZXPOSTITB1=XPOSTITB1
+ ENDIF
+ IF(XYPOSTITB1 /= 0.)THEN
+ ZXYPOSTITB1=XYPOSTITB1
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,YTEM,.009,0.,-1.)
+ ! CALL PLCHHQ(0.002,0.005,YTEM,.007,0.,-1.)
+ ENDIF
+! Titre N2 BOTTOM
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITB2',YTEM)
+ ZXPOSTITB2=.002
+ ZXYPOSTITB2=.025
+ IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ ENDIF
+ IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,YTEM,.007,0.,-1.)
+ ! CALL PLCHHQ(0.002,0.025,YTEM,.007,0.,-1.)
+ ENDIF
+! Titre N3 BOTTOM
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITB3',YTEM)
+ ZXPOSTITB3=.002
+ ZXYPOSTITB3=.045
+ IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ ENDIF
+ IF(XYPOSTITB3 /= 0.)THEN
+ ZXYPOSTITB3=XYPOSTITB3
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,.007,0.,-1.)
+ ENDIF
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ call gsclip(1)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ENDIF !GGGGGGGGGGGGGGG
+ CALL FRAME
+! print *,'subspxy ap frame '
+!!!!!!!!!!!!!!!!!Mai 2002!!!!!!!!!!!!!!!!!!!!!!!!
+ IF(LPRINT)THEN
+ IF(SIZE(XVAR,5) == 2 .AND. NLOOPN == 1)CYCLE
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+
+ WRITE(INUM,'(''SP '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'')')CGROUP,&
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+!........
+ IF(SIZE(XVAR,5) < 2)THEN
+ IF(GOMEGAXOK)THEN
+ WRITE(INUM,'(''Partie reelle uniquement DOMEGAX= '',F6.1)')ZOMEGA
+
+ ELSE
+
+ IF(GOMEGAYOK)THEN
+ WRITE(INUM,'(''Partie reelle uniquement DOMEGAY= '',F6.1)')ZOMEGA
+ ELSE
+
+ IF(LSPX)THEN
+ WRITE(INUM,'(''Partie reelle uniquement DOMEGAX= '',F6.1,'' -> Trace en indices de grille'')')XOMEGAX
+ ELSE
+ WRITE(INUM,'(''Partie reelle uniquement DOMEGAY= '',F6.1,'' -> Trace en indices de grille'')')XOMEGAY
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ELSE
+!........
+ IF(GOMEGAXOK)THEN
+ WRITE(INUM,'(''Parties reelle + imaginaire DOMEGAX= '',F6.1)')XOMEGAX
+ ELSE
+
+ IF(GOMEGAYOK)THEN
+ WRITE(INUM,'(''Parties reelle + imaginaire DOMEGAY= '',F6.1)')XOMEGAY
+ ELSE
+
+ IF(LSPX)THEN
+ WRITE(INUM,'(''Parties reelle + imaginaire DOMEGAX= '',F6.1,'' -> Trace en indices de grille'')')XOMEGAX
+ ELSE
+ WRITE(INUM,'(''Parties reelle + imaginaire DOMEGAY= '',F6.1,'' -> Trace en indices de grille'')')XOMEGAY
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+!........
+ IF(LSPX)THEN
+ WRITE(INUM,'(''NBVAL en I '',i4 )')SIZE(ZTEM1D,1)
+ ELSE
+ WRITE(INUM,'(''NBVAL en J '',i4 )')SIZE(ZTEM1D,1)
+ ENDIF
+
+ IF(SIZE(XVAR,5) < 2)THEN
+
+ WRITE(INUM,'(36(''*''))')
+ IF(LSPX)THEN
+ WRITE(INUM,'(10X,''X(I)'',9X,''Y(VAL.R)'')')
+ ELSE
+ WRITE(INUM,'(10X,''X(J)'',9X,''Y(VAL.R)'')')
+ ENDIF
+ WRITE(INUM,'(36(''*''))')
+ DO J=1,SIZE(ZTEM1D,1)
+ WRITE(INUM,'(I4,2X,F8.1,(5X,E15.8))')J,ZTEM1D(J),ZWORKZ(J)
+ ENDDO
+ ELSE
+ WRITE(INUM,'(55(''*''))')
+ IF(LSPX)THEN
+ WRITE(INUM,'(10X,''X(=I)'',8X,''Y(VAL.R)'',11X,''Y(VAL.Im)'')')
+ ELSE
+ WRITE(INUM,'(10X,''X(=J)'',8X,''Y(VAL.R)'',11X,''Y(VAL.Im)'')')
+ ENDIF
+ WRITE(INUM,'(55(''*''))')
+ DO J=1,SIZE(ZTEM1D,1)
+ IF(LSPX)THEN
+ WRITE(INUM,'(I4,2X,F8.1,2(5X,E15.8))')J,ZTEM1D(J),XVAR(J,1,NLOOPK,NLOOPT,1,NLOOPP),ZWORKZ(J)
+ ELSE
+ WRITE(INUM,'(I4,2X,F8.1,2(5X,E15.8))')J,ZTEM1D(J),XVAR(1,J,NLOOPK,NLOOPT,1,NLOOPP),ZWORKZ(J)
+ ENDIF
+ ENDDO
+ ENDIF
+ IF(SIZE(XVAR,5) < 2)THEN
+
+ WRITE(INUM,'(36(''*''))')
+ ELSE
+ WRITE(INUM,'(55(''*''))')
+ ENDIF
+
+ ENDIF
+!!!!!!!!!!!!!!!!!Mai 2002!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ENDDO
+
+
+ ELSE !TTTTTTTTTTTTTTTTTTTTTT
+ print *,'subspxy boucle temps ',LTINCRDIA(KLOOP,1)
+
+
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+ CALL RESOLV_TIMES(NLOOPT)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NLOOPT,1)
+! Partie reelle et imaginaire
+ IF(LSPX)THEN
+ ZWORKZ(:)=XVAR(:,1,NLOOPK,NLOOPT,NLOOPN,NLOOPP)
+ ELSE
+!oooooooooooooooooooooo
+! Disposition particuliere pour le traitement des vecteurs // Y mal enreg.
+! Cas anormal
+ IF(IJ == 1 .AND. NJL /= NJH)THEN
+ ZWORKZ(:)=XVAR(:,1,NLOOPK,NLOOPT,NLOOPN,NLOOPP)
+ ELSE
+! Cas normal
+ ZWORKZ(:)=XVAR(1,:,NLOOPK,NLOOPT,NLOOPN,NLOOPP)
+ ENDIF
+ ENDIF
+ IF (LSPO .OR. LPHAO) THEN ! lin
+ ZMIN=MINVAL(ZTEM1D);ZMAX=MAXVAL(ZTEM1D)
+ ELSE IF (LSPLO .OR. LOSPLO .OR. LPHALO) THEN ! Log
+ ZMAX=MAXVAL(ZTEMLO)
+ ZMIN=ZMAX
+ DO J=1,SIZE(ZTEMLO)
+ IF(ZTEMLO(J) > 0.)THEN
+ ZMIN=MIN(ZMIN,ZTEMLO(J))
+ ENDIF
+ ENDDO
+ where(ZTEMLO <= 0.)ZTEMLO=1.e36
+ END IF
+ ZZMIN=MINVAL(ZWORKZ);ZZMAX=MAXVAL(ZWORKZ)
+ print *,' ZMIN,ZMAX,ZZMIN,ZZMAX initiaux ',ZMIN,ZMAX,ZZMIN,ZZMAX
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ ENDIF
+ CALL AGSETF('FRA.',2.)
+ CALL AGSETC('LAB/NAME.','B')
+ CALL AGSETR('LAB/SU.',1.)
+ CALL AGSETC('LAB/NAME.','L')
+ CALL AGSETR('LAB/SU.',1.)
+ CALL PCSETC('FC',':')
+
+ IF((GOMEGAXOK .AND. LSPX) .OR. (GOMEGAYOK .AND. LSPY))THEN !......................
+
+!------
+! _SPO_
+!------
+ IF(LSPO)THEN
+
+ CALL AGSETF('SET.',4.)
+! Traitement de la partie reelle et imaginaire (suivant la valeur de N)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+! Ligne 0
+ CALL GSCLIP(1)
+ CALL GSLN(2)
+ CALL FRSTPT(ZMIN,0.)
+ CALL VECTOR(ZMAX,0.)
+ CALL SFLUSH
+ CALL GSLN(1)
+! Titres
+
+
+!---------------
+! _OSPLO_ (/log)
+!---------------
+ ELSE IF(LOSPLO)THEN
+
+ ZZMIN=MINVAL(ZWORKZ(:)*ZOMEGA)
+ ZZMAX=MAXVAL(ZWORKZ(:)*ZOMEGA)
+ print *,' ZZMIN,ZZMAX *omega ',ZZMIN,ZZMAX
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,3)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,3)
+ ENDIF
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEMLO,ZWORKZ*ZOMEGA,SIZE(ZTEMLO),0)
+! Ligne 0
+ CALL GSCLIP(1)
+ CALL GSLN(2)
+ CALL FRSTPT(ZMIN,0.)
+ CALL VECTOR(ZMAX,0.)
+ CALL SFLUSH
+ CALL GSLN(1)
+! Titres
+
+!------------------
+! _LSPLO_ (Log/log)
+!------------------
+ ELSE IF(LSPLO)THEN
+ IF (ZZMAX <=0.) THEN
+ IF (NLOOPN==1) PRINT*,' LSPLO partie reelle <=0'
+ IF (NLOOPN==2) PRINT*,' LSPLO partie imaginaire <=0'
+ CYCLE
+ END IF
+ ! Elimination des valeurs <=0 a cause du Log
+ ZZMIN=ZZMAX
+ DO J=1,SIZE(ZWORKZ)
+ IF(ZWORKZ(J) > 0.)THEN
+ ZZMIN=MIN(ZZMIN,ZWORKZ(J))
+ ENDIF
+ ENDDO
+ IF (ZZMIN ==ZZMAX) THEN
+ IF (NLOOPN==1) PRINT*,' LSPLO partie reelle>0 cst ',ZZMIN
+ IF (NLOOPN==2) PRINT*,' LSPLO partie imaginaire>0 cst ',ZZMIN
+ CYCLE
+ END IF
+ where(ZWORKZ <= 0.)ZWORKZ=1.e36
+ print *,' ZZMIN,ZZMAX corrigés ',ZZMIN,ZZMAX
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ ENDIF
+! CALL AGSETF('SET.',4.)
+ CALL AGSETF('SET.',2.)
+ CALL EZXY(ZTEMLO,ZWORKZ,SIZE(ZTEMLO),0)
+ IF(LM5S3)THEN
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ print*,'out GETSET',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID
+ CALL SET(ZVR-.3,ZVR-.05,ZVT-.3,ZVT-.05,0.,5.,0.,5.,1)
+ CALL FRSTPT(3.,0.)
+ CALL VECTOR(0.,5.)
+ CALL GSCHH(.2)
+ CALL GTX(0.+.5,5.-.4,YC5S3)
+ ENDIF
+! Titres
+
+!---------------
+! _PHALO_ (/log)
+!---------------
+ ELSE IF(LPHALO)THEN
+
+ !!VM IF(NLOOPN == 2)exit
+
+ IF(SIZE(XVAR,5) < 2)THEN
+ print *,' Absence partie imaginaire. Representation impossible sous cette forme'
+ ELSE
+ IF(NLOOPN==1) THEN ! Phase
+ IF(LSPX)THEN
+ ZWORKZ(:)=ATAN2(-XVAR(:,1,JLOOPK,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ELSE
+!ooooooooooooooooooooooooooo
+! Disposition particuliere pour le traitement des vecteurs // Y mal enreg.
+! Cas anormal
+ IF(IJ == 1 .AND. NJL /= NJH)THEN
+ ZWORKZ(:)=ATAN2(-XVAR(:,1,JLOOPK,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ELSE
+! Cas normal
+ ZWORKZ(:)=ATAN2(-XVAR(1,:,JLOOPK,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ENDIF
+ ENDIF
+ DO J=2,SIZE(ZWORKZ)
+ IF(ABS(ZWORKZ(J-1) - ZWORKZ(J)) >= ATAN(1.)*8.)THEN
+ IF(ZWORKZ(J) > 0.)ZWORKZ(J)=ZWORKZ(J)+ATAN(1.)*8.
+ IF(ZWORKZ(J) < 0.)ZWORKZ(J)=ZWORKZ(J)-ATAN(1.)*8.
+ ENDIF
+ ENDDO
+! print *,' PHALO ZWORKZ AP DEROULEMENT PHASE ',ZWORKZ
+ ZZMIN=MINVAL(ZWORKZ)
+ ZZMAX=MAXVAL(ZWORKZ)
+ print *,' ZZMIN,ZZMAX de la phase ',ZZMIN,ZZMAX
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,3)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,3)
+ ENDIF
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEMLO,ZWORKZ,SIZE(ZTEM1D),0)
+ ELSE IF(NLOOPN==2) THEN ! Module
+ IF(LSPX)THEN
+ ZWORKZ(:)=XVAR(:,1,JLOOPK,NLOOPT,1,NLOOPP)
+ ZWORKZ(:)=SQRT(ZWORKZ(:)*ZWORKZ(:) + &
+ XVAR(:,1,JLOOPK,NLOOPT,2,NLOOPP)*&
+ XVAR(:,1,JLOOPK,NLOOPT,2,NLOOPP) )
+ ELSE
+ IF(IJ == 1 .AND. NJL /= NJH)THEN
+ ZWORKZ(:)=XVAR(:,1,JLOOPK,NLOOPT,1,NLOOPP)
+ ZWORKZ(:)=SQRT(ZWORKZ(:)*ZWORKZ(:) + &
+ XVAR(:,1,JLOOPK,NLOOPT,2,NLOOPP)*&
+ XVAR(:,1,JLOOPK,NLOOPT,2,NLOOPP) )
+ ELSE
+ ZWORKZ(:)=XVAR(1,:,JLOOPK,NLOOPT,1,NLOOPP)
+ ZWORKZ(:)=SQRT(ZWORKZ(:)*ZWORKZ(:) + &
+ XVAR(1,:,JLOOPK,NLOOPT,2,NLOOPP)*&
+ XVAR(1,:,JLOOPK,NLOOPT,2,NLOOPP) )
+ ENDIF
+ ENDIF
+ ZZMIN=MINVAL(ZWORKZ)
+ ZZMAX=MAXVAL(ZWORKZ)
+ print *,' ZZMIN,ZZMAX du module ',ZZMIN,ZZMAX
+ ! 4 (log X, log Y) plutot que 3 (log X, linear Y)
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ ENDIF
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEMLO,ZWORKZ,SIZE(ZTEMLO),0)
+ IF(LM5S3)THEN
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ print*,'out GETSET',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID
+ CALL SET(ZVR-.3,ZVR-.05,ZVT-.3,ZVT-.05,0.,5.,0.,5.,1)
+ CALL FRSTPT(3.,0.)
+ CALL VECTOR(0.,5.)
+ CALL GSCHH(.2)
+ CALL GTX(0.+.5,5.-.4,YC5S3)
+ ENDIF
+ ENDIF ! fin boucle NLOOPN
+ ENDIF
+
+!-------
+! _PHAO_
+!-------
+ ELSE IF(LPHAO)THEN
+
+ !!VM IF(NLOOPN == 2)exit
+
+ IF(SIZE(XVAR,5) < 2)THEN
+ print *,' Absence partie imaginaire. Representation impossible sous cette forme'
+ ELSE
+ IF(NLOOPN==1) THEN ! Phase
+ IF(LSPX)THEN
+ ZWORKZ(:)=ATAN2(-XVAR(:,1,JLOOPK,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ELSE
+!ooooooooooooooooooooooooooo
+! Disposition particuliere pour le traitement des vecteurs // Y mal enreg.
+! Cas anormal
+ IF(IJ == 1 .AND. NJL /= NJH)THEN
+ ZWORKZ(:)=ATAN2(-XVAR(:,1,JLOOPK,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ELSE
+! Cas normal
+ ZWORKZ(:)=ATAN2(-XVAR(1,:,JLOOPK,NLOOPT,2,NLOOPP),ZWORKZ(:))
+ ENDIF
+ ENDIF
+! print *,' PHALO ZWORKZ ',ZWORKZ
+ DO J=2,SIZE(ZWORKZ)
+ IF(ABS(ZWORKZ(J-1) - ZWORKZ(J)) >= ATAN(1.)*8.)THEN
+ IF(ZWORKZ(J) > 0.)ZWORKZ(J)=ZWORKZ(J)+ATAN(1.)*8.
+ IF(ZWORKZ(J) < 0.)ZWORKZ(J)=ZWORKZ(J)-ATAN(1.)*8.
+ ENDIF
+ ENDDO
+! print *,' PHALO ZWORKZ AP DEROULEMENT PHASE ',ZWORKZ
+ ZZMIN=MINVAL(ZWORKZ)
+ ZZMAX=MAXVAL(ZWORKZ)
+ print *,' ZZMIN,ZZMAX de la phase ',ZZMIN,ZZMAX
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,1)
+ ENDIF
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+ ELSE IF(NLOOPN==2) THEN ! Module *k
+ IF(LSPX)THEN
+ ZWORKZ(:)=XVAR(:,1,JLOOPK,NLOOPT,1,NLOOPP)
+ ZWORKZ(:)=SQRT(ZWORKZ(:)*ZWORKZ(:) + &
+ XVAR(:,1,JLOOPK,NLOOPT,2,NLOOPP)*&
+ XVAR(:,1,JLOOPK,NLOOPT,2,NLOOPP) )
+ ELSE
+ IF(IJ == 1 .AND. NJL /= NJH)THEN
+ ZWORKZ(:)=XVAR(:,1,JLOOPK,NLOOPT,1,NLOOPP)
+ ZWORKZ(:)=SQRT(ZWORKZ(:)*ZWORKZ(:) + &
+ XVAR(:,1,JLOOPK,NLOOPT,2,NLOOPP)*&
+ XVAR(:,1,JLOOPK,NLOOPT,2,NLOOPP) )
+ ELSE
+ ZWORKZ(:)=XVAR(1,:,JLOOPK,NLOOPT,1,NLOOPP)
+ ZWORKZ(:)=SQRT(ZWORKZ(:)*ZWORKZ(:) + &
+ XVAR(1,:,JLOOPK,NLOOPT,2,NLOOPP)*&
+ XVAR(1,:,JLOOPK,NLOOPT,2,NLOOPP) )
+ ENDIF
+ ENDIF
+ ! Module * k
+ ZWORKZ(:)=ZWORKZ(:)*ZTEMLO(:)
+ ZZMIN=MINVAL(ZWORKZ)
+ ZZMAX=MAXVAL(ZWORKZ)
+ print *,' ZZMIN,ZZMAX de K*Module ',ZZMIN,ZZMAX
+ ! 4 (log X, log Y)
+ IF(LVPTUSER)THEN
+ CALL SET(XVPTL,XVPTR,XVPTB,XVPTT,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ ELSE
+ CALL SET(.1,.9,.1,.9,ZMIN,ZMAX,ZZMIN,ZZMAX,4)
+ ENDIF
+ CALL AGSETF('SET.',4.)
+ CALL EZXY(ZTEMLO,ZWORKZ,SIZE(ZTEMLO),0)
+ IF(LM5S3)THEN
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ print*,'out GETSET',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID
+ CALL SET(ZVR-.3,ZVR-.05,ZVT-.3,ZVT-.05,0.,5.,0.,5.,1)
+ CALL FRSTPT(3.,0.)
+ CALL VECTOR(0.,5.)
+ CALL GSCHH(.2)
+ CALL GTX(0.+.5,5.-.4,YC5S3)
+ ENDIF
+ ENDIF ! fin boucle NLOOPN
+ ENDIF
+ ENDIF
+
+ ELSE !......................
+
+ IF(LSPO)THEN
+ CALL AGSETF('SET.',4.)
+! Traitement de la partie reelle
+ CALL EZXY(ZTEM1D,ZWORKZ,SIZE(ZTEM1D),0)
+ ELSE
+ ENDIF
+
+ ENDIF !......................
+
+ IF(GOMEGAXOK .OR. GOMEGAYOK)THEN !GGGGGGGGGGGGGGG
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Titres
+ CALL SET(0.,.9,0.,.9,0.,.9,0.,.9,1)
+ call gsclip(0)
+! Titres en X et Y
+ IF(LSPO)THEN
+ IF(GOMEGAXOK)THEN
+ call plchhq(.9,.05,':PGL:X:PRL:X:',.015,0.,1.)
+ ELSEIF(GOMEGAYOK)THEN
+ call plchhq(.9,.05,':PGL:X:PRL:Y:',.015,0.,1.)
+ ELSE
+ IF(LSPX)THEN
+ call plchhq(.9,.05,':PRU:Ind(:PRL:X:PRU:):',.015,0.,1.)
+ ELSE
+ call plchhq(.9,.05,':PRU:Ind(:PRL:Y:PRU:):',.015,0.,1.)
+ ENDIF
+ ENDIF
+ ELSEIF(LOSPLO)THEN
+ IF(LSPX)THEN
+ !!VM call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:X:PRU:):',.015,0.,1.)
+ call plchhq(.9,.05,':PRL:K:PRL:X:PRU:',.015,0.,1.)
+ ELSE
+ !!VM call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:Y:PRU:):',.015,0.,1.)
+ call plchhq(.9,.05,':PRL:K:PRL:Y:PRU:',.015,0.,1.)
+ ENDIF
+ ELSEIF(LSPLO)THEN
+ IF(LSPX)THEN
+ !!VM call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:X:PRU:):',.015,0.,1.)
+ call plchhq(.9,.05,':PRL:K:PRL:X:PRU:',.015,0.,1.)
+ ELSE
+ !!VM call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:Y:PRU:):',.015,0.,1.)
+ call plchhq(.9,.05,':PRL:K:PRL:Y:PRU:',.015,0.,1.)
+ ENDIF
+ ELSEIF(LPHALO)THEN
+ IF(LSPX)THEN
+ !!VM call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:X:PRU:):',.015,0.,1.)
+ call plchhq(.9,.05,':PRL:K:PRL:X:PRU:',.015,0.,1.)
+ ELSE
+ !!VM call plchhq(.9,.05,':PRU:Log(:PGL:X:PRL:Y:PRU:):',.015,0.,1.)
+ call plchhq(.9,.05,':PRL:K:PRL:Y:PRU:',.015,0.,1.)
+ ENDIF
+ ELSEIF(LPHAO)THEN
+ IF(LSPX)THEN
+ call plchhq(.9,.05,':PGL:X:PRL:X:',.015,0.,1.)
+ ELSE
+ call plchhq(.9,.05,':PGL:X:PRL:Y:',.015,0.,1.)
+ ENDIF
+ ENDIF
+ IF(NLOOPN == 2)THEN
+ IF(LSPO)THEN
+ call plchhq(0., .87,':PRU:(I):',.015,0.,-1.)
+ ELSEIF(LOSPLO)THEN
+ call plchhq(0., .87,':PGL:X:PRU:*(I):',.015,0.,-1.)
+ ELSEIF(LSPLO)THEN
+ call plchhq(0., .87,':PRU:(I):',.015,0.,-1.)
+ ELSEIF(LPHALO)THEN
+ call plchhq(0., .85,':PRU:Module:',.015,0.,-1.)
+ ELSEIF(LPHAO)THEN
+ call plchhq(0., .85,':PRU:K*Module:',.015,0.,-1.)
+ ENDIF
+ ELSE
+ IF(LSPO)THEN
+ call plchhq(0., .87,':PRU:(R):',.015,0.,-1.)
+ ELSEIF(LOSPLO)THEN
+ call plchhq(0., .87,':PGL:X:PRU:*(R):',.015,0.,-1.)
+ ELSEIF(LSPLO)THEN
+ call plchhq(0., .87,':PRU:(R):',.015,0.,-1.)
+ ELSEIF(LPHALO)THEN
+ call plchhq(0., .85,':PRU:Phase:',.015,0.,-1.)
+ ELSEIF(LPHAO)THEN
+ call plchhq(0., .85,':PRU:Phase:',.015,0.,-1.)
+ ENDIF
+ ENDIF
+! Titres top et bottom
+! Top1
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT1',YTEM)
+ ZXPOSTITT1=.002
+ ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM,.008,0.,-1.)
+ ENDIF
+ ELSE
+ YTEM=CGROUP(1:LEN_TRIM(CGROUP))
+ YTEM=ADJUSTL(YTEM)
+ IL=LEN_TRIM(YTEM)
+ YTEM(IL+3:IL+5)='K ='
+ IL=IL+6
+ WRITE(YTEM(IL:IL+2),'(I3)')NLOOPK
+ call plchhq(.05,.98,YTEM(1:LEN_TRIM(YTEM)),.015,0.,-1.)
+! call plchhq(.05,.98,CGROUP(1:LEN_TRIM(CGROUP)),.015,0.,-1.)
+ ENDIF
+! Top2
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.95
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+! Top3
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT3',YTEM)
+ ZXPOSTITT3=.002
+ ZXYPOSTITT3=.93
+ IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ ENDIF
+ IF(XYPOSTITT3 /= 0.)THEN
+ ZXYPOSTITT3=XYPOSTITT3
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+! Titres Bottom
+! Titre N1 BOTTOM
+ YTEM(1:LEN(YTEM))=' '
+ YTEM=CTIMEC
+ YTEM=ADJUSTL(YTEM)
+ CALL RESOLV_TIT('CTITB1',YTEM)
+ ZXPOSTITB1=.002
+ ZXYPOSTITB1=.005
+ IF(XPOSTITB1 /= 0.)THEN
+ ZXPOSTITB1=XPOSTITB1
+ ENDIF
+ IF(XYPOSTITB1 /= 0.)THEN
+ ZXYPOSTITB1=XYPOSTITB1
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,YTEM,.009,0.,-1.)
+ ! CALL PLCHHQ(0.002,0.005,YTEM,.007,0.,-1.)
+ ENDIF
+! Titre N2 BOTTOM
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITB2',YTEM)
+ ZXPOSTITB2=.002
+ ZXYPOSTITB2=.025
+ IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ ENDIF
+ IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,YTEM,.007,0.,-1.)
+ ! CALL PLCHHQ(0.002,0.025,YTEM,.007,0.,-1.)
+ ENDIF
+! Titre N3 BOTTOM
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITB3',YTEM)
+ ZXPOSTITB3=.002
+ ZXYPOSTITB3=.045
+ IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ ENDIF
+ IF(XYPOSTITB3 /= 0.)THEN
+ ZXYPOSTITB3=XYPOSTITB3
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,.007,0.,-1.)
+ ENDIF
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ call gsclip(1)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! print *,'subspxy ap frame '
+ ENDIF !GGGGGGGGGGGGGGG
+ CALL FRAME
+!!!!!!!!!!!!!!!!!Mai 2002!!!!!!!!!!!!!!!!!!!!!!!!
+ IF(LPRINT)THEN
+ IF(SIZE(XVAR,5) == 2 .AND. NLOOPN == 1)CYCLE
+
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+
+ WRITE(INUM,'(''SP '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'')')CGROUP,&
+& CTITRE(NLOOPP)(1:25),XTRAJT(NLOOPT,1)
+!........
+ IF(SIZE(XVAR,5) < 2)THEN
+ IF(GOMEGAXOK)THEN
+ WRITE(INUM,'(''Partie reelle uniquement DOMEGAX= '',F6.1)')ZOMEGA
+
+ ELSE
+
+ IF(GOMEGAYOK)THEN
+ WRITE(INUM,'(''Partie reelle uniquement DOMEGAY= '',F6.1)')ZOMEGA
+ ELSE
+
+ IF(LSPX)THEN
+ WRITE(INUM,'(''Partie reelle uniquement DOMEGAX= '',F6.1,'' -> Trace en indices de grille'')')XOMEGAX
+ ELSE
+ WRITE(INUM,'(''Partie reelle uniquement DOMEGAY= '',F6.1,'' -> Trace en indices de grille'')')XOMEGAY
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ELSE
+!........
+ IF(GOMEGAXOK)THEN
+ WRITE(INUM,'(''Parties reelle + imaginaire DOMEGAX= '',F6.1)')ZOMEGA
+ ELSE
+
+ IF(GOMEGAYOK)THEN
+ WRITE(INUM,'(''Parties reelle + imaginaire DOMEGAY= '',F6.1)')ZOMEGA
+ ELSE
+ IF(LSPX)THEN
+ WRITE(INUM,'(''Parties reelle + imaginaire DOMEGAX= '',F6.1,'' -> Trace en indices de grille'')')XOMEGAX
+ ELSE
+ WRITE(INUM,'(''Parties reelle + imaginaire DOMEGAY= '',F6.1,'' -> Trace en indices de grille'')')XOMEGAY
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+!........
+ IF(LSPX)THEN
+ WRITE(INUM,'(''NBVAL en I '',i4 )')SIZE(ZTEM1D,1)
+ ELSE
+ WRITE(INUM,'(''NBVAL en J '',i4 )')SIZE(ZTEM1D,1)
+ ENDIF
+
+ IF(SIZE(XVAR,5) < 2)THEN
+
+ WRITE(INUM,'(36(''*''))')
+ IF(LSPX)THEN
+ WRITE(INUM,'(10X,''X(I)'',9X,''Y(VAL.R)'')')
+ ELSE
+ WRITE(INUM,'(10X,''X(J)'',9X,''Y(VAL.R)'')')
+ ENDIF
+ WRITE(INUM,'(36(''*''))')
+ DO J=1,SIZE(ZTEM1D,1)
+ WRITE(INUM,'(I4,2X,F8.1,(5X,E15.8))')J,ZTEM1D(J),ZWORKZ(J)
+ ENDDO
+ ELSE
+ WRITE(INUM,'(55(''*''))')
+ IF(LSPX)THEN
+ WRITE(INUM,'(10X,''X(=I)'',8X,''Y(VAL.R)'',11X,''Y(VAL.Im)'')')
+ ELSE
+ WRITE(INUM,'(10X,''X(=J)'',8X,''Y(VAL.R)'',11X,''Y(VAL.Im)'')')
+ ENDIF
+ WRITE(INUM,'(55(''*''))')
+ DO J=1,SIZE(ZTEM1D,1)
+ IF(LSPX)THEN
+ WRITE(INUM,'(I4,2X,F8.1,2(5X,E15.8))')J,ZTEM1D(J),XVAR(J,1,NLOOPK,NLOOPT,1,NLOOPP),ZWORKZ(J)
+ ELSE
+ WRITE(INUM,'(I4,2X,F8.1,2(5X,E15.8))')J,ZTEM1D(J),XVAR(1,J,NLOOPK,NLOOPT,1,NLOOPP),ZWORKZ(J)
+ ENDIF
+ ENDDO
+ ENDIF
+ IF(SIZE(XVAR,5) < 2)THEN
+
+ WRITE(INUM,'(36(''*''))')
+ ELSE
+ WRITE(INUM,'(55(''*''))')
+ ENDIF
+
+ ENDIF
+!!!!!!!!!!!!!!!!!Mai 2002!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ENDDO
+
+!+++++++++ Boucle temps +++++++++++++++++++++++++++++++++++
+
+ ENDIF !TTTTTTTTTTTTTTTTTTTTTT
+
+ ENDDO
+!+++++++++ Boucle sur K +++++++++++++++++++++++++++++++++++
+ ENDDO
+!+++++++++ Boucle sur N +++++++++++++++++++++++++++++++++++
+ ENDDO
+
+!+++++++++ Boucle processus +++++++++++++++++++++++++++++++++++
+
+ DEALLOCATE(ZWORKZ,ZTEM1D,ZTEMLO)
+
+!*************************************************************************
+ ENDIF
+!!!!! BIDIMENSIONNELS
+!*************************************************************************
+! Plan ( horizontal ou vertical // X ou vertical // Y)
+!*************************************************************************
+ ELSE !iiiiiiiiiiiiiiiiiiiiiiiiii
+ print *,' bidimensionnel: II,IJ,IK=',II,IJ,IK
+
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! CH Positionnement NIINF, NJINF, NISUP, NJSUP
+! Defaut : NIINF=MAX(IIB,NIL), NJINF=MAX(IJB,NJL), NISUP=MIN(IIE,NIH),
+! NJSUP=MIN(IJE,NJH)
+! Sinon valeurs fournies par l'utilisateur dans les limites (NIL,NJL NIH,
+! NJH)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! CV Positionnement NIINF, NJINF, NISUP, NJSUP
+! CV Positionnement LHORIZ et LVERTI
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ CALL RESOLV_NIJINF_NIJSUP
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! CH + CV Allocation matrice 3D de reception des valeurs
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ ALLOCATE (ZWORK3D(1:NISUP-NIINF+1,1:NJSUP-NJINF+1, &
+ 1:NKH-NKL+1))
+
+! print *,' NBPROCDIA(KLOOP) ',NBPROCDIA(KLOOP)
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle externe sur les processus
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO JLOOPP=1,NBPROCDIA(KLOOP)
+ NLOOPP=NPROCDIA(JLOOPP,KLOOP)
+
+ CALL LOADUNITIT(JLOOPP,KLOOP)
+
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle sur les numeros de R + I
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+! print *,' NBNDIA(KLOOP) ',NBNDIA(KLOOP)
+
+ DO JLOOPN=1,NBNDIA(KLOOP)
+ NLOOPN=NNDIA(JLOOPN,KLOOP)
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle sur les temps (Formulation sequentielle)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ IF(.NOT.LTINCRDIA(KLOOP,1))THEN
+
+! print *,' NBTIMEDIA(KLOOP,1) ',NBTIMEDIA(KLOOP,1)
+
+ DO JLOOPT=1,NBTIMEDIA(KLOOP,1)
+ NLOOPT=NTIMEDIA(JLOOPT,KLOOP,1)
+
+
+ CALL RESOLV_TIMES(NTIMEDIA(JLOOPT,KLOOP,1))
+
+ ZWORK3D=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,NTIMEDIA(JLOOPT,KLOOP,1),JLOOPN, &
+ NPROCDIA(JLOOPP,KLOOP))
+! WRITE(CLEGEND2(8:15),'(F8.0)')XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(NTIMEDIA(JLOOPT,KLOOP,1),1)
+!!!!!!!!!!!!!!!!!!!!!!!!! CH !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ IF(LCH)THEN
+
+ IF(NBLVLKDIA(KLOOP,1) == 0)THEN
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle sur les altitudes Z (Formulation sequentielle)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ IF(.NOT.LZINCRDIA(KLOOP))THEN
+ DO JLOOPZ=1,NBLVLZDIA(KLOOP)
+
+ IZ=XLVLZDIA(JLOOPZ,KLOOP)
+ CALL TRACEH_FORDIACHRO(IZ,ZWORK3D,KLOOP)
+
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+
+ ENDDO
+
+ ELSE
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle sur les altitudes Z (Formulation incrementale)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO JLOOPZ=INT(XLVLZDIA(1,KLOOP)),INT(XLVLZDIA(2,KLOOP)), &
+ INT(XLVLZDIA(3,KLOOP))
+ IZ=JLOOPZ
+ CALL TRACEH_FORDIACHRO(IZ,ZWORK3D,KLOOP)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+
+ ENDDO
+
+ ENDIF
+
+ ELSE
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle sur les niveaux de modele (Formulation sequentielle)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO JLOOPK=1,NBLVLKDIA(KLOOP,1)
+ CALL TRACEH_FORDIACHRO(NLVLKDIA(JLOOPK, &
+ KLOOP,1),ZWORK3D,KLOOP)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDDO
+
+ ENDIF
+! CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!! CV !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ELSE IF(LCV)THEN
+
+ IF(NLMAX <= 1 .OR. (NLANGLE<0 .OR. NLANGLE>360) .OR. &
+ (NIDEBCOU <=0 .AND. XIDEBCOU == -999.) .OR. &
+ (NJDEBCOU <=0 .AND. XJDEBCOU == -999.))THEN
+ PRINT *,' DEFINISSEZ D''ABORD NIDEBCOU, NJDEBCOU,',&
+& ' NLMAX, NLANGLE (Pour CV + PV), PROFILE (Pour PV)'
+ PRINT *,' ou XIDEBCOU, XJDEBCOU'
+ PRINT *,' PUIS RENTREZ A NOUVEAU VOTRE DIRECTIVE '
+! print *,' (Pour le 1D, mettre Obligatoirement ',&
+!& 'NLMAX=2 et LPOINTG=T'
+ PRINT *,' VALEURS ACTUELLES: '
+ PRINT '('' NIDEBCOU:'',I5,'' NJDEBCOU:'',I5,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5,'' PROFILE: '',I5)',NIDEBCOU, &
+& NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ IF(ALLOCATED(ZWORK3D))THEN
+ DEALLOCATE(ZWORK3D)
+ LPBREAD=.TRUE.
+ ENDIF
+ RETURN
+ ELSE
+ PRINT *,' VALEURS DES PARAMETRES DE DEFINITION DE LA COUPE',&
+& ' ou DU PROFIL :'
+ IF(XIDEBCOU == -999. .AND. XJDEBCOU == -999.)THEN
+ PRINT '('' NIDEBCOU:'',I5,'' NJDEBCOU:'',I5,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5,'' PROFILE: '',I5)',NIDEBCOU, &
+& NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ print *,' ( Pour le 1D, mettre Obligatoirement ',&
+& 'NLMAX=2 et LPOINTG=T )'
+ ELSE
+ PRINT '('' XIDEBCOU:'',F7.1,'' XJDEBCOU:'',F7.1,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5,'' PROFILE: '',I5)',XIDEBCOU, &
+& XJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ENDIF
+ ENDIF
+
+ CALL VERIFLEN_FORDIACHRO
+ ALLOCATE (ZTEMCV(NLMAX,1:IKU))
+ CALL PRECOU_FORDIACHRO(ZWORK3D,ZTEMCV)
+ ILENT=LEN_TRIM(CTITGAL)
+ ILENU=LEN_TRIM(CUNITGAL)
+ YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+ YTEXTE(ILENT+1:ILENT+1)=' '
+ YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
+ CALL TRACEV_FORDIACHRO(ZTEMCV,KLOOP,YTEXTE(1: &
+ LEN_TRIM(YTEXTE)))
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+
+ DEALLOCATE(ZTEMCV)
+ DEALLOCATE(XWORKZ,XWZ)
+
+ ENDIF
+ ENDDO
+
+ ELSE
+
+! print *,' NBTIMEDIA(KLOOP,1) ',NBTIMEDIA(KLOOP,1)
+! print *,' NTIMEDIA(1 et 2,KLOOP,1) ',NTIMEDIA(1,KLOOP,1), &
+! NTIMEDIA(2,KLOOP,1),NTIMEDIA(3,KLOOP,1)
+
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! Boucle sur les temps (Formulation incrementale)
+! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+ DO JLOOPT=NTIMEDIA(1,KLOOP,1),NTIMEDIA(2,KLOOP,1), &
+ NTIMEDIA(3,KLOOP,1)
+ NLOOPT=JLOOPT
+
+
+ CALL RESOLV_TIMES(JLOOPT)
+ ZWORK3D=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,JLOOPT,JLOOPN,NPROCDIA(JLOOPP,KLOOP))
+! WRITE(CLEGEND2(8:15),'(F8.0)')XTRAJT(JLOOPT,1)
+ WRITE(CTIMEC(8:15),'(F8.0)')XTRAJT(JLOOPT,1)
+
+!!!!!!!!!!!!!!!!!!!!!!!!! CH !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ IF(LCH)THEN
+
+ IF(NBLVLKDIA(KLOOP,1) == 0)THEN
+
+ IF(.NOT.LZINCRDIA(KLOOP))THEN
+ DO JLOOPZ=1,NBLVLZDIA(KLOOP)
+ IZ=XLVLZDIA(JLOOPZ,KLOOP)
+ CALL TRACEH_FORDIACHRO(IZ,ZWORK3D,KLOOP)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDDO
+
+ ELSE
+
+ DO JLOOPZ=INT(XLVLZDIA(1,KLOOP)),INT(XLVLZDIA(2,KLOOP)), &
+ INT(XLVLZDIA(3,KLOOP))
+ IZ=JLOOPZ
+ CALL TRACEH_FORDIACHRO(IZ,ZWORK3D,KLOOP)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDDO
+ ENDIF
+
+ ELSE
+
+ DO JLOOPK=1,NBLVLKDIA(KLOOP,1)
+
+ CALL TRACEH_FORDIACHRO(NLVLKDIA(JLOOPK,KLOOP,1), &
+ ZWORK3D,KLOOP)
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ ENDDO
+
+ ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!!! CV !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ELSE IF(LCV)THEN
+
+ IF(NLMAX <= 1 .OR. (NLANGLE<0 .OR. NLANGLE>360) .OR. &
+ (NIDEBCOU <=0 .AND. XIDEBCOU == -999.) .OR. &
+ (NJDEBCOU <=0 .AND. XJDEBCOU == -999.))THEN
+ PRINT *,' DEFINISSEZ D''ABORD NIDEBCOU, NJDEBCOU,',&
+& ' NLMAX, NLANGLE (Pour CV + PV), PROFILE (Pour PV)'
+ PRINT *,' ou XIDEBCOU, XJDEBCOU'
+ PRINT *,' PUIS RENTREZ A NOUVEAU VOTRE DIRECTIVE '
+! print *,' (Pour le 1D, mettre Obligatoirement ',&
+!& 'NLMAX=2 et LPOINTG=T'
+ PRINT *,' VALEURS ACTUELLES: '
+ PRINT '('' NIDEBCOU:'',I5,'' NJDEBCOU:'',I5,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5,'' PROFILE: '',I5)',NIDEBCOU, &
+& NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ IF(ALLOCATED(ZWORK3D))THEN
+ DEALLOCATE(ZWORK3D)
+ LPBREAD=.TRUE.
+ ENDIF
+ RETURN
+ ELSE
+ PRINT *,' VALEURS DES PARAMETRES DE DEFINITION DE LA COUPE',&
+& ' ou DU PROFIL :'
+ IF(XIDEBCOU == -999. .AND. XJDEBCOU == -999.)THEN
+ PRINT '('' NIDEBCOU:'',I5,'' NJDEBCOU:'',I5,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5,'' PROFILE: '',I5)',NIDEBCOU, &
+& NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ print *,' ( Pour le 1D, mettre Obligatoirement ',&
+& 'NLMAX=2 et LPOINTG=T )'
+ ELSE
+ PRINT '('' XIDEBCOU:'',F7.1,'' XJDEBCOU:'',F7.1,'' NLMAX: '',&
+& I6,'' NLANGLE:'',I5,'' PROFILE: '',I5)',XIDEBCOU, &
+& XJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ENDIF
+ ENDIF
+
+ CALL VERIFLEN_FORDIACHRO
+ ALLOCATE (ZTEMCV(NLMAX,1:IKU))
+ CALL PRECOU_FORDIACHRO(ZWORK3D,ZTEMCV)
+! CALL IMCOU_FORDIACHRO(ZTEMCV,XDIAINT,CLEGEND,YTEXTE( &
+! 1:LEN_TRIM(YTEXTE)))
+ ILENT=LEN_TRIM(CTITGAL)
+ ILENU=LEN_TRIM(CUNITGAL)
+ YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+ YTEXTE(ILENT+1:ILENT+1)=' '
+ YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
+ CALL TRACEV_FORDIACHRO(ZTEMCV,KLOOP,YTEXTE(1: &
+ LEN_TRIM(YTEXTE)))
+ IF(KLOOP == NSUPERDIA)CALL FRAME
+ DEALLOCATE(ZTEMCV)
+ DEALLOCATE(XWORKZ,XWZ)
+
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+
+ ENDIF
+
+!*****************************************************************************
+!*****************************************************************************
+!------------------------------------------------------------------------------
+RETURN
+END SUBROUTINE SUBSPXY
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/tabcol_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/tabcol_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d2800552d0a144efaf9e6fc2ae6807bdeec2c0e7
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/tabcol_fordiachro.f90
@@ -0,0 +1,296 @@
+! ######spl
+ SUBROUTINE TABCOL_FORDIACHRO
+! ############################
+!
+!!**** *TABCOL_FORDIACHRO* - Definition d'une table de couleurs en RGB
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 16/01/95
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+IMPLICIT NONE
+!
+!* 0.1 local variables
+!
+
+REAL,DIMENSION(3,255) :: ZRGB, ZRGB2
+
+INTEGER :: J, JJ, II
+INTEGER :: ISTA, IER,INB, IWK, INBB
+!
+!-------------------------------------------------------------------------------
+!
+CALL GQOPS(ISTA)
+CALL GQACWK(1,IER,INB,IWK)
+!print *,' TABCOL_FORDIACHRO INB IWK ',INB,IWK
+CALL GQOPWK(1,IER,INB,IWK)
+!print *,' TABCOL_FORDIACHRO AP GQOPWK INB IWK ',INB,IWK
+IF(LINVWB)THEN
+CALL GSCR(1,1,0.,0.,0.)
+CALL GSCR(1,0,1.,1.,1.)
+ELSE
+CALL GSCR(1,0,0.,0.,0.)
+CALL GSCR(1,1,1.,1.,1.)
+ENDIF
+IF(ISTA >1 .AND. INB >1)THEN
+! CALL GSCR(2,0,0.,0.,0.)
+! CALL GSCR(2,1,1.,1.,1.)
+ENDIF
+ZRGB(1,1)=1.
+ZRGB(2,1)=1.
+ZRGB(3,1)=1.
+ZRGB(1,2)=1.
+ZRGB(2,2)=0.
+ZRGB(3,2)=0.
+ZRGB(1,3)=0.
+ZRGB(2,3)=1.
+ZRGB(3,3)=0.
+ZRGB(1,4)=0.
+ZRGB(2,4)=0.
+ZRGB(3,4)=1.
+ZRGB(1,5)=0.
+ZRGB(2,5)=1.
+ZRGB(3,5)=1.
+ZRGB(1,6)=1.
+ZRGB(2,6)=0.
+ZRGB(3,6)=1.
+ZRGB(1,7)=1.
+ZRGB(2,7)=1.
+ZRGB(3,7)=0.
+ZRGB(1,8)=1.
+ZRGB(2,8)=.5
+ZRGB(3,8)=0.
+ZRGB(1,9)=.65
+ZRGB(2,9)=.16
+ZRGB(3,9)=0.16
+ZRGB(1,10)=0.86
+ZRGB(2,10)=0.58
+ZRGB(3,10)=.44
+ZRGB(1,11)=0.5
+ZRGB(2,11)=0.
+ZRGB(3,11)=1.
+ZRGB(1,12)=.2
+ZRGB(2,12)=0.56
+ZRGB(3,12)=.8
+ZRGB(1,13)=.14
+ZRGB(2,13)=0.56
+ZRGB(3,13)=.14
+ZRGB(1,14)=.4
+ZRGB(2,14)=.4
+ZRGB(3,14)=.4
+ZRGB(1,15)=.66
+ZRGB(2,15)=.66
+ZRGB(3,15)=.66
+DO J=16,96
+ZRGB(1,J)=.90
+ENDDO
+DO J=16,96,9
+ZRGB(3,J)=0.
+ZRGB(3,J+1)=.125
+ZRGB(3,J+2)=.25
+ZRGB(3,J+3)=.375
+ZRGB(3,J+4)=.5
+ZRGB(3,J+5)=.625
+ZRGB(3,J+6)=.75
+ZRGB(3,J+7)=.875
+ZRGB(3,J+8)=1.
+ENDDO
+DO J=16,24
+ZRGB(2,J)=0.
+ENDDO
+DO J=25,33
+ZRGB(2,J)=.125
+ENDDO
+DO J=34,42
+ZRGB(2,J)=.25
+ENDDO
+DO J=43,51
+ZRGB(2,J)=.375
+ENDDO
+DO J=52,60
+ZRGB(2,J)=.5
+ENDDO
+DO J=61,69
+ZRGB(2,J)=.625
+ENDDO
+DO J=70,78
+ZRGB(2,J)=.75
+ENDDO
+DO J=79,87
+ZRGB(2,J)=.875
+ENDDO
+DO J=88,96
+ZRGB(2,J)=1.
+ENDDO
+!
+DO J=97,177
+ZRGB(1,J)=0.
+ENDDO
+DO J=97,177,9
+ZRGB(3,J)=0.
+ZRGB(3,J+1)=.125
+ZRGB(3,J+2)=.25
+ZRGB(3,J+3)=.375
+ZRGB(3,J+4)=.5
+ZRGB(3,J+5)=.625
+ZRGB(3,J+6)=.75
+ZRGB(3,J+7)=.875
+ZRGB(3,J+8)=1.
+ENDDO
+DO J=97,105
+ZRGB(2,J)=0.
+ENDDO
+DO J=106,114
+ZRGB(2,J)=.125
+ENDDO
+DO J=115,123
+ZRGB(2,J)=.25
+ENDDO
+DO J=124,132
+ZRGB(2,J)=.375
+ENDDO
+DO J=133,141
+ZRGB(2,J)=.5
+ENDDO
+DO J=142,150
+ZRGB(2,J)=.625
+ENDDO
+DO J=151,159
+ZRGB(2,J)=.75
+ENDDO
+DO J=160,168
+ZRGB(2,J)=.875
+ENDDO
+DO J=169,177
+ZRGB(2,J)=1.
+ENDDO
+!
+DO J=178,239
+ZRGB(1,J)=0.5
+ENDDO
+DO J=178,249,9
+ZRGB(3,J)=0.
+ZRGB(3,J+1)=.125
+ZRGB(3,J+2)=.25
+ZRGB(3,J+3)=.375
+ZRGB(3,J+4)=.5
+ZRGB(3,J+5)=.625
+ZRGB(3,J+6)=.75
+ZRGB(3,J+7)=.875
+ZRGB(3,J+8)=1.00
+ENDDO
+DO J=178,186
+ZRGB(2,J)=0.125
+ENDDO
+DO J=187,195
+ZRGB(2,J)=.25
+ENDDO
+DO J=196,204
+ZRGB(2,J)=.375
+ENDDO
+DO J=205,213
+ZRGB(2,J)=.5
+ENDDO
+DO J=214,222
+ZRGB(2,J)=.625
+ENDDO
+DO J=223,231
+ZRGB(2,J)=.75
+ENDDO
+DO J=232,240
+ZRGB(2,J)=.875
+ENDDO
+!
+ZRGB2(:,1:240)=ZRGB(:,1:240)
+IF(LTABCOLDEF2)THEN
+ DO JJ=18,90,9
+ ZRGB(:,JJ)=ZRGB2(:,JJ+1)
+ ENDDO
+ DO JJ=19,91,9
+ ZRGB(:,JJ)=ZRGB2(:,JJ+2)
+ ENDDO
+ DO JJ=20,92,9
+ ZRGB(:,JJ)=ZRGB2(:,JJ+3)
+ ENDDO
+ DO JJ=21,93,9
+ ZRGB(:,JJ)=ZRGB2(:,JJ+3)
+ ENDDO
+ DO JJ=22,94,9
+ ZRGB(:,JJ)=ZRGB2(:,JJ+75)
+ ENDDO
+ DO JJ=23,95,9
+ ZRGB(:,JJ)=ZRGB2(:,JJ+76)
+ ENDDO
+ DO JJ=24,96,9
+ ZRGB(:,JJ)=ZRGB2(:,JJ+76)
+ ENDDO
+ DO JJ=97,105
+ IF(JJ == 97)II=0
+ IF(JJ > 97)II=II+8
+ ZRGB(:,JJ)=ZRGB2(:,JJ+5+II)
+ ENDDO
+ DO JJ=106,114
+ IF(JJ == 106)II=0
+ IF(JJ > 106)II=II+8
+ ZRGB(:,JJ)=ZRGB2(:,JJ-3+II)
+ ENDDO
+ DO JJ=115,123
+ IF(JJ == 115)II=0
+ IF(JJ > 115)II=II+8
+ ZRGB(:,JJ)=ZRGB2(:,JJ-10+II)
+ ENDDO
+ ZRGB(:,22)=ZRGB2(:,232)
+ ZRGB(:,124)=ZRGB2(:,186)
+ ZRGB(:,125)=ZRGB2(:,195)
+ ZRGB(:,126)=ZRGB2(:,204)
+ ZRGB(:,127)=ZRGB2(:,222)
+ ZRGB(:,128)=ZRGB2(:,231)
+ENDIF
+! En raison de problemes avec la couleur pour certains terminaux, on ne definit
+! que 128 couleurs (Confirmation avec le terminal de Karsten)
+!DO J=2,237
+DO J=2,128
+DO JJ=1,INB
+ CALL GQOPWK(JJ,IER,INBB,IWK)
+! print *,' TABCOL_FORDIACHRO JJ,INBB,IWK ',JJ,INBB,IWK
+ IF(IWK == 9)THEN
+ CYCLE
+ ELSE
+ CALL GSCR(IWK,J,ZRGB(1,J),ZRGB(2,J),ZRGB(3,J))
+ ENDIF
+ENDDO
+ENDDO
+!
+!
+RETURN
+END SUBROUTINE TABCOL_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/tit_tra3d.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/tit_tra3d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..48cccfc3492708df85a19d73155221b7db6883c0
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/tit_tra3d.f90
@@ -0,0 +1,216 @@
+! ####################
+ MODULE MODI_TIT_TRA3D
+! ####################
+INTERFACE
+!
+ SUBROUTINE TIT_TRA3D(HCAR,HTEM1,HTEM2,PVR)
+CHARACTER(LEN=75) :: HCAR
+CHARACTER(LEN=*) :: HTEM1,HTEM2
+REAL :: PVR
+END SUBROUTINE TIT_TRA3D
+END INTERFACE
+END MODULE MODI_TIT_TRA3D
+! ####################
+ SUBROUTINE TIT_TRA3D(HCAR,HTEM1,HTEM2,PVR)
+! ####################
+!
+USE MODD_TIT
+USE MODD_RESOLVCAR
+!
+IMPLICIT NONE
+!
+CHARACTER(LEN=75) :: HCAR
+CHARACTER(LEN=*) :: HTEM1,HTEM2
+REAL :: PVR
+!
+CHARACTER(LEN=60) :: YTEM
+CHARACTER(LEN=40) :: YTEM40
+CHARACTER(LEN=75) :: YPLANH
+REAL :: ZXPOSTITT1,ZXYPOSTITT1
+REAL :: ZXPOSTITT2,ZXYPOSTITT2
+REAL :: ZXPOSTITT3,ZXYPOSTITT3
+REAL :: ZXPOSTITB1,ZXYPOSTITB1
+REAL :: ZXPOSTITB2,ZXYPOSTITB2
+REAL :: ZXPOSTITB3,ZXYPOSTITB3
+REAL :: ZSZTITVAR1,ZSZTITVAR2
+REAL :: ZSZTITVAR3
+!
+! Titres TOP
+!***********************************************
+! Titre N1 TOP
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ YPLANH=' '
+ YPLANH=HCAR
+ ZXPOSTITT1=.002
+ ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+! WRITE(YPLANH,1001)NIINF,NISUP,NJINF,NJSUP
+ CALL RESOLV_TIT('CTITT1',YPLANH)
+ IF(YPLANH /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PCSETC('FC','/')
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YPLANH,XSZTITT1,0.,-1.)
+ CALL PCSETC('FC',':')
+! CALL PLCHHQ(0.002,0.98,YPLANH,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PCSETC('FC','/')
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YPLANH,.012,0.,-1.)
+ CALL PCSETC('FC',':')
+! CALL PLCHHQ(0.002,0.98,YPLANH,.012,0.,-1.)
+ ENDIF
+ ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! TOP2
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ YTEM(1:LEN(YTEM))=' '
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.95
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! TOP3
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ZXPOSTITT3=.002
+ ZXYPOSTITT3=.93
+ IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ ENDIF
+ IF(XYPOSTITT3 /= 0.)THEN
+ ZXYPOSTITT3=XYPOSTITT3
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT3',YTEM)
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,XSZTITT3,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Titres BOTTOM
+!***********************************************
+! Titre N1 BOTTOM
+ ZXPOSTITB1=.002
+ ZXYPOSTITB1=.005
+ IF(XPOSTITB1 /= 0.)THEN
+ ZXPOSTITB1=XPOSTITB1
+ ENDIF
+ IF(XYPOSTITB1 /= 0.)THEN
+ ZXYPOSTITB1=XYPOSTITB1
+ ENDIF
+ CALL RESOLV_TIT('CTITB1',HTEM1)
+ if(nverbia > 0)then
+ print *,' *CTITB1=',HTEM1
+ endif
+ IF(HTEM1 /= ' ')THEN
+ IF(XSZTITB1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HTEM1(1:LEN_TRIM(HTEM1)),XSZTITB1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HTEM1(1:LEN_TRIM(HTEM1)),.007,0.,-1.)
+ ENDIF
+ ENDIF
+! Titre N3 BOTTOM
+ ZXPOSTITB3=.002
+ ZXYPOSTITB3=.045
+ IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ ENDIF
+ IF(XYPOSTITB3 /= 0.)THEN
+ ZXYPOSTITB3=XYPOSTITB3
+ ENDIF
+
+ YTEM(1:LEN(YTEM))=' '
+! YTEM=CTIMEC
+ YTEM=ADJUSTL(YTEM)
+ CALL RESOLV_TIT('CTITB3',YTEM)
+ if(nverbia > 0)then
+! print *,' image LEN et CTIMEC ',LEN(CTIMEC),CTIMEC
+! print *,' image LEN et YTEM ',LEN(YTEM),YTEM
+ print *,' *CTITB3=',YTEM
+ endif
+ IF(YTEM/= ' ')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM(1:LEN_TRIM(YTEM)),XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM(1:LEN_TRIM(YTEM)),.009,0.,-1.)
+ ENDIF
+ ENDIF
+
+! Titre N2 BOTTOM
+ ZXPOSTITB2=.002
+ ZXYPOSTITB2=.025
+ IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ ENDIF
+ IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ ENDIF
+ CALL RESOLV_TIT('CTITB2',HTEM2)
+ if(nverbia > 0)then
+ print *,' *CTITB2=',HTEM2
+ endif
+ IF(HTEM2 /= ' ')THEN
+ IF(XSZTITB2 /= 0.)THEN
+ CALL PLCHHQ(0.002,0.025,HTEM2,XSZTITB2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.002,0.025,HTEM2,.007,0.,-1.)
+ ENDIF
+ ENDIF
+!
+!!!!!! CTITVAR
+ YTEM40(1:LEN(YTEM40))=' '
+ CALL RESOLV_TIT('CTITVAR1',YTEM40)
+ YTEM40=ADJUSTL(YTEM40)
+ IF(YTEM40 /= ' ')THEN
+ ZSZTITVAR1=.011
+ IF(XSZTITVAR1 /= 0.)THEN
+ ZSZTITVAR1=XSZTITVAR1
+ ENDIF
+!! print *,' *YTEM40 ',YTEM40(1:LEN_TRIM(YTEM40))
+ CALL PLCHHQ(MAX(PVR,.99),.007,YTEM40(1:LEN_TRIM(YTEM40)),ZSZTITVAR1,0.,+1.)
+ ENDIF
+ YTEM40(1:LEN(YTEM40))=' '
+ CALL RESOLV_TIT('CTITVAR2',YTEM40)
+ IF(YTEM40 /= ' ')THEN
+ ZSZTITVAR2=.011
+ IF(XSZTITVAR2 /= 0.)THEN
+ ZSZTITVAR2=XSZTITVAR2
+ ENDIF
+ CALL PLCHHQ(MAX(PVR,.99),.007+.017,YTEM40(1:LEN_TRIM(YTEM40)),ZSZTITVAR2,0.,+1.)
+ ENDIF
+ YTEM40(1:LEN(YTEM40))=' '
+ CALL RESOLV_TIT('CTITVAR3',YTEM40)
+ IF(YTEM40 /= ' ')THEN
+ ZSZTITVAR3=.011
+ IF(XSZTITVAR3 /= 0.)THEN
+ ZSZTITVAR3=XSZTITVAR3
+ ENDIF
+ CALL PLCHHQ(MAX(PVR,.99),.007+.034,YTEM40(1:LEN_TRIM(YTEM40)),ZSZTITVAR3,0.,+1.)
+ ENDIF
+!
+! Titres en X et Y
+!*****************************************
+
+END SUBROUTINE TIT_TRA3D
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/traceh_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/traceh_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8404b58ed2f4f769fbb798ed09b80ab8c40ceb36
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/traceh_fordiachro.f90
@@ -0,0 +1,830 @@
+! ######spl
+ MODULE MODI_TRACEH_FORDIACHRO
+! #############################
+!
+INTERFACE
+!
+SUBROUTINE TRACEH_FORDIACHRO(KLREF,P3D,KLOOP)
+REAL,DIMENSION(:,:,:) :: P3D
+INTEGER :: KLREF,KLOOP
+END SUBROUTINE TRACEH_FORDIACHRO
+!
+END INTERFACE
+!
+END MODULE MODI_TRACEH_FORDIACHRO
+! #############################################
+ SUBROUTINE TRACEH_FORDIACHRO(KLREF,P3D,KLOOP)
+! #############################################
+!
+!!**** *TRACEH_FORDIACHRO* - Manager for the horizontal cross-section plots
+!!
+!! PURPOSE
+!! -------
+! In the case of horizontal cross-sections, call the interpolation and
+! display routines: - for contour plots
+! - for vector arrow plots
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!! VALNGRID : retrieves the NGRID grid number when given the variable name
+!! COMCOORD : computes true altitudes corresponding to the NGRID value
+!! INTERP : vertically interpolates horizontal cross-sections
+!! IMAGE : contour plot manager for horizontal cross-sections
+!! IMAGEV : vector plot manager for horizontal cross-sections
+!! READ_ALLVAR: reads any generic variable from the LFIFM file given its name
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_TITLE : Declares heading variables for the plots (TRACE)
+!! NCONT : Current plot number
+!!
+!! Module MODD_NMGRID : declares global variable NMGRID (TRACE)
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!! NHI : Extrema detection
+!! (=0 --> H+L, <0 nothing)
+!! NDOT : Line style
+!! (=0|1|1023|65535 --> solid lines;
+!! <0 --> solid lines for positive values and
+!! dotted lines(ABS(NDOT))for negative values;
+!! >0 --> dotted lines(ABS(NDOT)) )
+!! CTYPHOR : Horizontal cross-section type
+!! (='K' --> model level section;
+!! ='Z' --> constant-altitude section;
+!! ='P' --> isobar section (planned)
+!! ='T' --> isentrope section (planned)
+!!
+!! Module MODD_OUT : defines various logical units and dimensions
+!! NIMAXT : x-size of the displayed section of the MESO-NH arrays
+!! NJMAXT : y-size of the displayed section of the MESO-NH arrays
+!! NKMAXT : z-size of the displayed section of the MESO-NH arrays
+!!
+!! Module MODN_PARA
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NKMAX : z array dimensions
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!! JPVEXT : Vertical external points number
+!!
+!! Module MODD_SUPER : defines plot overlay control variables
+!! LSUPER : =.TRUE. --> plot overlay is active
+!! =.FALSE. --> plot overlay is not active
+!! NSUPER : Rank of the current plot in the overlay
+!! sequence. The initial plot is rank 1.
+!!
+!!
+!! Module MODD_ALLVAR : contains generic variables arrays and structures
+!! XWORK3D : 3D generic scalar field array
+!! XWORKX3D : 3D generic vector field x-component array
+!! XWORKY3D : 3D generic vector field y-component array
+!! XWORKZ3D : 3D generic vector field z-component array
+!! XWORK2D : 2D generic scalar field
+!! XWORKX3D : 2D generic vector field x-component array
+!! XWORKY3D : 2D generic vector field y-component array
+!!>>>>>DRAGOON
+!!>>>>>DRAGOON NOTICE: I don't see why a 2D generic vector should not have
+!!>>>>>DRAGOON a w-component as well. Exemple: a 2D map of the u-w
+!! vectors...
+!!>>>>>DRAGOON
+!! XT1 : structure defining the name, grid number and unit name
+!! for a 3D generic scalar field (TRACE derived type X_Y_Z_)
+!! XT2 : structure defining the name, grid number and unit name
+!! for a 2D generic scalar field (TRACE derived type X_Y_)
+!! XT3 : structure defining the name, grid numbers and unit name
+!! for a 3D generic 3D vector field
+!! (TRACE derived type VX_VY_VZ_)
+!! XT4 : structure defining the name, grid numbers and unit name
+!! for a 2D generic 2D vector field
+!! (TRACE derived type VX_VY_)
+!! XT5 : structure defining the name, grid number and unit name
+!! for a 1D generic scalar field (TRACE derived type Z_)
+!!
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 06/12/94
+!! Updated JD 09/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_TITLE
+USE MODD_MASK3D
+USE MODD_TIT
+USE MODD_DEFCV
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_NMGRID
+USE MODN_NCAR
+USE MODD_OUT
+USE MODD_DIM1
+USE MODN_PARA
+USE MODD_PARAMETERS
+USE MODD_TYPE_AND_LH
+USE MODD_SUPER
+USE MODD_ALLVAR
+USE MODI_INTERP_FORDIACHRO
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODD_COORD
+USE MODI_RESOLV_TIT
+USE MODI_RESOLV_TITY
+USE MODI_COMPUTEDIR
+
+IMPLICIT NONE
+!
+!* 0.1 Interfaces declaration
+!
+INTERFACE
+ SUBROUTINE PRECOU_FORDIACHRO(PWORK3D,PTEMCV)
+ REAL,DIMENSION(:,:,:) :: PWORK3D
+ REAL,DIMENSION(:,:) :: PTEMCV
+ END SUBROUTINE PRECOU_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE IMAGE_FORDIACHRO(PTAB,KLREF,PTABINT,KNHI,KNDOT,HTEXTE)
+ CHARACTER(LEN=*) :: HTEXTE
+ REAL :: PTABINT
+ REAL,DIMENSION(:,:) :: PTAB
+ INTEGER :: KNHI, KNDOT, KLREF
+ END SUBROUTINE IMAGE_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE IMAGEV_FORDIACHRO(PU,PV,KLREF,HTEXTE)
+ REAL,DIMENSION(:,:) :: PU,PV
+ CHARACTER(LEN=*) :: HTEXTE
+ INTEGER :: KLREF
+ END SUBROUTINE IMAGEV_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE TRAXY(PTEMX,PTEMY,KLOOP,HTITX,HTITY,PTIMED,PTIMEF)
+ INTEGER :: KLOOP
+ REAL,DIMENSION(:) :: PTEMX, PTEMY
+ REAL :: PTIMED, PTIMEF
+ CHARACTER(LEN=*) :: HTITX, HTITY
+ END SUBROUTINE TRAXY
+END INTERFACE
+INTERFACE
+ SUBROUTINE TRAHTRAXY(KLOOP,PTEMCV,HTEXTE)
+ INTEGER :: KLOOP
+ REAL,DIMENSION(:,:) :: PTEMCV
+ CHARACTER(LEN=40) :: HTEXTE
+ END SUBROUTINE TRAHTRAXY
+END INTERFACE
+!
+COMMON/TEMH/XZZX,XZZY,NIIMAX,NIJMAX
+#include "big.h"
+REAL,DIMENSION(N2DVERTX) :: XZZX
+REAL,DIMENSION(N2DVERTX) :: XZZY
+INTEGER :: NIIMAX, NIJMAX
+!
+!
+!* 0.15 Dummy arguments
+!
+INTEGER :: KLREF, KLOOP, JU
+REAL,DIMENSION(:,:,:) :: P3D
+!
+!* 0.2 local variables
+!
+
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: ZTEM, ZTEM2
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZX
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZSTAB, ZSTAB1, ZSTAB2, ZTEMCV,ZSTABM
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZTEMX, ZTEMY
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZZY
+
+REAL :: ZTIMED, ZTIMEF
+
+INTEGER :: ITER, JTER, IUB1, IUB2, ISKIP
+INTEGER :: ISTA, IER, INB, IWK
+INTEGER :: IWIU, IWJU
+INTEGER :: ILENT, ILENU, ILENCTIMECS, ILENE
+INTEGER :: IBEGTXT, IENDTXT
+
+CHARACTER(LEN=20) :: YNOM
+CHARACTER(LEN=40) :: YTEXTE
+CHARACTER(LEN=15) :: YEND
+CHARACTER(LEN=8) :: YCAR8
+CHARACTER(LEN=16) :: YTITX, YTITY
+
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. PRELIMINARY CALCULATION
+! -----------------------
+!
+if(nverbia > 0)then
+ print *,' **entree traceh LPR,LTK,LEV,LSV3,CTYPHOR ', LPR,LTK,LEV,LSV3,CTYPHOR
+endif
+NIMAXT=NISUP-NIINF+1
+NJMAXT=NJSUP-NJINF+1
+NKMAXT=NKMAX+2*JPVEXT
+!
+!* 1.1 Array allocations
+!
+IF(ALLOCATED(ZSTAB))THEN
+ DEALLOCATE(ZSTAB)
+END IF
+ ALLOCATE(ZSTAB(NIMAXT,NJMAXT))
+!
+!* 1.2 NCAR setting
+!
+!
+!* 1.3 Interactive option selection and plot overlay management
+!
+!
+IWIU=SIZE(P3D,1)
+IWJU=SIZE(P3D,2)
+if(nverbia >0)then
+ print *,' ** Entree traceh KLREF ',KLREF
+endif
+YNOM=ADJUSTL(CGROUP)
+IF(YNOM.EQ.'QUIT')THEN
+ CALL GQOPS(ISTA)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(ISTA >1 .AND. INB >1)THEN
+ CALL GDAWK(2)
+ CALL GCLWK(2)
+ ENDIF
+! CALL FRAME
+ CALL NGPICT(1,1)
+ CALL CLSGKS
+ STOP
+END IF
+
+IBEGTXT=1
+IENDTXT=LEN(YTEXTE)
+
+IF(NSUPERDIA > 1)THEN
+ IF(LMINUS .OR. LPLUS)THEN
+ IF(NBPM > 1)THEN
+ DO JU=1,NBPM
+ IF(NUMPM(JU) == 3)THEN
+ LSUPER=.TRUE.
+ EXIT
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ ENDDO
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ ELSE
+ LSUPER=.TRUE.
+ ENDIF
+ELSE
+ LSUPER=.FALSE.
+ENDIF
+IF(KLOOP == 1)NSUPER=0
+XLWIDTH=XLWDEF
+!
+!
+! Selects "model levels" mode
+!
+!
+! Selects altitude mode
+!
+
+! If no keyword has been detected so far, TRACE tries to
+! interpret the last entry as a new model level number.
+!
+!
+IF(.NOT.LCN .AND. .NOT.LCNCUM)THEN
+IF (CTYPHOR.EQ.'K')THEN
+ IF(LMSKTOP)THEN
+ KLREF=NKH
+ ELSE
+ IF(KLREF.GT.NKH.OR.KLREF.LT.NKL)THEN
+! IF(KLREF.GT.NKMAX+2*JPVEXT.OR.KLREF.LT.1)THEN
+ print *,' This model level is unknown!'
+ END IF
+ END IF
+END IF
+END IF
+!
+!* 2. PROCESSING OF THE BASIC SET OF VARIABLES
+! ---------------------------------------------------
+
+! WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A8,2X,A1,''='',I5)')CGROUP,CTYPHOR,KLREF
+
+ YTEXTE(1:LEN(YTEXTE))=' '
+ IBEGTXT=1
+ ILENT=LEN_TRIM(CTITGAL)
+ ILENU=LEN_TRIM(CUNITGAL)
+
+IF(LCN .OR. LCNCUM)THEN
+ YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+
+ ZSTAB(:,:)=P3D(:,:,1)
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+ IF(LCN)THEN
+ YTEXTE(ILENT+1:ILENT+1)=' '
+ YTEXTE(ILENT+2:ILENT+9)=ADJUSTL(CTIMEC(8:15))
+ ELSE
+ YCAR8(1:LEN(YCAR8))=' '
+ YTEXTE(ILENT+1:ILENT+1)=' '
+ YTEXTE(ILENT+2:ILENT+9)=ADJUSTL(CTIMECS(8:15))
+ ILENT=LEN_TRIM(YTEXTE)
+ YTEXTE(ILENT+1:ILENT+1)='-'
+ ILENCTIMECS=LEN_TRIM(CTIMECS)
+ YCAR8=CTIMECS(ILENCTIMECS-7:ILENCTIMECS)
+ YTEXTE(ILENT+2:ILENT+9)=ADJUSTL(YCAR8)
+ ENDIF
+ CALL IMAGE_FORDIACHRO(ZSTAB,KLREF,XDIAINT,NHI,NDOT,YTEXTE(1: &
+ LEN_TRIM(YTEXTE)))
+
+ELSE
+
+ !YTEXTE(ILENT+1:ILENT+1)=' '
+ !YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
+ !IBEGTXT=ILENT+2+ILENU
+ !YTEXTE(IBEGTXT:IBEGTXT+2)=' '
+ !IBEGTXT=IBEGTXT+3
+
+ YEND(1:LEN(YEND))=' '
+
+ IF(LEV .AND. CTYPHOR(1:1)=='E')THEN
+ IF(LCHREEL)THEN
+ WRITE(YEND,'(A2,''='',F7.1)')'PV',XLOOPZ
+ ILENE=LEN_TRIM(YEND)
+ !WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A2,''='',F7.1)')'PV',XLOOPZ
+ ELSE
+ WRITE(YEND,'(A2,''='',I5)')'PV',KLREF
+ ILENE=LEN_TRIM(YEND)
+ !WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A2,''='',I5)')'PV',KLREF
+ ENDIF
+ ELSE IF(LMSKTOP)THEN
+ WRITE(YEND,'(A9)')' MSKTOP=T'
+ ILENE=LEN_TRIM(YEND)
+ !WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A9)')' MSKTOP=T'
+ ELSE IF(LSV3)THEN
+ IF(LXYZ00)THEN
+ IF(LCHREEL .AND. CTYPHOR /= 'K')THEN
+ WRITE(YEND,'(A5,''='',F7.1)')CGROUPSV3(1:5),XLOOPZ
+ ILENE=LEN_TRIM(YEND)
+ !WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A4,''='',F7.1)')CGROUPSV3(1:4),XLOOPZ
+ ELSE
+ WRITE(YEND,'(A5,''='',I5)')CGROUPSV3(1:5),KLREF
+ ILENE=LEN_TRIM(YEND)
+ !WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A4,''='',I5)')CGROUPSV3(1:4),KLREF
+! WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A4,''='',I5)')' Z00',KLREF
+ ENDIF
+ ELSE
+ IF(LCHREEL .AND. CTYPHOR /= 'K')THEN
+ WRITE(YEND,'(A3,''='',F7.1)')'SV3',XLOOPZ
+ ILENE=LEN_TRIM(YEND)
+ !WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A3,''='',F7.1)')'SV3',XLOOPZ
+ ELSE
+ WRITE(YEND,'(A3,''='',I5)')'SV3',KLREF
+ ILENE=LEN_TRIM(YEND)
+ !WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A3,''='',I5)')'SV3',KLREF
+ ENDIF
+ ENDIF
+ ELSE
+ IF(LXYZ)THEN
+ IF(LCHREEL .AND. CTYPHOR /= 'K')THEN
+ WRITE(YEND,'(A1,''='',F7.1,A6)')CTYPHOR,XLOOPZ,' MSK=T'
+ ILENE=LEN_TRIM(YEND)
+ !WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A1,''='',F7.1,A6)')CTYPHOR,XLOOPZ,' MSK=T'
+ ELSE
+ WRITE(YEND,'(A1,''='',I5,A6)')CTYPHOR,KLREF,' MSK=T'
+ ILENE=LEN_TRIM(YEND)
+ !WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A1,''='',I5,A6)')CTYPHOR,KLREF,' MSK=T'
+ ENDIF
+ ELSE
+ IF(LCHREEL .AND. CTYPHOR /= 'K')THEN
+ WRITE(YEND,'(A1,''='',F7.1)')CTYPHOR,XLOOPZ
+ ILENE=LEN_TRIM(YEND)
+ !WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A1,''='',F7.1)')CTYPHOR,XLOOPZ
+ ELSE
+ WRITE(YEND,'(A1,''='',I5)')CTYPHOR,KLREF
+ ILENE=LEN_TRIM(YEND)
+ !WRITE(YTEXTE(IBEGTXT:IENDTXT),'(A1,''='',I5)')CTYPHOR,KLREF
+ ENDIF
+ ENDIF
+ ENDIF
+ ! YTEXTE est rempli a partir de la fin
+ IBEGTXT=IENDTXT-ILENE+1
+ YTEXTE(IBEGTXT:IENDTXT)=TRIM(YEND)
+ ! 3 car blancs
+ IENDTXT=IBEGTXT-1
+ IBEGTXT=IENDTXT-2
+ YTEXTE(IBEGTXT:IENDTXT)=' '
+ ! unite
+ IENDTXT=IBEGTXT-1
+ IBEGTXT=IENDTXT-ILENU+1
+ YTEXTE(IBEGTXT:IENDTXT)=CUNITGAL(1:ILENU)
+ ! 1 car blanc
+ IENDTXT=IBEGTXT-1
+ IBEGTXT=IENDTXT
+ YTEXTE(IBEGTXT:IENDTXT)=' '
+ ! titre (tronque eventuellement)
+ IENDTXT=IBEGTXT-1
+ IBEGTXT=MAX(1,IENDTXT-ILENT+1)
+ YTEXTE(IBEGTXT:IENDTXT)=CTITGAL(1:ILENT)
+ YTEXTE=ADJUSTL(YTEXTE)
+if(nverbia > 0)then
+ print*,' ** TRACEH: TIT=',CTITGAL(1:ILENT),' UNIT=',CUNITGAL(1:ILENU),&
+ ' TEXTE= ',TRIM(YTEXTE)
+endif
+
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ IF(LUMVM .OR. LUTVT .OR. LMUMVM .OR. LMUTVT .OR. &
+ LDIRWM .OR. LDIRWT .OR. &
+ LSUMVM .OR. LSUTVT .OR. LMLSUMVM .OR. LMLSUTVT)THEN
+ ALLOCATE(ZTEM(IWIU,IWJU,SIZE(P3D,3)))
+ ALLOCATE(ZSTAB1(IWIU,IWJU))
+ ALLOCATE(ZSTAB2(IWIU,IWJU))
+ IF(NGRIDIA(1) == 1)THEN
+ ZTEM(:,:,:)=P3D(:,:,:)
+ print *,' *****TRACEH.. PAS D''INTERPOLATION de U sur la grille de masse, GROUPE: ',CGROUP,' IGRID: ',NGRIDIA(1)
+ ELSE
+ ZTEM(1:IWIU-1,:,:)=0.5*(P3D(1:IWIU-1,:,:)+P3D(2:IWIU,:,:))
+ ZTEM(IWIU,:,:)=2.*ZTEM(IWIU-1,:,:)-ZTEM(IWIU-2,:,:)
+ ENDIF
+!!!!!!!!!!PROVISOIRE POUR VERIF
+! ZTEM(5,:,:)=10.
+ CALL INTERP_FORDIACHRO(KLREF,NKL,NKH,ZTEM,ZSTAB1)
+if(nverbia >0)then
+ print *,' ** Traceh AP INTERP1 KLREF ',KLREF
+endif
+
+! Avril 2000 LCV+LCH+LUMVM ou LUTVT -> PH vecteurs
+! Traitement U
+ IF(LCV)THEN
+! Je remets le plan horizontal demande (ZSTAB1) arbitrairement au niveau 2 ou
+! NKL de ZTEM et je fais toutes les operations concernant une coupe verticale
+! (sauf pour le 2D horizontal)
+ IF(SIZE(ZTEM,3) == 1)THEN
+ ZTEM(:,:,1)=ZSTAB1(:,:)
+ ELSE
+ ZTEM(:,:,MAX(2,NKL))=ZSTAB1(:,:)
+ ENDIF
+ CALL VERIFLEN_FORDIACHRO
+ CALL MEMCV
+ IF(ALLOCATED(ZTEMCV))THEN
+ DEALLOCATE(ZTEMCV)
+ ENDIF
+ IF(NVERBIA >0)THEN
+ print *,' ** TRACEH av PRECOU NLMAX IKU ',NLMAX,SIZE(ZTEM,3)
+ ENDIF
+ ALLOCATE(ZTEMCV(NLMAX,1:SIZE(ZTEM,3)))
+ IF(ALLOCATED(XTEMCVU))THEN
+ DEALLOCATE(XTEMCVU)
+ ENDIF
+ ALLOCATE(XTEMCVU(NLMAX,1))
+ CALL PRECOU_FORDIACHRO(ZTEM,ZTEMCV)
+ IF(SIZE(ZTEMCV,2) == 1)THEN
+ XTEMCVU(:,1)=ZTEMCV(:,1)
+ ELSE
+ XTEMCVU(:,1)=ZTEMCV(:,2)
+ ENDIF
+ DEALLOCATE(ZTEMCV)
+ ENDIF
+! Avril 2000
+
+ DEALLOCATE(ZTEM)
+ IF(NVERBIA > 0)THEN
+ print *,' DEALLOCATE(ZTEM) '
+ ENDIF
+
+! Traitement V
+ ALLOCATE(ZTEM2(IWIU,IWJU,SIZE(P3D,3)))
+ ZTEM2(:,:,:)=XVAR(NIINF-NIL+1:NISUP-NIL+1, &
+ NJINF-NJL+1:NJSUP-NJL+1, &
+ :,NLOOPT,1,1)
+ IF(NGRIDIA(1) == 1)THEN
+ print *,' *****TRACEH.. PAS D''INTERPOLATION de V sur la grille de masse, GROUPE: ',CGROUP,' IGRID: ',NGRIDIA(1)
+ ELSE
+ ZTEM2(:,1:IWJU-1,:)=0.5*(ZTEM2(:,1:IWJU-1,:)+ZTEM2(:,2:IWJU,:))
+ ZTEM2(:,IWJU,:)=2.*ZTEM2(:,IWJU-1,:)-ZTEM2(:,IWJU-2,:)
+ ENDIF
+!!!!!!!!!!PROVISOIRE POUR VERIF
+! ZTEM(:,10,:)=10.
+ CALL INTERP_FORDIACHRO(KLREF,NKL,NKH,ZTEM2,ZSTAB2)
+if(nverbia >0)then
+ print *,' ** Traceh AP INTERP2 KLREF ',KLREF
+endif
+! Avril 2000 LCV+LCH+LUMVM ou LUTVT -> PH vecteurs
+ IF(LCV)THEN
+! Je remets le plan horizontal demande (ZSTAB2) arbitrairement au niveau 2 ou
+! NKL de ZTEM2 et je fais toutes les operations concernant une coupe verticale
+! (sauf pour le 2D horizontal)
+ IF(SIZE(ZTEM2,3) == 1)THEN
+ ZTEM2(:,:,1)=ZSTAB2(:,:)
+ ELSE
+ ZTEM2(:,:,MAX(2,NKL))= ZSTAB2(:,:)
+ ENDIF
+ CALL VERIFLEN_FORDIACHRO
+ CALL MEMCV
+ IF(ALLOCATED(ZTEMCV))THEN
+ DEALLOCATE(ZTEMCV)
+ ENDIF
+ IF(NVERBIA >0)THEN
+ print *,' ** TRACEH av PRECOU NLMAX IKU ',NLMAX,SIZE(ZTEM2,3)
+ ENDIF
+ ALLOCATE(ZTEMCV(NLMAX,1:SIZE(ZTEM2,3)))
+ IF(ALLOCATED(XTEMCVV))THEN
+ DEALLOCATE(XTEMCVV)
+ ENDIF
+ ALLOCATE(XTEMCVV(NLMAX,1))
+ CALL PRECOU_FORDIACHRO(ZTEM2,ZTEMCV)
+! Nov 2001
+! XTEMCVV(:,1)=ZTEMCV(:,2)
+ IF(SIZE(ZTEMCV,2) == 1)THEN
+ XTEMCVV(:,1)=ZTEMCV(:,1)
+ ELSE
+ XTEMCVV(:,1)=ZTEMCV(:,2)
+ ENDIF
+! Nov 2001
+ DEALLOCATE(ZTEMCV)
+ ENDIF
+! Avril 2000
+ DEALLOCATE(ZTEM2)
+ IF(NVERBIA > 0)THEN
+ print *,' DEALLOCATE(ZTEM2) '
+ ENDIF
+
+ IF(LUMVM .OR. LUTVT .OR. LSUMVM .OR. LSUTVT .OR. LDIRWM .OR. LDIRWT .OR. &
+ LMUMVM .OR.LMUTVT)THEN
+! Avril 2000 LCV+LCH+LUMVM ou LUTVT -> PH vecteurs
+ IF(LCV)THEN
+!! Nov 2001
+ IF(LMUMVM .OR.LMUTVT)THEN
+ IF(ALLOCATED(ZTEMCV))THEN
+ DEALLOCATE(ZTEMCV)
+ ENDIF
+! print *,' XTEMCVU ',XTEMCVU
+! print *,' XTEMCVV ',XTEMCVV
+ ALLOCATE(ZTEMCV(SIZE(XTEMCVU,1),SIZE(XTEMCVU,2)))
+ WHERE(XTEMCVV(:,:) == XSPVAL)XTEMCVU=XSPVAL
+ WHERE(XTEMCVU(:,:) == XSPVAL)XTEMCVV=XSPVAL
+ WHERE(XTEMCVU(:,:) /= XSPVAL)ZTEMCV=XTEMCVU*XTEMCVU
+ XTEMCVU=ZTEMCV
+ WHERE(XTEMCVV(:,:) /= XSPVAL)ZTEMCV=XTEMCVV*XTEMCVV
+ XTEMCVV=ZTEMCV
+ WHERE(XTEMCVU(:,:) /= XSPVAL)XTEMCVU=SQRT(XTEMCVU+XTEMCVV)
+ CALL TRAHTRAXY(KLOOP,XTEMCVU,YTEXTE)
+ DEALLOCATE(ZTEMCV)
+
+ ELSEIF(LDIRWM .OR. LDIRWT)THEN
+ IUB1=SIZE(XTEMCVU,1)
+ IUB2=SIZE(XTEMCVU,2)
+ ISKIP=1
+ ITER=IUB1; JTER=IUB2
+ IF(ALLOCATED(ZX))THEN
+ DEALLOCATE(ZX)
+ ENDIF
+ IF(ALLOCATED(ZZY))THEN
+ DEALLOCATE(ZZY)
+ ENDIF
+ ALLOCATE(ZX(ITER,1),ZZY(JTER))
+ print *,' **traceh av ZX,ZZY '
+ ZX(:,1)=XZZX(1:IUB1:ISKIP)
+ ZZY=XZZY(1:IUB2:ISKIP)
+ print *,' **traceh aP ZX,ZZY ',ZX(1:IUB1,1)
+ print *,' **traceh aP ZX,ZZY ',ZZY(1:IUB2)
+! Calcul de la direction du vent par DIR.... Retour ds XTEMCVV
+ CALL COMPUTEDIR(ITER,JTER,IUB1,IUB2,ISKIP,XTEMCVU,XTEMCVV)
+ print *,' **traceh ap computedir , av trahtraxy'
+ CALL TRAHTRAXY(KLOOP,XTEMCVV,YTEXTE)
+
+ ENDIF
+!! Nov 2001
+ ELSE
+! Avril 2000
+ IF(LMUMVM .OR.LMUTVT)THEN
+ ZSTAB(:,:)=SQRT(ZSTAB1(:,:)**2+ZSTAB2(:,:)**2)
+ WHERE(ZSTAB1(:,:) == XSPVAL)ZSTAB=XSPVAL
+ WHERE(ZSTAB2(:,:) == XSPVAL)ZSTAB=XSPVAL
+ CALL IMAGE_FORDIACHRO(ZSTAB,KLREF,XDIAINT,NHI,NDOT,YTEXTE(1:LEN_TRIM(YTEXTE)))
+ ELSE IF((LDIRWM.OR.LDIRWT).AND. .NOT. LDIRWIND) THEN
+ !! direction par DD....
+ print*,'traceh dd ',minval(ZSTAB1),maxval(ZSTAB1),minval(ZSTAB2), &
+ maxval(ZSTAB2)
+ print*,'traceh dd ',minloc(ZSTAB1),maxloc(ZSTAB1),minloc(ZSTAB2), &
+ maxloc(ZSTAB2)
+ IUB1=SIZE(ZSTAB1,1)
+ IUB2=SIZE(ZSTAB1,2)
+ ISKIP=1
+ ITER=IUB1; JTER=IUB2
+ XZZX(1:IUB1)=XXX(NIINF:NISUP,NMGRID)
+ XZZY(1:IUB2)=XXY(NJINF:NJSUP,NMGRID)
+ CALL COMPUTEDIR(ITER,JTER,IUB1,IUB2,ISKIP,ZSTAB1,ZSTAB2)
+ print*,'traceh dd ',minval(ZSTAB2),maxval(ZSTAB2)
+ print*,'traceh dd ',minloc(ZSTAB2),maxloc(ZSTAB2)
+ CALL IMAGE_FORDIACHRO(ZSTAB2,KLREF,XDIAINT,NHI,NDOT,YTEXTE(1:LEN_TRIM(YTEXTE)))
+ ELSE
+ CALL IMAGEV_FORDIACHRO(ZSTAB1,ZSTAB2,KLREF,YTEXTE)
+ ENDIF
+ ENDIF
+! Avril 2000
+
+ ELSE
+
+ ZSTAB(:,:)=SQRT(ZSTAB1(:,:)**2+ZSTAB2(:,:)**2)
+ WHERE(ZSTAB1(:,:) == XSPVAL)ZSTAB=XSPVAL
+ WHERE(ZSTAB2(:,:) == XSPVAL)ZSTAB=XSPVAL
+ CALL IMAGE_FORDIACHRO(ZSTAB,KLREF,XDIAINT,NHI,NDOT,YTEXTE(1:LEN_TRIM(YTEXTE)))
+
+ ENDIF
+
+ IF(ALLOCATED(ZTEM))DEALLOCATE(ZTEM)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ELSE
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ CALL INTERP_FORDIACHRO(KLREF,NKL,NKH,P3D,ZSTAB)
+if(nverbia >0)then
+ print *,' ** Traceh AP INTERP3 KLREF ',KLREF
+endif
+!print *,' ZSTAB'
+!print *,ZSTAB
+!REGLER LE PB DE L'INTERVALLE
+
+ IF(NJMAXT == 1 .AND. NIMAXT /= 1)THEN !;;;;;;;;;;;;
+ IF(ALLOCATED(ZTEMX))THEN
+ DEALLOCATE(ZTEMX)
+ ENDIF
+ IF(ALLOCATED(ZTEMY))THEN
+ DEALLOCATE(ZTEMY)
+ ENDIF
+ ALLOCATE(ZTEMX(SIZE(ZSTAB,1)))
+ ALLOCATE(ZTEMY(SIZE(ZSTAB,1)))
+ ZTEMX(:)=XXX(NIINF:NISUP,NMGRID)
+! Ajout Nov 99
+ ZTEMX(:)=ZTEMX(:)-XXX(NIINF,NMGRID)
+! Ajout Nov 99
+ ZTEMY(:)=ZSTAB(:,1)
+ WHERE(ZTEMY == XSPVAL)
+! WHERE(ZTEMY == 999.)
+ ZTEMY=1.E36
+ END WHERE
+ YTITX(1:LEN(YTITX))=' '
+ YTITY(1:LEN(YTITX))=' '
+ YTITX='X(M)'
+ YTITY=CUNITGAL(1:LEN(CUNITGAL))
+ ZTIMED=XTRAJT(NLOOPT,1)
+ ZTIMEF=ZTIMED
+ CALL TRAXY(ZTEMX,ZTEMY,KLOOP,YTITX,YTITY,ZTIMED,ZTIMEF)
+ IF(KLOOP == 1)THEN
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ CALL RESOLV_TIMES(NLOOPT)
+ CALL PLCHHQ(.99,.007,YTEXTE(1:LEN_TRIM(YTEXTE)),.011,0.,+1.)
+ ENDIF
+
+ ELSE IF(NIMAXT == 1 .AND. NJMAXT /= 1)THEN !;;;;;;;;;;;;
+
+ IF(ALLOCATED(ZTEMX))THEN
+ DEALLOCATE(ZTEMX)
+ ENDIF
+ IF(ALLOCATED(ZTEMY))THEN
+ DEALLOCATE(ZTEMY)
+ ENDIF
+ ALLOCATE(ZTEMX(SIZE(ZSTAB,2)))
+ ALLOCATE(ZTEMY(SIZE(ZSTAB,2)))
+ ZTEMX(:)=XXY(NJINF:NJSUP,NMGRID)
+! Ajout Nov 99
+ ZTEMX(:)=ZTEMX(:)-XXY(NJINF,NMGRID)
+! Ajout Nov 99
+ ZTEMY(:)=ZSTAB(1,:)
+ WHERE(ZTEMY == XSPVAL)
+! WHERE(ZTEMY == 999.)
+ ZTEMY=1.E36
+ END WHERE
+ YTITX(1:LEN(YTITX))=' '
+ YTITY(1:LEN(YTITX))=' '
+ YTITX='Y(M)'
+ YTITY=CUNITGAL(1:LEN(CUNITGAL))
+ ZTIMED=XTRAJT(NLOOPT,1)
+ ZTIMEF=ZTIMED
+ CALL TRAXY(ZTEMX,ZTEMY,KLOOP,YTITX,YTITY,ZTIMED,ZTIMEF)
+ IF(KLOOP == 1)THEN
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ CALL RESOLV_TIMES(NLOOPT)
+ CALL PLCHHQ(.99,.007,YTEXTE(1:LEN_TRIM(YTEXTE)),.011,0.,+1.)
+ ENDIF
+
+ ELSE !;;;;;;;;;;;;
+
+! Ajout PH = intersection CV et CH 10/3/99 (Defini avec _cv__k_ (ou _z_ etc))
+ IF(LCV)THEN !......................................
+
+! Je remets le plan horizontal demande (ZSTAB) arbitrairement au niveau NKL
+! de P3D(ZWORK3D) et je fais toutes les operations concernant une coupe verticale
+! Je recupere le profil dans ZTEMCV(1:NLMAX,NKL)
+! J'ai les X ds XDS(1:NLMAX) Penser a mettre les latlon pts extremes
+ IF(NVERBIA >0)THEN
+ print *,' ** TRACEH SZ(1,2) de P3D et ZSTAB NKL ',&
+ SIZE(P3D,1),SIZE(P3D,2),SIZE(ZSTAB,1),SIZE(ZSTAB,2),NKL
+ ENDIF
+ ALLOCATE(ZSTABM(SIZE(ZSTAB,1),SIZE(ZSTAB,2)))
+! prise en compte du 2D hor. -> PH Oct 2000)
+ IF(SIZE(P3D,3) == 1)THEN
+ ZSTABM(:,:)=P3D(:,:,1)
+ P3D(:,:,1)=ZSTAB(:,:)
+ ELSE
+ ZSTABM(:,:)=P3D(:,:,MAX(2,NKL))
+ P3D(:,:,MAX(2,NKL))=ZSTAB(:,:)
+ ENDIF
+ CALL VERIFLEN_FORDIACHRO
+ CALL MEMCV
+ IF(ALLOCATED(ZTEMCV))THEN
+ DEALLOCATE(ZTEMCV)
+ ENDIF
+ IF(NVERBIA >0)THEN
+ print *,' ** TRACEH av PRECOU NLMAX IKU ',NLMAX,SIZE(P3D,3)
+ ENDIF
+ ALLOCATE(ZTEMCV(NLMAX,1:SIZE(P3D,3)))
+ CALL PRECOU_FORDIACHRO(P3D,ZTEMCV)
+! prise en compte du 2D hor. -> PH Oct 2000)
+ IF(SIZE(P3D,3) == 1)THEN
+ P3D(:,:,1)=ZSTABM(:,:)
+ ELSE
+ P3D(:,:,MAX(2,NKL))=ZSTABM(:,:)
+ ENDIF
+ DEALLOCATE(ZSTABM)
+ IF(NVERBIA >0)THEN
+ IF(SIZE(P3D,3) == 1)THEN
+ print *,' ** TRACEH ap PRECOU ZTEMCV(:,NKL)', ZTEMCV(:,1)
+ ELSE
+ print *,' ** TRACEH ap PRECOU ZTEMCV(:,NKL)', ZTEMCV(:,MAX(2,NKL))
+ ENDIF
+ ENDIF
+!!!!!!!!!!!!! Supprime le 30/11/01
+ CALL TRAHTRAXY(KLOOP,ZTEMCV,YTEXTE)
+!!!!!!!!!!!!! Supprime le 30/11/01
+
+ ELSE !......................................
+
+ CALL IMAGE_FORDIACHRO(ZSTAB,KLREF,XDIAINT,NHI,NDOT,YTEXTE(1:LEN_TRIM(YTEXTE)))
+ ENDIF !......................................
+
+ ENDIF !;;;;;;;;;;;;
+
+ ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ENDIF
+!
+
+! CALL FRAME
+!
+DEALLOCATE(ZSTAB)
+IF(ALLOCATED(ZSTAB1))THEN
+ DEALLOCATE(ZSTAB1)
+ENDIF
+IF(ALLOCATED(ZSTAB2))THEN
+ DEALLOCATE(ZSTAB2)
+ENDIF
+if(nverbia > 0)then
+ print *,' **sortie traceh LPR,LTK,LEV,LSV3 ', LPR,LTK,LEV,LSV3
+endif
+ RETURN
+!------------------------------------------------------------------------------
+!
+!* 5. EXIT
+! ----
+!
+1000 FORMAT(5X,I4,3X,A12)
+!
+!* 5.1 Heading formats
+!
+1001 FORMAT('Horiz. profile XDEB=',F6.0,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I4)
+1002 FORMAT('Horiz. profile XDEB=',F6.0,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1003 FORMAT('Horiz. profile XDEB=',E7.2,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I4)
+1004 FORMAT('Horiz. profile XDEB=',E6.2,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1010 FORMAT('Horiz. profile IDEB=',I4,' JDEB=',I4,' ANG.=',I3,' NBPTS=',I4)
+1011 FORMAT('Horiz. profile XDEB=',F6.0,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I4)
+1013 FORMAT('Horiz. profile XDEB=',F6.0,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1014 FORMAT('Horiz. profile XDEB=',E7.2,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I4)
+1015 FORMAT('Horiz. profile XDEB=',E6.2,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1018 FORMAT('Horiz. profile IND I,J (BEGIN)-(END)=(',I4,',',I4,')-(',I4,',',I4,')')
+1019 FORMAT('Horiz. profile LAT,LON (BEGIN)-(END)=(',F4.1,',',F5.1,')-(',F4.1,',',F5.1,')')
+1020 FORMAT('Horiz. profile CONF. COORD.(BEGIN)-(END)=(',F8.0,',',F8.0,')-(',F8.0,',',F8.0,')')
+!
+END SUBROUTINE TRACEH_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/tracev_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/tracev_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..29f70fa02c1fa16112fc317b4b18abfeda1e9557
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/tracev_fordiachro.f90
@@ -0,0 +1,262 @@
+! ######spl
+ MODULE MODI_TRACEV_FORDIACHRO
+! #############################
+!
+INTERFACE
+!
+SUBROUTINE TRACEV_FORDIACHRO(PTEMCV,KLOOP,HTEXT)
+INTEGER :: KLOOP
+CHARACTER(LEN=*) :: HTEXT
+REAL,DIMENSION(:,:) :: PTEMCV
+END SUBROUTINE TRACEV_FORDIACHRO
+!
+END INTERFACE
+END MODULE MODI_TRACEV_FORDIACHRO
+! ######spl
+ SUBROUTINE TRACEV_FORDIACHRO(PTEMCV,KLOOP,HTEXT)
+! ################################################
+!
+!!**** *TRACEV_FORDIACHRO* - Manager for the horizontal cross-section plots
+!!
+!! PURPOSE
+!! -------
+! In the case of horizontal cross-sections, call the interpolation and
+! display routines: - for contour plots
+! - for vector arrow plots
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!! VALNGRID : retrieves the NGRID grid number when given the variable name
+!! COMCOORD : computes true altitudes corresponding to the NGRID value
+!! IMCOU : contour plot manager for vertical cross-sections
+!! IMCOUV : vector plot manager for vertical cross-sections
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_TITLE : Declares heading variables for the plots (TRACE)
+!! NCONT : Current plot number
+!!
+!! Module MODD_NMGRID : declares global variable NMGRID (TRACE)
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!! Module MODN_NCAR : defines NAM_DIRTRA_POS namelist
+!! (former NCAR common)
+!! NHI : Extrema detection
+!! (=0 --> H+L, <0 nothing)
+!! NDOT : Line style
+!! (=0|1|1023|65535 --> solid lines;
+!! <0 --> solid lines for positive values and
+!! dotted lines(ABS(NDOT))for negative values;
+!! >0 --> dotted lines(ABS(NDOT)) )
+!! XPHINT : Increment contour value for PHIM, PHIT
+!!
+!! Module MODD_OUT : defines various logical units and dimensions
+!! NIMAXT : x-size of the displayed section of the MESO-NH arrays
+!! NJMAXT : y-size of the displayed section of the MESO-NH arrays
+!! NKMAXT : z-size of the displayed section of the MESO-NH arrays
+!!
+!! Module MODN_PARA
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NKMAX : z array dimensions
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!! JPVEXT : Vertical external points number
+!!
+!! Module MODD_SUPER : defines plot overlay control variables
+!! LSUPER : =.TRUE. --> plot overlay is active
+!! =.FALSE. --> plot overlay is not active
+!! NSUPER : Rank of the current plot in the overlay
+!! sequence. The initial plot is rank 1.
+!!
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_TITLE
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_NMGRID
+USE MODN_NCAR
+USE MODD_OUT
+USE MODD_DIM1
+USE MODN_PARA
+USE MODD_SUPER
+USE MODD_PT_FOR_CH_FORDIACHRO
+!USE MODI_IMCOU_FORDIACHRO
+
+IMPLICIT NONE
+!
+!* 0.1 Interfaces declaration
+!
+INTERFACE
+ SUBROUTINE IMCOU_FORDIACHRO(PTABV,PINT,HLEGEND,HTEXT)
+ CHARACTER(LEN=*) :: HTEXT, HLEGEND
+ REAL :: PINT
+ REAL,DIMENSION(:,:) :: PTABV
+ END SUBROUTINE IMCOU_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE IMCOUV_FORDIACHRO(PU,PW,HLEGEND,HTEXT)
+ REAL,DIMENSION(:,:) :: PU,PW
+ CHARACTER(LEN=*) :: HTEXT
+ CHARACTER(LEN=*) :: HLEGEND
+ END SUBROUTINE IMCOUV_FORDIACHRO
+END INTERFACE
+!
+!* 0.15 Dummy arguments
+!
+INTEGER :: KLOOP, JU
+CHARACTER(LEN=*) :: HTEXT
+REAL,DIMENSION(:,:) :: PTEMCV
+!
+!* 0.2 local variables
+!
+
+REAL,SAVE :: ZHMIN, ZHMAX
+INTEGER :: IBEGITXT, IENDTXT
+INTEGER :: ISTA, IER, INB, IWK, J, II
+
+CHARACTER(LEN=20) :: YNOM
+
+!
+!-------------------------------------------------------------------------------
+!* 1.3 Interactive option selection and plot overlay management
+!
+!
+!!!!!!!!!!! 110797
+IF(NLOOPSUPER == 1)THEN
+ZHMIN=XHMIN; ZHMAX=XHMAX
+if(nverbia > 0)then
+ print *,' TRACEV ENTREE XHMIN XHMAX ZHMIN ZHMAX ',XHMIN,XHMAX,ZHMIN,ZHMAX
+endif
+ELSE
+ IF(NBPMT > 0)THEN
+ DO J=NLOOPSUPER,1,-1
+ IF(NUMPM(J) /= 0 .AND. NUMPM(J) /= 1 .AND. NUMPM(J) /= 2)THEN
+ II=1
+ EXIT
+ ELSE
+! print *,' J NUMPM(J) ',J,NUMPM(J)
+ II=0
+ ENDIF
+ ENDDO
+ IF(II == 0)THEN
+ ZHMIN=XHMIN; ZHMAX=XHMAX
+ if(nverbia > 0)then
+ print *,' TRACEV ENTREE XHMIN XHMAX ZHMIN ZHMAX ',XHMIN,XHMAX,ZHMIN,ZHMAX
+ endif
+ ENDIF
+ ENDIF
+ENDIF
+!!!!!!!!!!! 110797
+
+YNOM=ADJUSTL(CGROUP)
+IF(YNOM.EQ.'QUIT')THEN
+ CALL GQOPS(ISTA)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(ISTA >1 .AND. INB >1)THEN
+ CALL GDAWK(2)
+ CALL GCLWK(2)
+ ENDIF
+! CALL FRAME
+ CALL NGPICT(1,1)
+ CALL CLSGKS
+ STOP
+END IF
+IBEGITXT=1
+IENDTXT=30
+
+IF(NSUPERDIA > 1)THEN
+ IF(LMINUS .OR. LPLUS)THEN
+ IF(NBPM > 1)THEN
+ DO JU=1,NBPM
+ IF(NUMPM(JU) == 3)THEN
+ LSUPER=.TRUE.
+ EXIT
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ ENDDO
+ ELSE
+ LSUPER=.FALSE.
+ ENDIF
+ ELSE
+ LSUPER=.TRUE.
+ ENDIF
+ELSE
+ LSUPER=.FALSE.
+ENDIF
+IF(KLOOP == 1)NSUPER=0
+XLWIDTH=XLWDEF
+!
+!* 2. PROCESSING OF ALL VARIABLES
+! ---------------------------
+!
+IF(LULMWM .OR. LULTWT)THEN
+
+ CALL IMCOUV_FORDIACHRO(PTEMCV,XWCV,CLEGEND,HTEXT)
+
+! Ajout Janvier 2001
+ELSE IF(LUMVM .OR. LUTVT .OR. LDIRWIND .OR. LSUMVM .OR. LSUTVT)THEN
+ if(nverbia > 0)then
+ print *,' LUMVM LDIRWIND LSUMVM AV CALL IMCOUV_FORDIACHRO ds TRACEV ',LUMVM,LDIRWIND,LSUMVM
+ endif
+ CALL IMCOUV_FORDIACHRO(PTEMCV,XWCV,CLEGEND,HTEXT)
+
+ELSE IF((LDIRWM .AND. .NOT.LDIRWIND) .OR. (LDIRWT .AND. .NOT.LDIRWIND))THEN
+ if(nverbia > 0)then
+ print *,' tracev LDIRWM LDIRWT LDIRWIND AV call imcou_fordiachro ',LDIRWM,LDIRWT,LDIRWIND
+ print *,' tracev SIZE(PTEMCV) AV call imcou_fordiachro ',SIZE(PTEMCV,1),SIZE(PTEMCV,2)
+ endif
+ CALL IMCOU_FORDIACHRO(PTEMCV,XDIAINT,CLEGEND,HTEXT)
+ELSE
+
+ CALL COMPCOORD_FORDIACHRO(NMGRID)
+!print *,' ZSTAB'
+!print *,ZSTAB
+!REGLER LE PB DE L'INTERVALLE
+ CALL IMCOU_FORDIACHRO(PTEMCV,XDIAINT,CLEGEND,HTEXT)
+!
+ENDIF
+IF(ALLOCATED(XWCV))THEN
+ DEALLOCATE(XWCV)
+ENDIF
+
+IF(.NOT.LSUPER .OR. (LSUPER .AND. NLOOPSUPER == NSUPERDIA))THEN
+ XHMIN=ZHMIN; XHMAX=ZHMAX
+if(nverbia > 0)then
+ print *,' TRACEV SORTIE XHMIN XHMAX ZHMIN ZHMAX ',XHMIN,XHMAX,ZHMIN,ZHMAX
+endif
+ENDIF
+!
+ RETURN
+!------------------------------------------------------------------------------
+!
+!* 5. EXIT
+! ----
+!
+!
+END SUBROUTINE TRACEV_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/tracexz.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/tracexz.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6b4185278520b32dd676fe3737a968160445bf14
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/tracexz.f90
@@ -0,0 +1,140 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/post/s.tracexz.f90, Version:1.2, Date:98/10/02, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ######spl
+ SUBROUTINE TRACEXZ
+! ##################
+!
+!!**** *TRACEXZ* - Overlays a gridpoint location stencil over a
+!! West-East vertical cross-section plot.
+!!
+!! PURPOSE
+!! -------
+!
+! When LXZ=.T., and in the special case of a vertical cross-section
+! located using the grid index format, shows a model level stencil
+! overlaid on the plot.
+!
+!!** METHOD
+!! ------
+!! Draws polylines between gridpoints corresponding to the NMGRID value.
+!!
+!! EXTERNAL
+!! --------
+!! GSLN : NCAR routine to set a line type.
+!! GPL : NCAR routine to draw a polyline.
+!! VALNGRID : loads current grid number in the NMGRID global variable
+!! COMPCOORD : computes true altitudes for NMGRID grid location
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_NMGRID : declares global variable NMGRID
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX : XHAT coordinate values for all the MESO-NH grids
+!!
+!! Module MODN_PARA : defines NAM_DOMAIN_POS namelist
+!! Module MODD_DIM1 : contains dimension of data array
+!! NIMAX,NKMAX : x, and z array dimensions
+!!
+!! Module MODD_GRID1 : declares grid variables (Model module)
+!! XZZ : true z altitude for the current NMGRID grid location
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 01/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_NMGRID
+USE MODD_COORD
+USE MODN_PARA !NOTICE: MODN_PARA includes MODD_DIM1
+USE MODD_GRID1
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+!* 0.1 Local variables
+!
+INTEGER :: JKLOOP,JILOOP
+INTEGER :: IIU, IKU, IMGRID
+!
+REAL,DIMENSION(200) :: ZX, ZY
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. MODEL LEVELS STENCIL DRAWING
+! ----------------------------
+!
+IIU=NIMAX+2*JPHEXT
+IKU=NKMAX+2*JPVEXT
+!
+CALL GSLN(3)
+!
+!* 1.1 Draws the "w" level stencil
+!
+!print *,' Tracexz NMGRID ',NMGRID
+IMGRID=NMGRID
+CALL COMPCOORD_FORDIACHRO(4) ! computes NMGRID grid true altitudes
+!print *,' Tracexz IMGRID ',IMGRID
+!CALL VALNGRID('WM')
+DO JKLOOP=1,IKU
+ DO JILOOP=1,IIU
+ ZX(JILOOP)=XXX(JILOOP,4)-XXX(NIDEBCOU,IMGRID)
+ ZY(JILOOP)=XZZ(JILOOP,NJDEBCOU,JKLOOP)
+ ENDDO
+ CALL GPL(IIU,ZX,ZY)
+ENDDO
+!
+!* 1.2 Draws the NMGRID model level stencil
+!
+NMGRID=IMGRID
+CALL COMPCOORD_FORDIACHRO(NMGRID) ! computes NMGRID grid true altitudes
+!print *,' Tracexz NMGRID ',NMGRID
+!
+IF(NMGRID.EQ.4)CALL GSLN(3)
+IF(NMGRID.EQ.2)CALL GSLN(2)
+IF(NMGRID.EQ.3)CALL GSLN(4)
+IF(NMGRID.EQ.1)CALL GSLN(5)
+!
+DO JKLOOP=1,IKU
+ DO JILOOP=1,IIU
+ ZX(JILOOP)=XXX(JILOOP,NMGRID)-XXX(NIDEBCOU,NMGRID)
+ ZY(JILOOP)=XZZ(JILOOP,NJDEBCOU,JKLOOP)
+ ENDDO
+ CALL GPL(IIU,ZX,ZY)
+ENDDO
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+CALL GSLN(1)
+!
+RETURN
+END SUBROUTINE TRACEXZ
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/tracircle.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/tracircle.f90
new file mode 100644
index 0000000000000000000000000000000000000000..82b32d3718d7751abb5d9c4db1fdd23fa4eddf4c
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/tracircle.f90
@@ -0,0 +1,210 @@
+! ######spl
+ SUBROUTINE TRACIRCLE(PU,PV,PP,PLW)
+! ###################################
+!
+!!**** *TRACIRCLE* -
+!!
+!! PURPOSE
+!! -------
+! Trace de cercles concentriques (pour materialiser par ex la
+! portee de radar(s))
+!
+!!** METHOD
+!! ------
+!! L utilisateur fournit :
+!! Le centre du cercle en latitude / longitude et
+!! son(ses) rayon(s) en metres
+!! Conversion en coordonnees normalisees et trace des segments successifs
+!! du(des) cercle(s)
+!!
+!! EXTERNAL
+!! --------
+!! SET : defines NCAR window and viewport in normalized and user
+!! coordinates
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_RADAR
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 23/04/03
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RADAR
+!
+IMPLICIT NONE
+!
+REAL :: ZWL, ZWR, ZWB, ZWT
+REAL :: ZVL, ZVR, ZVB, ZVT
+REAL :: PU, PV ! Coord. conformes centre du cercle
+REAL :: PP, PLW ! Rayon et epaisseur du trai du cercle
+REAL :: ZXCN, ZYCN ! coord normalisees du centre du cercle
+REAL :: ZRN ! Rayon en coord normalisees <-> PP
+REAL :: ZXA, ZYA, ZDTR, ZANG, ZSINA, ZCOSA, ZXB, ZYB, ZWIDTH, ZPPKM
+REAL :: ZX30, ZY30, ZX60,ZY60, ZX90,ZY90, ZX120,ZY120, ZX150,ZY150,&
+ZX180,ZY180, ZX210,ZY210, ZX240,ZY240, ZX270,ZY270,ZX300,ZY300, ZX330,ZY330,&
+ZX360,ZY360
+INTEGER :: ID, IER, J
+CHARACTER(LEN=4) :: YC
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. SAUVEGARDE FENETRE COURANTE
+! ---------------------------
+!
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+CALL GQLWSC(IER,ZWIDTH)
+!
+!* 2. CALCUL DE COORDONNEES NORMALISEES et DEF. NOUVELLE FENETRE
+! ----------------------------------------------------------
+! Calcul des coordonnees normalisees du centre du cercle et de la dim du rayon
+ZXCN=ZVL+((PU-ZWL)*(ZVR-ZVL)/(ZWR-ZWL))
+ZYCN=ZVB+((PV-ZWB)*(ZVT-ZVB)/(ZWT-ZWB))
+ZRN=PP*(ZVR-ZVL)/(ZWR-ZWL)
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZVL,ZVR,ZVB,ZVT,1)
+!
+!* 3. TRACE DU CERCLE
+! ---------------
+!
+CALL SFLUSH
+IF(PLW == 0. .OR. PLW == 9999.)PLW=2.
+CALL GSLWSC(PLW)
+ZXA=ZXCN
+ZYA=ZYCN+ZRN
+CALL FRSTPT(ZXA,ZYA)
+ZDTR=3.141592654/180.
+CALL GSCLIP(1)
+DO J=1,360
+ ZANG=J*ZDTR
+ ZSINA=SIN(ZANG)
+ ZCOSA=COS(ZANG)
+ IF(J == 90)ZSINA=1.
+ IF(J == 90)ZCOSA=0.
+ IF(J == 360)ZSINA=0.
+ IF(J == 360)ZCOSA=1.
+ ZXB=ZRN*ZSINA
+ ZYB=ZRN*ZCOSA
+ ZXB=ZXCN+ZXB
+ ZYB=ZYCN+ZYB
+ CALL VECTOR(ZXB,ZYB)
+ ZXA=ZXB
+ ZYA=ZYB
+ IF(LRADIST)THEN
+ ZPPKM=PP/1000.
+ WRITE(YC,'(I4)')NINT(ZPPKM)
+ YC=ADJUSTL(YC)
+ IF(J == 90 .OR. J == 270)THEN
+ CALL GSCLIP(0)
+ IF(J == 90 .AND. ZXA > ZVR)THEN
+ ELSE
+ CALL PLCHHQ(ZXA,ZYA,YC(1:LEN_TRIM(YC)),.008,0.,0.)
+ ENDIF
+ CALL GSCLIP(1)
+ ELSEIF(J == 180)THEN
+ CALL PLCHHQ(ZXA,ZYA-.005,YC(1:LEN_TRIM(YC)),.008,0.,0.)
+ ELSEIF(J == 360)THEN
+ CALL PLCHHQ(ZXA,ZYA+.005,YC(1:LEN_TRIM(YC)),.008,0.,0.)
+ ENDIF
+ ENDIF
+ IF(J == 30)THEN
+ ZX30=ZXA; ZY30=ZYA
+ ELSEIF(J == 60)THEN
+ ZX60=ZXA; ZY60=ZYA
+ ELSEIF(J == 90)THEN
+ ZX90=ZXA; ZY90=ZYA
+ ELSEIF(J == 120)THEN
+ ZX120=ZXA; ZY120=ZYA
+ ELSEIF(J == 150)THEN
+ ZX150=ZXA; ZY150=ZYA
+ ELSEIF(J == 180)THEN
+ ZX180=ZXA; ZY180=ZYA
+ ELSEIF(J == 210)THEN
+ ZX210=ZXA; ZY210=ZYA
+ ELSEIF(J == 240)THEN
+ ZX240=ZXA; ZY240=ZYA
+ ELSEIF(J == 270)THEN
+ ZX270=ZXA; ZY270=ZYA
+ ELSEIF(J == 300)THEN
+ ZX300=ZXA; ZY300=ZYA
+ ELSEIF(J == 330)THEN
+ ZX330=ZXA; ZY330=ZYA
+ ELSEIF(J == 360)THEN
+ ZX360=ZXA; ZY360=ZYA
+ ENDIF
+ENDDO
+CALL SFLUSH
+CALL GSCLIP(1)
+!
+!* 4. TRACE DES RAYONS
+! ----------------
+!
+IF(LRADRAY)THEN
+ CALL SFLUSH
+ CALL GSLN(2)
+ CALL GSLWSC(2.)
+ CALL FRSTPT(ZXCN,ZYCN)
+ CALL VECTOR(ZX30,ZY30)
+ CALL FRSTPT(ZXCN,ZYCN)
+ CALL VECTOR(ZX60,ZY60)
+ CALL FRSTPT(ZXCN,ZYCN)
+ CALL VECTOR(ZX90,ZY90)
+ CALL FRSTPT(ZXCN,ZYCN)
+ CALL VECTOR(ZX120,ZY120)
+ CALL FRSTPT(ZXCN,ZYCN)
+ CALL VECTOR(ZX150,ZY150)
+ CALL FRSTPT(ZXCN,ZYCN)
+ CALL VECTOR(ZX180,ZY180)
+ CALL FRSTPT(ZXCN,ZYCN)
+ CALL VECTOR(ZX210,ZY210)
+ CALL SFLUSH
+ CALL GSLN(2)
+ CALL FRSTPT(ZXCN,ZYCN)
+ CALL VECTOR(ZX240,ZY240)
+ CALL SFLUSH
+ CALL GSLN(2)
+ CALL FRSTPT(ZXCN,ZYCN)
+ CALL VECTOR(ZX270,ZY270)
+ CALL SFLUSH
+ CALL GSLN(2)
+ CALL FRSTPT(ZXCN,ZYCN)
+ CALL VECTOR(ZX300,ZY300)
+ CALL SFLUSH
+ CALL GSLN(2)
+ CALL FRSTPT(ZXCN,ZYCN)
+ CALL VECTOR(ZX330,ZY330)
+ CALL SFLUSH
+ CALL GSLN(2)
+ CALL FRSTPT(ZXCN,ZYCN)
+ CALL VECTOR(ZX360,ZY360)
+ CALL SFLUSH
+ENDIF
+!
+CALL GSCLIP(0)
+!
+!* 5. RESTORATION FENETRE COURANTE
+! ----------------------------
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+CALL GSLWSC(ZWIDTH)
+CALL GSLN(1)
+
+!
+!* 6. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE TRACIRCLE
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/traflux3d.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/traflux3d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..dc706aebf494303d3581167707ec9ca40b6e5916
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/traflux3d.f90
@@ -0,0 +1,896 @@
+!-----------------------------------------------------------------
+! ####################
+ SUBROUTINE TRAFLUX3D
+! ####################
+!
+!!**** *TRAFLUX3D* - (Demande Joel Stein,Nicole Asencio, Francois Gheusi)
+!! (Mai 00)
+!!
+!! PURPOSE
+!! -------
+! Materialisation du positionnement de lignes de flux
+! issues d'une position initiale connue ,
+! par transport de leurs coordonnees initiales dans les tableaux
+! scalaires SVx1, SVx2, SVx3
+!
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron et J. Stein * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 12/04/00
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_TRAJ3D
+USE MODD_TITLE
+USE MODD_TIT
+USE MODI_INTERPXYZ
+USE MODD_MASK3D
+USE MODD_RESOLVCAR
+USE MODD_CONF
+USE MODD_COORD
+USE MODD_GRID1
+USE MODD_NMGRID
+USE MODD_DIM1
+USE MODD_PARAMETERS
+USE MODD_SEVERAL_RECORDS
+USE MODD_FILES_DIACHRO
+USE MODD_ALLOC_FORDIACHRO
+USE MODI_REALLOC_AND_LOAD
+USE MODN_NCAR
+USE MODD_CTL_AXES_AND_STYL
+USE MODN_PARA
+USE MODI_TIT_TRA3D
+!
+IMPLICIT NONE
+!
+COMMON/COLAREA/ICOL(300)
+!
+!* 0.1 Local variables
+!
+INTEGER :: JM, ID, IGRID, JTLOOP, JI
+INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE
+INTEGER :: ICL, ICOL, ILOOP, IDEB, IFIN, INUM, IRESP
+!
+REAL,DIMENSION(:,:,:,:),ALLOCATABLE,SAVE :: ZSVM1, ZSVM2, ZSVM3, ZCHAMP
+REAL :: ZVL, ZVR, ZVB, ZVT, ZWL, ZWR, ZWB, ZWT
+REAL :: ZMINZ, ZMAXZ, ZINTZ, ZISO
+REAL,DIMENSION(300) :: ZLEV
+CHARACTER(LEN=16) :: YGROUP
+CHARACTER(LEN=75) :: YCAR
+CHARACTER(LEN=12) :: YCHAMP
+CHARACTER(LEN=100),SAVE :: YTEM2
+CHARACTER(LEN=110),SAVE :: YTEM1
+INTEGER :: JPART,ICOLOR,IFLUX
+REAL, ALLOCATABLE, DIMENSION(:,:) :: ZXPOS,ZYPOS,ZZPOS, ZCHAMP_POS ! positions aux
+! instants correspondants aux differents fichiers
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!
+!-------------------------------------------------------------------------------
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+! on lit les champs X0,Y0 et Z0 de la trajectoire pour le fichier
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+IGRID=NMGRID
+NMGRID=1
+IF (NBFILES /= 1) THEN
+ print*,' Vous voulez tracer des lignes de flux stationnaires:'
+ print*,'il ne faut utiliser qu un seul fichier pour l instant et non ',NBFILES
+ STOP
+ENDIF
+! partie selon X
+DO JM=1,1
+ YGROUP='LGXM'
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='LGXT'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM001'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT001'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM1'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT1'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ !
+ IF(LPBREAD)THEN
+ print *,' Absence de variable LGXM, SVM001, LGXT ou SVT001 .. Operation impossible'
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+ IF (LGROUP) THEN
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ ENDIF
+ !
+ IF (.NOT. ALLOCATED(ZSVM1)) THEN
+ ALLOCATE(ZSVM1(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),NBFILES))
+ ZSVM1=11111.
+ ENDIF
+ IF(MAXVAL(XXHAT)/MAXVAL(XVAR) > 1.E2)THEN
+ print *,' ** TRAFLUX3D MAXVAL(XXHAT),MAXVAL(XVAR),*1000(KM->M) ',MAXVAL(XXHAT),MAXVAL(XVAR)
+ WHERE(XVAR(:,:,:,JM,1,1) /= XSPVAL)
+ ZSVM1(:,:,:,JM)=XVAR(:,:,:,1,1,1)*1000.
+ ELSEWHERE
+ ZSVM1(:,:,:,JM)=XVAR(:,:,:,1,1,1)
+ ENDWHERE
+ ELSE
+ ZSVM1(:,:,:,JM)=XVAR(:,:,:,1,1,1)
+ ENDIF
+ !
+ ! Chargement clegend clegend2
+ CALL RESOLV_TIMES(1)
+ YTEM2=' '
+ YTEM1=' '
+ YTEM2=CLEGEND2
+ ! Elimination volontaire de 104 a 108 charge ds resolv_times pour RS
+ YTEM1=CLEGEND(1:103)
+ !
+ !IF(.NOT.LFIC1)THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ !CALL REALLOC_AND_LOAD(YGROUP)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE .',YGROUP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ !ENDIF
+ !
+END DO
+!
+! partie selon Y
+DO JM=1,1
+ YGROUP='LGYM'
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='LGYT'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM002'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT002'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM2'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT2'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ !
+ IF(LPBREAD)THEN
+ print *,' Absence de variable LGYM, SVM002, LGYT ou SVT002 .. Operation impossible'
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+ IF (LGROUP) THEN
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ ENDIF
+ !
+ IF (.NOT. ALLOCATED(ZSVM2)) THEN
+ ALLOCATE(ZSVM2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),NBFILES))
+ ZSVM2=11111.
+ ENDIF
+ IF(MAXVAL(XYHAT)/MAXVAL(XVAR) > 1.E2)THEN
+ print *,' ** TRAFLUX3D MAXVAL(XYHAT),MAXVAL(XVAR),*1000(KM->M) ',MAXVAL(XYHAT),MAXVAL(XVAR)
+ WHERE(XVAR(:,:,:,JM,1,1) /= XSPVAL)
+ ZSVM2(:,:,:,JM)=XVAR(:,:,:,1,1,1)*1000.
+ ELSEWHERE
+ ZSVM2(:,:,:,JM)=XVAR(:,:,:,1,1,1)
+ ENDWHERE
+ ELSE
+ ZSVM2(:,:,:,JM)=XVAR(:,:,:,1,1,1)
+ ENDIF
+ !
+ !IF(.NOT.LFIC1)THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ !CALL REALLOC_AND_LOAD(YGROUP)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE .',YGROUP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ !ENDIF
+ !
+END DO
+! partie selon Z
+DO JM=1,1
+ YGROUP='LGZM'
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='LGZT'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM003'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT003'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM3'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT3'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ !
+ IF(LPBREAD)THEN
+ print *,' Absence de variable LGZM, SVM003, LGZT ou SVT003 .. Operation impossible'
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+ IF (LGROUP) THEN
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ ENDIF
+ !
+ IF (.NOT. ALLOCATED(ZSVM3)) THEN
+ ALLOCATE(ZSVM3(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),NBFILES))
+ ZSVM3=11111.
+ ENDIF
+ IF(MAXVAL(XZHAT)/MAXVAL(XVAR) > 1.E2)THEN
+ print *,' ** TRAFLUX3D MAXVAL(XZHAT),MAXVAL(XVAR),*1000(KM->M) ',MAXVAL(XZHAT),MAXVAL(XVAR)
+ WHERE(XVAR(:,:,:,JM,1,1) /= XSPVAL)
+ ZSVM3(:,:,:,JM)=XVAR(:,:,:,1,1,1)*1000.
+ ELSEWHERE
+ ZSVM3(:,:,:,JM)=XVAR(:,:,:,1,1,1)
+ ENDWHERE
+ ELSE
+ ZSVM3(:,:,:,JM)=XVAR(:,:,:,1,1,1)
+ ENDIF
+ !
+ !IF(.NOT.LFIC1)THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ !CALL REALLOC_AND_LOAD(YGROUP)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE .',YGROUP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ !ENDIF
+ !
+END DO
+! allocation d'un champ supp pour l'appel a interpxyz
+! on lit un champ supplementaire pour le trace sur la trajectoire
+IF (LTRAJ_GROUP) THEN
+ DO JM=1,1
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),CTRAJ_GROUP)
+ IF(LPBREAD)THEN
+ print *,' Absence de variable CTRAJ_GROUP .. Operation impossible'
+ RETURN
+ ENDIF
+ !
+ IF (LGROUP) THEN
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),CTRAJ_GROUP)
+ ENDIF
+ !
+ IF (.NOT. ALLOCATED(ZCHAMP)) THEN
+ ALLOCATE(ZCHAMP(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),NBFILES))
+ ZCHAMP=11111.
+ ENDIF
+ !
+ ZCHAMP(:,:,:,JM)=XVAR(:,:,:,1,1,1)
+ !
+ !IF(.NOT.LFIC1)THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ !CALL REALLOC_AND_LOAD(YGROUP)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE .',CTRAJ_GROUP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ !ENDIF
+ !
+ END DO
+ELSE
+!!!! Octobre 2001
+ ALLOCATE(ZCHAMP(0,0,0,1))
+! ALLOCATE(ZCHAMP(0,0,0,0))
+END IF
+!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+! on recherche la valeur R0 d'origine pour le point courant R
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+IIB=1+JPHEXT; IIE=SIZE(ZSVM1,1)-JPHEXT
+IJB=1+JPHEXT; IJE=SIZE(ZSVM1,2)-JPHEXT
+IKB=1+JPVEXT; IKE=SIZE(ZSVM1,3)-JPVEXT
+!
+! Calcul des altitudes pour la grille 1 dans XZZ
+!
+CALL COMPCOORD_FORDIACHRO(1)
+!
+IFLUX=199
+ALLOCATE(ZXPOS(NPART,IFLUX+1))
+ALLOCATE(ZYPOS(NPART,IFLUX+1))
+ALLOCATE(ZZPOS(NPART,IFLUX+1))
+IF (LTRAJ_GROUP) THEN
+ ALLOCATE(ZCHAMP_POS(NPART,IFLUX+1))
+ELSE
+!!!! Octobre 2001
+ ALLOCATE(ZCHAMP_POS(NPART,IFLUX+1))
+! ALLOCATE(ZCHAMP_POS(1,1))
+!!!! Octobre 2001
+! ALLOCATE(ZCHAMP_POS(0,0))
+END IF
+!
+ZXPOS(:,1)=XXPART(1:NPART)
+ZYPOS(:,1)=XYPART(1:NPART)
+ZZPOS(:,1)=XZPART(1:NPART)
+!
+DO JPART=1,NPART
+ IF (ZXPOS(JPART,1).LT.XXX(IIB,1) .OR. ZXPOS(JPART,1).GT.XXX(IIE,1) .OR. &
+ ZYPOS(JPART,1).LT.XXY(IJB,1) .OR. ZXPOS(JPART,1).GT.XXY(IJE,1) &
+ ) THEN
+ ZXPOS(JPART,1)=MIN(XXX(IIE,1),MAX(XXX(IIB,1),ZXPOS(JPART,1)))
+ ZYPOS(JPART,1)=MIN(XXY(IJE,1),MAX(XXY(IJB,1),ZYPOS(JPART,1)))
+ print *,' la particule ',JPART,' est sortie du domaine'
+ print *,'nouvelles valeurs de XXPART et XYPART:'
+ print *,'XXPART=',ZXPOS(JPART,1),'XYPART=',ZYPOS(JPART,1)
+ END IF
+END DO
+!
+!
+DO JTLOOP=2,IFLUX+1
+ DO JPART=1,NPART
+ CALL INTERPXYZ(ZSVM1(:,:,:,1 ), &
+ ZSVM2(:,:,:,1 ), &
+ ZSVM3(:,:,:,1 ), &
+ ZCHAMP(:,:,:,1 ), &
+ ZXPOS(JPART,JTLOOP-1), &
+ ZYPOS(JPART,JTLOOP-1), &
+ ZZPOS(JPART,JTLOOP-1), &
+ XXX(2,1),XXY(2,1), &
+ XXDXHAT(3,1),XXDYHAT(3,1), &
+ XZZ,LTRAJ_GROUP, &
+ ZXPOS(JPART,JTLOOP ), &
+ ZYPOS(JPART,JTLOOP ), &
+ ZZPOS(JPART,JTLOOP ), &
+ ZCHAMP_POS(JPART,JTLOOP-1) )
+ !
+ IF (ZXPOS(JPART,JTLOOP).LT.XXX(IIB,1) .OR. ZXPOS(JPART,JTLOOP).GT.XXX(IIE,1) .OR. &
+ ZYPOS(JPART,JTLOOP).LT.XXY(IJB,1) .OR. ZYPOS(JPART,JTLOOP).GT.XXY(IJE,1) &
+ ) THEN
+ ZXPOS(JPART,JTLOOP)=ZXPOS(JPART,JTLOOP-1)
+ ZYPOS(JPART,JTLOOP)=ZYPOS(JPART,JTLOOP-1)
+ ZZPOS(JPART,JTLOOP)=ZZPOS(JPART,JTLOOP-1)
+ print *,'la particule ',JPART,' est sortie du domaine apres ',JTLOOP,' avances'
+ END IF
+ !
+ ENDDO
+ENDDO
+!
+DEALLOCATE(ZSVM1,ZSVM2,ZSVM3,ZCHAMP) ! dealloc des champs
+!
+! sortie des trajectoires
+IF(LPRINT)THEN
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ ILOOP=NPART/5
+ IF(ILOOP * 5 < NPART)ILOOP=ILOOP+1
+ENDIF
+DO JTLOOP=1,IFLUX+1
+ print*,'*****************'
+ print*,'JTLOOP= ', JTLOOP
+ print*,'*****************'
+ print*,'XPOS= ',ZXPOS(1:NPART,JTLOOP)
+ print*,'YPOS= ',ZYPOS(1:NPART,JTLOOP)
+ print*,'ZPOS= ',ZZPOS(1:NPART,JTLOOP)
+ IF (LTRAJ_GROUP) print*,'CHAMPPOS= ',ZCHAMP_POS(1:NPART,JTLOOP)
+ IF(LPRINT)THEN
+ WRITE(INUM,'(A,I3)') 'LOOP= ',JTLOOP
+ DO JI=1,ILOOP
+ IF (JI==1) THEN
+ IDEB=1 ; IFIN=4
+ ELSE
+ IDEB=IFIN+1 ; IFIN=IFIN+5
+ ENDIF
+ IF (JI==ILOOP) THEN
+ IFIN=NPART
+ ENDIF
+ IF (JI==1) THEN
+ WRITE(INUM,'(A12,4(3X,E12.6))')' XPOS=',ZXPOS(IDEB:IFIN,JTLOOP)
+ ELSE
+ WRITE(INUM,'(4(E12.6,3X),E12.6)') ZXPOS(IDEB:IFIN,JTLOOP)
+ ENDIF
+ END DO
+ DO JI=1,ILOOP
+ IF (JI==1) THEN
+ IDEB=1 ; IFIN=4
+ ELSE
+ IDEB=IFIN+1 ; IFIN=IFIN+5
+ ENDIF
+ IF (JI==1) THEN
+ WRITE(INUM,'(A12,4(3X,E12.6))')' YPOS=',ZYPOS(IDEB:IFIN,JTLOOP)
+ ELSE
+ WRITE(INUM,'(4(E12.6,3X),E12.6)') ZYPOS(IDEB:IFIN,JTLOOP)
+ ENDIF
+ END DO
+ DO JI=1,ILOOP
+ IF (JI==1) THEN
+ IDEB=1 ; IFIN=4
+ ELSE
+ IDEB=IFIN+1 ; IFIN=IFIN+5
+ ENDIF
+ IF (JI==1) THEN
+ WRITE(INUM,'(A12,4(3X,E12.6))')' ZPOS=',ZZPOS(IDEB:IFIN,JTLOOP)
+ ELSE
+ WRITE(INUM,'(4(E12.6,3X),E12.6)') ZZPOS(IDEB:IFIN,JTLOOP)
+ ENDIF
+ IF (JI==ILOOP) WRITE(INUM,*)
+ END DO
+ ENDIF
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+! Visualisation des trajectoires sur XY, XZ, YZ
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!
+! Recuperation de la fenetre d'affichage courante pour restauration en fin de
+! routine
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!
+! Determination de NIINF NJINF NISUP NJSUP si non initialises par l'utilisateur
+IF(NIINF == 0 .AND. NISUP == 0 .AND. NJINF == 0 .AND. NJSUP == 0)THEN
+ CALL RESOLV_NIJINF_NIJSUP
+ENDIF
+
+!
+!!!!!! XY
+!
+YCAR(1:LEN_TRIM(YCAR))=' '
+WRITE(YCAR,'(''FLUX **XY** '')')
+ ! car TIT_TRA3D ne trace rien sur la 1e image ...!
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ CALL PCSETC('FC','/')
+ CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+ CALL PCSETC('FC',':')
+!CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+IF(LCARTESIAN)THEN
+ CALL DEFENETRE
+ELSE
+ ! trace de la grille lat-lon
+ CALL GSLWSC(1.)
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+ CALL BCGRD_FORDIACHRO(2)
+ !CALL BCGRD_FORDIACHRO(1)
+ENDIF
+!
+! couleur en fct de l alt ZZPOS (15 intervalles)
+ICL=15
+CALL COLOR_FORDIACHRO(ICL+2,1)
+CALL TABCOL_FORDIACHRO
+ZMAXZ=MAXVAL(ZZPOS) ; ZMINZ=MINVAL(ZZPOS)
+ZINTZ=NINT(ZMAXZ-ZMINZ)/15
+IF(ZMINZ + ICL*ZINTZ <= ZMAXZ)ICL=ICL+1
+CALL CPSETI('NCL',ICL)
+CALL CPSETI('CLS',0)
+ZISO=ZMINZ-ZINTZ
+DO JI=1,ICL
+ CALL CPSETI('PAI',JI)
+ CALL CPSETI('AIA',JI+1)
+ CALL CPSETI('AIB',JI)
+ ZISO=ZISO+ZINTZ
+ IF(ABS(ZISO)<1.E-20)ZISO=0.
+ CALL CPSETR('CLV',ZISO)
+ CALL CPSETR('CLU',1.)
+ ZLEV(JI)=ZISO
+ ICOL(JI)=JI
+END DO
+!
+IF (.NOT.LCOLINE) THEN
+ print *,' LCOLINE=F: Retro-trajectoires et marqueurs noirs dans le plan XY'
+ENDIF
+
+CALL GSLWSC(3.)
+DO JPART=1,NPART
+ CALL GSMK(4)
+ IF (.NOT.LCOLINE) THEN
+ ICOLOR=1
+ CALL GSPMCI(1)
+ ELSE
+ ICOLOR= 1+ MOD((JPART-1),16) ! boucle sur les 16 premieres couleurs
+ ! couleur du marker en fct de l alt ZZPOS
+ IF(ZZPOS(JPART,1) <ZLEV(1))THEN
+ CALL GSPMCI(1)
+ ELSEIF(ZZPOS(JPART,1) >=ZLEV(ICL))THEN
+ CALL GSPMCI(ICL+1)
+ ELSE
+ DO JI=1,ICL-1
+ IF(ZZPOS(JPART,1) >= ZLEV(JI) .AND. &
+ ZZPOS(JPART,1) < ZLEV(JI+1))THEN
+ CALL GSPMCI(JI+1)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+ CALL GSTXCI(ICOLOR)
+ CALL GSPLCI(ICOLOR)
+ CALL GPM(1,ZXPOS(JPART,1),ZYPOS(JPART,1))
+ CALL FRSTD(ZXPOS(JPART,1),ZYPOS(JPART,1))
+ CALL GSMK(3)
+ DO JTLOOP=2,IFLUX+1
+ IF (LCOLINE) THEN ! couleur du marker en fct de l alt ZZPOS
+ IF(ZZPOS(JPART,JTLOOP) <ZLEV(1))THEN
+ CALL GSPMCI(1)
+ ELSEIF(ZZPOS(JPART,JTLOOP) >=ZLEV(ICL))THEN
+ CALL GSPMCI(ICL+1)
+ ELSE
+ DO JI=1,ICL-1
+ IF(ZZPOS(JPART,JTLOOP) >= ZLEV(JI) .AND. &
+ ZZPOS(JPART,JTLOOP) < ZLEV(JI+1))THEN
+ CALL GSPMCI(JI+1)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+ CALL VECTD(ZXPOS(JPART,JTLOOP),ZYPOS(JPART,JTLOOP))
+ CALL GPM(1,ZXPOS(JPART,JTLOOP),ZYPOS(JPART,JTLOOP))
+ ENDDO
+ CALL LASTD
+ENDDO
+!
+CALL FRAME
+!
+!
+IF( LTRAJ_GROUP) THEN
+ CALL GSLWSC(1.)
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ YCAR(1:LEN_TRIM(YCAR))=' '
+ WRITE(YCAR,'(''FLUX **XY** '',A16)') CTRAJ_GROUP
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ !CALL PCSETC('FC','/')
+ !CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+ !CALL PCSETC('FC',':')
+ CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+ IF(LCARTESIAN)THEN
+ CALL DEFENETRE
+ ELSE
+ CALL BCGRD_FORDIACHRO(1)
+ ENDIF
+
+ CALL GSLWSC(3.)
+ DO JPART=1,NPART
+ CALL GSMK(4)
+ ICOLOR= 1+ MOD((JPART-1),16) ! boucle sur les 16 premieres couleurs
+ CALL GSTXCI(ICOLOR)
+ CALL GSPLCI(ICOLOR)
+ CALL GSPMCI(ICOLOR)
+ CALL GPM(1,ZXPOS(JPART,1),ZYPOS(JPART,1))
+ WRITE(YCHAMP,'(F12.4)') ZCHAMP_POS(JPART,1)
+ CALL PLCHHQ(ZXPOS(JPART,1),ZYPOS(JPART,1),YCHAMP,10.,0.,-1.)
+ CALL FRSTD(ZXPOS(JPART,1),ZYPOS(JPART,1))
+ CALL GSMK(3)
+ DO JTLOOP=2,IFLUX+1
+ CALL VECTD(ZXPOS(JPART,JTLOOP),ZYPOS(JPART,JTLOOP))
+ CALL GPM(1,ZXPOS(JPART,JTLOOP),ZYPOS(JPART,JTLOOP))
+ IF (JTLOOP<IFLUX+1) THEN
+ ! le dernier point pour CHAMP se rapporte a l'echeance precedente
+ ! donc il ne peut pas etre calcule et trace
+ WRITE(YCHAMP,'(F12.4)') ZCHAMP_POS(JPART,JTLOOP)
+ CALL PLCHHQ(ZXPOS(JPART,JTLOOP),ZYPOS(JPART,JTLOOP),YCHAMP,10.,0.,-1.)
+ ENDIF
+ ENDDO
+ CALL LASTD
+ ENDDO
+ !
+ ! trace de la grille lat-lon
+ CALL GSLWSC(1.)
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+ CALL BCGRD_FORDIACHRO(2)
+ CALL FRAME
+ENDIF
+!
+!!!!!! XZ
+!
+CALL GSLWSC(1.)
+CALL GSTXCI(1)
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+WRITE(YCAR,'(''FLUX **XZ** '')')
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+!CALL PCSETC('FC','/')
+!CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+!CALL PCSETC('FC',':')
+CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+CALL SET(.1,.9,.1,.9,XXX(NIINF,1),XXX(NISUP,1), &
+XHMIN,XHMAX,1)
+CALL LABMOD('(F8.0)','(F6.0)',9,6,10,10,0,0,0)
+!Avril 2002
+IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,0,0,5,0.,0.)
+ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,0,1,5,0.,0.)
+ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,0,5,0.,0.)
+ELSE
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,1,5,0.,0.)
+ENDIF
+!Avril 2002
+!
+CALL GSLWSC(3.)
+DO JPART=1,NPART
+ CALL GSMK(4)
+ ICOLOR= 1+ MOD((JPART-1),16) ! boucle sur les 16 premieres couleurs
+ CALL GSPLCI(ICOLOR)
+ CALL GSTXCI(ICOLOR)
+ CALL GSPMCI(ICOLOR)
+ CALL GPM(1,ZXPOS(JPART,1),ZZPOS(JPART,1))
+ CALL FRSTD(ZXPOS(JPART,1),ZZPOS(JPART,1))
+ CALL GSMK(3)
+ DO JTLOOP=2,IFLUX+1
+ CALL VECTD(ZXPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ CALL GPM(1,ZXPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ ENDDO
+ CALL LASTD
+ENDDO
+!
+CALL FRAME
+!
+!
+IF (LTRAJ_GROUP) THEN
+ CALL GSLWSC(1.)
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ WRITE(YCAR,'(''FLUX **XZ** '',A16)') CTRAJ_GROUP
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ !CALL PCSETC('FC','/')
+ !CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+ !CALL PCSETC('FC',':')
+ CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+ CALL SET(.1,.9,.1,.9,XXX(NIINF,1),XXX(NISUP,1), &
+ XHMIN,XHMAX,1)
+ CALL LABMOD('(F8.0)','(F6.0)',9,6,10,10,0,0,0)
+!Avril 2002
+IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,0,0,5,0.,0.)
+ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,0,1,5,0.,0.)
+ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,0,5,0.,0.)
+ELSE
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,1,5,0.,0.)
+ENDIF
+!Avril 2002
+ !
+ CALL GSLWSC(3.)
+ DO JPART=1,NPART
+ CALL GSMK(4)
+ ICOLOR= 1+ MOD((JPART-1),16) ! boucle sur les 16 premieres couleurs
+ CALL GSPLCI(ICOLOR)
+ CALL GSTXCI(ICOLOR)
+ CALL GSPMCI(ICOLOR)
+ CALL GPM(1,ZXPOS(JPART,1),ZZPOS(JPART,1))
+ WRITE(YCHAMP,'(F12.4)') ZCHAMP_POS(JPART,1)
+ CALL PLCHHQ(ZXPOS(JPART,1),ZZPOS(JPART,1),YCHAMP,10.,0.,-1.)
+ CALL FRSTD(ZXPOS(JPART,1),ZZPOS(JPART,1))
+ CALL GSMK(3)
+ DO JTLOOP=2,IFLUX+1
+ CALL VECTD(ZXPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ CALL GPM(1,ZXPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ IF (JTLOOP<IFLUX+1) THEN
+ WRITE(YCHAMP,'(F12.4)') ZCHAMP_POS(JPART,JTLOOP)
+ CALL PLCHHQ(ZXPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP),YCHAMP,10.,0.,-1.)
+ ENDIF
+ ENDDO
+ CALL LASTD
+ ENDDO
+ !
+ CALL FRAME
+END IF
+!
+!!!!!! YZ
+!
+CALL GSLWSC(1.)
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+WRITE(YCAR,'(''FLUX **YZ** '')')
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+!CALL PCSETC('FC','/')
+!CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+!CALL PCSETC('FC',':')
+CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+CALL SET(.1,.9,.1,.9,XXY(NJINF,1),XXY(NJSUP,1), &
+XHMIN,XHMAX,1)
+CALL LABMOD('(F8.0)','(F6.0)',9,6,10,10,0,0,0)
+!Avril 2002
+IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,0,0,5,0.,0.)
+ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,0,1,5,0.,0.)
+ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,0,5,0.,0.)
+ELSE
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,1,5,0.,0.)
+ENDIF
+!Avril 2002
+!
+CALL GSLWSC(3.)
+DO JPART=1,NPART
+ CALL GSMK(4)
+ ICOLOR= 1+ MOD((JPART-1),16) ! boucle sur les 16 premieres couleurs
+ CALL GSPLCI(ICOLOR)
+ CALL GSTXCI(ICOLOR)
+ CALL GSPMCI(ICOLOR)
+ CALL GPM(1,ZYPOS(JPART,1),ZZPOS(JPART,1))
+ CALL FRSTD(ZYPOS(JPART,1),ZZPOS(JPART,1))
+ CALL GSMK(3)
+ DO JTLOOP=2,IFLUX+1
+ CALL VECTD(ZYPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ CALL GPM(1,ZYPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ ENDDO
+ CALL LASTD
+ENDDO
+!
+CALL FRAME
+!
+IF (LTRAJ_GROUP) THEN
+ CALL GSLWSC(1.)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ WRITE(YCAR,'(''FLUX **YZ** '',A16)') CTRAJ_GROUP
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ !CALL PCSETC('FC','/')
+ !CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+ !CALL PCSETC('FC',':')
+ CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+ CALL SET(.1,.9,.1,.9,XXY(NJINF,1),XXY(NJSUP,1), &
+ XHMIN,XHMAX,1)
+ CALL LABMOD('(F8.0)','(F6.0)',9,6,10,10,0,0,0)
+!Avril 2002
+IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,0,0,5,0.,0.)
+ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,0,1,5,0.,0.)
+ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,0,5,0.,0.)
+ELSE
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,1,5,0.,0.)
+ENDIF
+!Avril 2002
+ !
+ CALL GSLWSC(3.)
+ DO JPART=1,NPART
+ CALL GSMK(4)
+ ICOLOR= 1+ MOD((JPART-1),16) ! boucle sur les 16 premieres couleurs
+ CALL GSPLCI(ICOLOR)
+ CALL GSTXCI(ICOLOR)
+ CALL GSPMCI(ICOLOR)
+ CALL GPM(1,ZYPOS(JPART,1),ZZPOS(JPART,1))
+ WRITE(YCHAMP,'(F12.4)') ZCHAMP_POS(JPART,1)
+ CALL PLCHHQ(ZYPOS(JPART,1),ZZPOS(JPART,1),YCHAMP,10.,0.,-1.)
+ CALL FRSTD(ZYPOS(JPART,1),ZZPOS(JPART,1))
+ CALL GSMK(3)
+ DO JTLOOP=2,IFLUX+1
+ CALL VECTD(ZYPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ CALL GPM(1,ZYPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ IF (JTLOOP<IFLUX+1) THEN
+ WRITE(YCHAMP,'(F12.4)') ZCHAMP_POS(JPART,JTLOOP)
+ CALL PLCHHQ(ZYPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP),YCHAMP,10.,0.,-1.)
+ ENDIF
+ ENDDO
+ CALL LASTD
+ ENDDO
+ !
+ CALL FRAME
+END IF
+!
+!
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!
+!
+CALL GSTXCI(1)
+CALL GSPLCI(1)
+CALL GSLWSC(1.)
+CALL GSLN(1)
+DEALLOCATE(ZXPOS,ZYPOS,ZZPOS,ZCHAMP_POS) ! dealloc des champs
+NMGRID=IGRID
+
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+!
+RETURN
+!
+END SUBROUTINE TRAFLUX3D
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/trahtraxy.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/trahtraxy.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6d4e313b3b1ba3d13c9e3083a8537935ac657a30
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/trahtraxy.f90
@@ -0,0 +1,259 @@
+! #################
+ SUBROUTINE TRAHTRAXY(KLOOP,PTEMCV,HTEXTE)
+! #################
+!
+!!**** *TRAHTRAXY* -
+!!
+!!
+!! PURPOSE
+!! -------
+! Trace PH (tableaux 1D scalaires y compris MUMVM et DIRUMVM)
+! dans traceh_fordiachro
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/11/01
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+
+USE MODD_NMGRID
+USE MODD_COORD
+USE MODD_DEFCV
+USE MODD_TIT
+USE MODD_TYPE_AND_LH
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+USE MODN_PARA
+USE MODN_NCAR
+USE MODI_RESOLV_TIT
+USE MODI_RESOLV_TITY
+
+IMPLICIT NONE
+!
+INTERFACE
+ SUBROUTINE TRAXY(PTEMX,PTEMY,KLOOP,HTITX,HTITY,PTIMED,PTIMEF)
+ INTEGER :: KLOOP
+ REAL,DIMENSION(:) :: PTEMX, PTEMY
+ REAL :: PTIMED, PTIMEF
+ CHARACTER(LEN=*) :: HTITX, HTITY
+ END SUBROUTINE TRAXY
+END INTERFACE
+!
+!
+!* 0.1 Dummy arguments
+!
+INTEGER :: KLOOP
+REAL,DIMENSION(:,:) :: PTEMCV
+CHARACTER(LEN=40) :: HTEXTE
+!
+!* 0.1 Local variables
+!
+!
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZTEMCV
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZTEMX, ZTEMY
+REAL :: ZTIMED, ZTIMEF
+REAL :: ZXPOSTITT1, ZXYPOSTITT1
+REAL :: ZXPOSTITT2, ZXYPOSTITT2
+REAL :: ZXPOSTITT3, ZXYPOSTITT3
+REAL :: ZXPOSTITT4, ZXYPOSTITT4
+REAL :: ZXPOSTITB1, ZXYPOSTITB1
+REAL :: ZXPOSTITB2, ZXYPOSTITB2
+REAL :: ZXPOSTITB3, ZXYPOSTITB3
+REAL :: ZXPOSTITB4, ZXYPOSTITB4
+!
+CHARACTER(LEN=16) :: YTITX,YTITY
+CHARACTER(LEN=40) :: YTEXTE,YTEM
+CHARACTER(LEN=80) :: YCARCOU
+!
+!-------------------------------------------------------------------------------
+!
+!* 1.
+! ----------------------------
+!
+YTEXTE=HTEXTE
+!!!!!!!!!!!!! Supprime le 30/11/01
+! Appel a TRAXY pour le trace du PH
+ IF(ALLOCATED(ZTEMX))THEN
+ DEALLOCATE(ZTEMX)
+ ENDIF
+ IF(ALLOCATED(ZTEMY))THEN
+ DEALLOCATE(ZTEMY)
+ ENDIF
+ IF(ALLOCATED(ZTEMCV))THEN
+ DEALLOCATE(ZTEMCV)
+ ENDIF
+ ALLOCATE(ZTEMCV(SIZE(PTEMCV,1),SIZE(PTEMCV,2)))
+ ZTEMCV(:,:)=PTEMCV(:,:)
+ ALLOCATE(ZTEMX(SIZE(ZTEMCV,1)))
+ ALLOCATE(ZTEMY(SIZE(ZTEMCV,1)))
+ IF(SIZE(ZTEMCV,2) == 1)THEN
+ ZTEMY(:)=ZTEMCV(:,1)
+ ELSE
+ ZTEMY(:)=ZTEMCV(:,MAX(2,NKL))
+ ENDIF
+ ZTEMX(:)=XDS(1:NLMAX,NMGRID)
+ WHERE(ZTEMY == XSPVAL)
+ ZTEMY=1.E36
+ END WHERE
+ YTITX(1:LEN(YTITX))=' '
+ YTITY(1:LEN(YTITX))=' '
+ YTITX='X(M)'
+ YTITY=CUNITGAL(1:LEN(CUNITGAL))
+ ZTIMED=XTRAJT(NLOOPT,1)
+ ZTIMEF=ZTIMED
+ IF(NVERBIA > 0)THEN
+ print *,' TRACEH AV TRAXY KLOOP,YTITX,YTITY,ZTIMED,ZTIMEF',&
+ KLOOP,YTITX,YTITY,ZTIMED,ZTIMEF
+ ENDIF
+ CALL TRAXY(ZTEMX,ZTEMY,KLOOP,YTITX,YTITY,ZTIMED,ZTIMEF)
+
+ IF(KLOOP == 1)THEN
+
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ CALL RESOLV_TIMES(NLOOPT)
+ YTEM(1:LEN(YTEM))=' '
+! CTITVAR1
+ CALL RESOLV_TIT('CTITVAR1',YTEM)
+ IF(CTITVAR1 == 'DEFAULT')THEN
+ CALL PLCHHQ(.99,.007,YTEXTE(1:LEN_TRIM(YTEXTE)),.011,0.,+1.)
+ ELSE IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(.99,.007,YTEM(1:LEN_TRIM(YTEM)),.011,0.,+1.)
+ ENDIF
+! CTITT1
+ YCARCOU(1:LEN(YCARCOU))=' '
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT1',YTEM)
+ ZXPOSTITT1=.002
+ ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+
+ IF(XIDEBCOU.NE.-999.)THEN
+ IF(LDEFCV2CC)THEN !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(LDEFCV2IND)THEN
+ WRITE(YCARCOU,1018)NIDEBCV,NJDEBCV,NIFINCV,NJFINCV
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(YCARCOU,1019)XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL
+ ELSE
+ WRITE(YCARCOU,1020)XIDEBCV,XJDEBCV,XIFINCV,XJFINCV
+ ENDIF
+ ELSE !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(XIDEBCOU < 99999.)THEN
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1011)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ ELSE
+ WRITE(YCARCOU,1013)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ END IF
+ ELSE
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1014)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ ELSE
+ WRITE(YCARCOU,1015)XIDEBCOU,XJDEBCOU,NLANGLE,NLMAX
+ END IF
+ END IF
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ ELSE
+ WRITE(YCARCOU,1010)NIDEBCOU,NJDEBCOU,NLANGLE,NLMAX
+ ENDIF
+ IF(CTITT1 == 'DEFAULT')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU(1:LEN_TRIM(YCARCOU)),XSZTITT1,0.,-1.)
+! CALL PLCHHQ(.002,.98,YCARCOU(1:LEN_TRIM(YCARCOU)),XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YCARCOU(1:LEN_TRIM(YCARCOU)),.012,0.,-1.)
+! CALL PLCHHQ(.002,.98,YCARCOU(1:LEN_TRIM(YCARCOU)),.012,0.,-1.)
+ ENDIF
+ ELSE IF(YTEM /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM(1:LEN_TRIM(YTEM)),XSZTITT1,0.,-1.)
+! CALL PLCHHQ(.002,.98,YTEM(1:LEN_TRIM(YTEM)),XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM(1:LEN_TRIM(YTEM)),.012,0.,-1.)
+! CALL PLCHHQ(.002,.98,YTEM(1:LEN_TRIM(YTEM)),.012,0.,-1.)
+ ENDIF
+ ENDIF
+! CTITT2
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.95
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM(1:LEN_TRIM(YTEM)),XSZTITT2,0.,-1.)
+! CALL PLCHHQ(.002,.95,YTEM(1:LEN_TRIM(YTEM)),XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM(1:LEN_TRIM(YTEM)),.008,0.,-1.)
+! CALL PLCHHQ(.002,.95,YTEM(1:LEN_TRIM(YTEM)),.008,0.,-1.)
+ ENDIF
+ ENDIF
+! CTITT3
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT3',YTEM)
+ ZXPOSTITT3=.002
+ ZXYPOSTITT3=.93
+ IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ ENDIF
+ IF(XYPOSTITT3 /= 0.)THEN
+ ZXYPOSTITT3=XYPOSTITT3
+ ENDIF
+ IF(YTEM /= ' ')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM(1:LEN_TRIM(YTEM)),XSZTITT3,0.,-1.)
+! CALL PLCHHQ(.002,.93,YTEM(1:LEN_TRIM(YTEM)),XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM(1:LEN_TRIM(YTEM)),.008,0.,-1.)
+! CALL PLCHHQ(.002,.93,YTEM(1:LEN_TRIM(YTEM)),.008,0.,-1.)
+ ENDIF
+ ENDIF
+
+ ENDIF
+!!!!!!!!!!!!! Supprime le 30/11/01
+1010 FORMAT('Horiz. profile IDEB=',I3,' JDEB=',I3,' ANG.=',I3,' NBPTS=',I3)
+1011 FORMAT('Horiz. profile XDEB=',F6.0,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I3)
+1013 FORMAT('Horiz. profile XDEB=',F6.0,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I3)
+1014 FORMAT('Horiz. profile XDEB=',E7.2,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I3)
+1015 FORMAT('Horiz. profile XDEB=',E6.2,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I3)
+1018 FORMAT('Horiz. profile IND I,J (BEGIN)-(END)=(',I3,',',I3,')-(',I3,',',I3,')')
+1019 FORMAT('Horiz. profile LAT,LON (BEGIN)-(END)=(',F4.1,',',F5.1,')-(',F4.1,',',F5.1,')')
+1020 FORMAT('Horiz. profile CONF. COORD.(BEGIN)-(END)=(',F8.0,',',F8.0,')-(',F8.0,',',F8.0,')')
+!
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END SUBROUTINE TRAHTRAXY
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/tramask.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/tramask.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7c97e6775fd69f6d52212f0544e63d0f2374bdd6
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/tramask.f90
@@ -0,0 +1,374 @@
+! ######spl
+ MODULE MODI_TRAMASK
+! ###################
+!
+INTERFACE
+!
+SUBROUTINE TRAMASK(PTEM,KLOOP)
+INTEGER :: KLOOP
+REAL,DIMENSION(:,:,:) :: PTEM
+END SUBROUTINE TRAMASK
+!
+END INTERFACE
+END MODULE MODI_TRAMASK
+! ######spl
+ SUBROUTINE TRAMASK(PTEM,KLOOP)
+! ##############################
+!
+!!**** *TRAMASK* -
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!! CLSGKS : closes NCAR and GKS graphics
+!! COMPCOORD : computes gridpoint locations, meshsizes and topography
+!! for all the possible grids, and true altitude where
+!! required.
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_NMGRID : declares global variable NMGRID
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!!
+!! Module MODN_PARA: Defines NAM_DOMAIN_POS namelist (former PARA common)
+!! NLMAX : Number of points horizontally along
+!! the vertical section
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NKMAX : z array dimension
+!!
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXZ : Gal-Chen z coordinate values for all the MESO-NH grids
+!!
+!! Module MODD_GRID1 : declares grid variables (Model module)
+!! XZZ : true gridpoint z altitude
+!!
+!! Module MODD_SUPER : defines plot overlay control variables
+!! LSUPER : =.TRUE. --> plot overlay is active
+!! =.FALSE. --> plot overlay is not active
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_NMGRID
+USE MODN_PARA
+USE MODN_NCAR
+USE MODD_COORD
+USE MODD_GRID1
+USE MODD_SUPER
+USE MODD_RESOLVCAR
+USE MODD_TIT
+USE MODD_TITLE
+USE MODD_CTL_AXES_AND_STYL
+!
+IMPLICIT NONE
+!
+!* 0.1 interface declarations
+!
+INTERFACE
+ SUBROUTINE VALMNMX(PMIN,PMAX)
+ REAL :: PMIN, PMAX
+ END SUBROUTINE VALMNMX
+END INTERFACE
+!
+!* 0.1 Dummy arguments
+!
+INTEGER :: KLOOP
+REAL,DIMENSION(:,:,:) :: PTEM
+!
+!* 0.2 local variables
+!
+!
+INTEGER :: ID
+INTEGER :: ILENT
+INTEGER :: ISTA, IER, INB, IWK
+!
+REAL,SAVE :: ZMIN, ZMAX
+REAL,SAVE :: ZVL, ZVR, ZVB, ZVT, ZWL, ZWR, ZWB,ZWT
+!
+CHARACTER(LEN=20) :: YNOM
+CHARACTER(LEN=40):: YTEXTE
+CHARACTER(LEN=60):: YTEM
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. PRELIMINARY CALCULATIONS
+! ------------------------
+!
+YTEXTE(1:LEN(YTEXTE)) = ' '
+ILENT=LEN_TRIM(CTITGAL)
+YTEXTE=ADJUSTL(CTITGAL)
+YTEXTE=ADJUSTL(YTEXTE)
+!
+!
+!* 1.4
+!
+!
+YNOM=ADJUSTL(CGROUP)
+IF(YNOM.EQ.'QUIT')THEN
+!
+!* 1.5 End of job: EXIT
+!
+ CALL GQOPS(ISTA)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(ISTA >1 .AND. INB >1)THEN
+ CALL GDAWK(2)
+ CALL GCLWK(2)
+ ENDIF
+! CALL FRAME
+ CALL NGPICT(1,1)
+ CALL CLSGKS
+ STOP
+ENDIF
+!
+!* 1.6 Ooverlay control
+!
+IF(NSUPERDIA > 1)THEN
+ LSUPER=.TRUE.
+ELSE
+ LSUPER=.FALSE.
+ENDIF
+IF(KLOOP == 1)NSUPER=0
+!print *,' KLOOP NSUPER ',KLOOP,NSUPER
+!
+!
+!* 1.8 Line width and color changes to differentiate the
+!* successive plots in an overlay sequence
+!
+CALL GSCLIP(1)
+IF(LSUPER)THEN
+
+ NSUPER=NSUPER+1
+ IF(NSUPER == 1)CALL TABCOL_FORDIACHRO
+ IF(LCOLINE)THEN
+ CALL GSLN(1)
+ CALL GSPLCI(NSUPER+1)
+ CALL GSTXCI(NSUPER+1)
+ ELSE
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ SELECT CASE(NSUPER)
+ CASE(:4)
+ CALL GSLWSC(1.)
+ CASE(5:8)
+ CALL GSLWSC(2.)
+ CASE(9:12)
+ CALL GSLWSC(3.)
+ CASE(13:16)
+ CALL GSLWSC(4.)
+ CASE DEFAULT
+ CALL GSLWSC(1.)
+ END SELECT
+ CALL GSLN(MOD(NSUPER,4))
+ IF(MOD(NSUPER,4) == 0)CALL GSLN(4)
+ ENDIF
+
+ELSE
+
+ CALL GSLN(1) ! Solid line if no overlay
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+
+END IF
+!
+IF(NSUPER <= 1)THEN
+ CALL AGSETF('SET.',4.)
+ CALL AGSETF('BAC.',4.)
+ CALL AGSETF('FRA.',2.)
+!print *,' AGSETF '
+ ZMIN=MINVAL(PTEM)
+ ZMAX=MAXVAL(PTEM)
+ CALL VALMNMX(ZMIN,ZMAX)
+ IF(ABS(ZMAX-ZMIN) <1.E-4)THEN
+ ZMAX=ZMAX+1.
+ ZMIN=ZMIN-1.
+ ENDIF
+! ZMIN=-.5; ZMAX=1.5
+ ZWB=ZMIN; ZWT=ZMAX
+ENDIF
+!print *,' SIZE(PTEM) ',SIZE(PTEM,1),SIZE(PTEM,2),SIZE(PTEM,3)
+IF(SIZE(PTEM,1) == 1)THEN
+ ZWL=XXY(NJINF,NMGRID); ZWR=XXY(NJSUP,NMGRID)
+ CALL SET(.1,.9,.1,.9,ZWL,ZWR,ZWB,ZWT,1)
+ CALL EZXY(XXY(NJINF:NJSUP,NMGRID),PTEM(1,:,1),NJSUP-NJINF+1,0)
+ELSE IF(SIZE(PTEM,2) == 1)THEN
+ ZWL=XXX(NIINF,NMGRID); ZWR=XXX(NISUP,NMGRID)
+! print *,' ZWL ZWR ',ZWL,ZWR
+ CALL SET(.1,.9,.1,.9,ZWL,ZWR,ZWB,ZWT,1)
+ CALL EZXY(XXX(NIINF:NISUP,NMGRID),PTEM(:,1,1),NISUP-NIINF+1,0)
+ENDIF
+
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+XCURVPTL=ZVL;XCURVPTR=ZVR;XCURVPTB=ZVB;XCURVPTT=ZVT
+!print *,' ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT ',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+CALL GSCLIP(0)
+IF(LSUPER)THEN
+ IF(NSUPER < 4)THEN
+ CALL FRSTPT(ZVR-(ZVR-ZVL)/4.+MAX(.18,ILENT*.009),.007+(NSUPER-1)*.017)
+ CALL VECTOR(ZVR-(ZVR-ZVL)/4.+MAX(.18,ILENT*.009)+.03,.007+(NSUPER-1)*.017)
+ ELSE
+ CALL PLCHHQ(ZVL+(NSUPER-4)*.25,ZVT+.01,ADJUSTL(CTIMEC(8:15)),.007,0.,-1.)
+ CALL FRSTPT(ZVL+(NSUPER-4)*.25+.08,ZVT+.01)
+ CALL VECTOR(ZVL+(NSUPER-4)*.25+.08+.03,ZVT+.01)
+ ENDIF
+ENDIF
+
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+CALL GSLN(1)
+CALL GSLWSC(1.)
+IF(NSUPER <= 1)THEN
+! ******************************************************************
+ CALL FORMATXY(ZWL,ZWR,ZWB,ZWT)
+ CALL GRIDAL(NMASKITVXMJ,NMASKITVXMN,NMASKITVYMJ,NMASKITVYMN,1,1,5,0,0)
+! CALL GRIDAL(5,1,5,1,1,1,5,0,0)
+ENDIF
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZVL,ZVR,ZVB,ZVT,1)
+IF(.NOT.LSUPER)THEN
+ ILENT=ILENT+2
+ YTEXTE(ILENT:ILENT+15-8+1)=CTIMEC(8:15)
+ CALL PLCHHQ(MAX(ZVR,.99),.007,YTEXTE(1:ILENT+15-8+1),.011,0.,+1.)
+ELSE
+ IF(NSUPER < 4)THEN
+ CALL PLCHHQ(ZVR-(ZVR-ZVL)/4.-.04,.007+(NSUPER-1)*.017,YTEXTE(1:ILENT), &
+ .009,0.,-1.)
+ CALL PLCHHQ(ZVR-(ZVR-ZVL)/4.-.12,.007+(NSUPER-1)*.017,CTIMEC(8:15), &
+ .007,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVL+(NSUPER-4)*.25,ZVT+.03,YTEXTE(1:ILENT), &
+ .009,0.,-1.)
+ ENDIF
+ENDIF
+
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+IF(LFACTIMP)THEN
+ CALL FACTIMP
+ENDIF
+! Titres en X
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/3.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/3.,YTEM,.008,0.,-1.)
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/3.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+! YTEM='(Sec.)'
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/3.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/3.,YTEM,.008,0.,-1.)
+ ENDIF
+! Titres en Y
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYT',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYM',ZVL,ZVR,ZVB,ZVT,YTEM)
+ IF(LCNSUM)THEN
+ YTEM='SUM(.TRUE.=1)'
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYB',ZVL,ZVR,ZVB,ZVT,YTEM)
+! Titres TOP
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT3',YTEM)
+ IF(CTITT3 /= ' ')THEN
+ CALL PLCHHQ(0.002,0.93,YTEM,.008,0.,-1.)
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ IF(CTITT2 /= ' ')THEN
+ CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT1',YTEM)
+ IF(CTITT1 /= ' ')THEN
+ CALL PLCHHQ(0.002,0.98,YTEM,.012,0.,-1.)
+ ENDIF
+! Titres BOTTOM
+! YTEM(1:LEN(YTEM))=' '
+! CALL RESOLV_TIT('CTITB3',YTEM)
+! IF(CTITB3 /= ' ')THEN
+! CALL PLCHHQ(0.002,0.05,YTEM,.008,0.,-1.)
+! ENDIF
+! YTEM(1:LEN(YTEM))=' '
+! CALL RESOLV_TIT('CTITB2',YTEM)
+! IF(CTITB2 /= ' ')THEN
+! CALL PLCHHQ(0.002,0.025,YTEM,.007,0.,-1.)
+! ENDIF
+! YTEM(1:LEN(YTEM))=' '
+! CALL RESOLV_TIT('CTITB1',YTEM)
+! IF(CTITB1 /= ' ')THEN
+! CALL PLCHHQ(0.002,0.005,YTEM,.007,0.,-1.)
+! ENDIF
+! Titre N1 BOTTOM
+ CALL RESOLV_TIT('CTITB1',CLEGEND)
+ CALL PLCHHQ(0.002,0.005,CLEGEND,.007,0.,-1.)
+ IF(LCNCUM .OR. LCNSUM)THEN
+! Titre N3 BOTTOM
+ CALL RESOLV_TIT('CTITB3',CTIMECS)
+ CALL PLCHHQ(0.002,0.050,CTIMECS,.009,0.,-1.)
+ ELSE
+ IF(LMINUS .OR. LPLUS)THEN
+ IF(.NOT.LTITDEFM .AND. CTITB3MEM /= 'DEFAULT' .AND. &
+ CTITB3MEM /= 'default' .AND. CTITB3MEM /= 'DEFAUT' .AND. &
+ CTITB3MEM /= 'defaut')THEN
+ IF(CTITB3MEM /= ' ' .AND. CTITB3MEM /= 'WHITE' .AND. &
+ CTITB3MEM /= 'white' .AND. CTITB3MEM /= 'BLANC' .AND. &
+ CTITB3MEM /= 'blanc')THEN
+ CALL PLCHHQ(0.002,0.050,CTITB3MEM(1:LEN_TRIM(CTITB3MEM)),.009,0.,-1.)
+ ENDIF
+ ELSE
+! ******************** 200697 ***************
+ CALL RESOLV_TIT('CTITB3',CTITB3)
+ IF(CTITB3 /= ' ')THEN
+ CALL PLCHHQ(0.002,0.050,CTITB3,.009,0.,-1.)
+ ENDIF
+ ENDIF
+! ******************** 200697 ***************
+ ELSE
+ YTEM(1:LEN(YTEM))=' '
+ YTEM=CTIMEC
+ YTEM=ADJUSTL(YTEM)
+ CALL RESOLV_TIT('CTITB3',YTEM)
+! CALL RESOLV_TIT('CTITB3',CTIMEC)
+ IF(YTEM /= ' ')THEN
+ CALL PLCHHQ(0.002,0.050,YTEM(1:LEN_TRIM(YTEM)),.009,0.,-1.)
+! CALL PLCHHQ(0.002,0.050,CTIMEC,.009,0.,-1.)
+ ENDIF
+ ENDIF
+ ENDIF
+! Titre N2 BOTTOM
+ CALL RESOLV_TIT('CTITB2',CLEGEND2)
+ IF(CLEGEND2 /= ' ')THEN
+ CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
+ ENDIF
+IF(LDATFILE)CALL DATFILE_FORDIACHRO
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+!
+!
+!----------------------------------------------------------------------------
+!
+!* 4. EXIT
+! ----
+!
+END SUBROUTINE TRAMASK
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/tramask3d.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/tramask3d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..69472e5bf88ebce5b503fe389525032184fc46fd
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/tramask3d.f90
@@ -0,0 +1,741 @@
+!-----------------------------------------------------------------
+! ####################
+ SUBROUTINE TRAMASK3D
+! ####################
+!
+!!**** *TRAMASK3D* - (Demande Joel Stein,Nicole Asencio, Francois Gheusi)
+!! (Mai 99)
+!!
+!! PURPOSE
+!! -------
+! Materialisation du positionnement de particules a un instant donne
+! issues d'une position initiale connue ,
+! par transport de leurs coordonnees initiales dans les tableaux
+! scalaires SVx1, SVx2, SVx3
+! L'utilisateur definit une fenetre spatiale dans les limites
+! XXL= XXH= XYL= XYH= XZL= XZH= (en metres) correspondant a une
+! position initiale et recherche dans les =/= enr. de ces tableaux
+! (<-> a des termes d'evolution temporelle) les points correspondant
+! a cette fenetre -> occurences vraies d'un masque.
+!
+! Si LMASK3D=T , visualisation de la projection de ces occurences
+! sur XY, XZ, YZ.
+!
+! Conjointement :
+! thetae_msktop_ (Valeurs <-> surface des occurences.T. du masque)
+! (a partir du sommet)
+! thetae_xyz__z_7000 (Extraction des valeurs de thetae corresp. aux
+! occurences .T. du masque en affectant aux autres points la valeur
+! XSPVAL puis trace comme habituellement d'une coupe horizontale, ici
+! d'altitude donnee)
+! thetae_sv3_5000,4000 (Trace d'une coupe horizontale d'altitudes
+! donnees SVx3. Le masque n'intervient pas dans ce cas)
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 29/04/99
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_MASK3D
+USE MODD_RESOLVCAR
+USE MODD_CONF
+USE MODD_COORD
+USE MODD_GRID1
+USE MODD_NMGRID
+USE MODD_DIM1
+USE MODD_PARAMETERS
+USE MODD_SEVERAL_RECORDS
+USE MODD_FILES_DIACHRO
+USE MODD_ALLOC_FORDIACHRO
+USE MODI_REALLOC_AND_LOAD
+USE MODN_NCAR
+!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!
+USE MODD_CTL_AXES_AND_STYL
+USE MODN_PARA
+USE MODD_TRAJ3D
+!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!JOEL!!!!!!!!!!!!!!
+USE MODD_TITLE
+USE MODI_TIT_TRA3D
+ USE MODD_ALLOC_FORDIACHRO
+
+!
+IMPLICIT NONE
+!
+!* 0.1 Local variables
+!
+INTEGER :: JKLOOP,JILOOP , JJLOOP, J, JM, ID, IGRID, JTLOOP
+INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE
+INTEGER :: IDBID
+INTEGER :: INUM,IRESP,ILOOP
+!
+REAL,DIMENSION(:,:,:,:),ALLOCATABLE,SAVE :: ZSVM1, ZSVM2, ZSVM3
+REAL :: ZVL, ZVR, ZVB, ZVT, ZWL, ZWR, ZWB, ZWT, ZX, ZY
+REAL :: ZWLBID, ZWRBID, ZWBBID, ZWTBID
+CHARACTER(LEN=16) :: YGROUP
+CHARACTER(LEN=75) :: YCAR
+CHARACTER(LEN=10) :: YFORMAX, YFORMAY
+CHARACTER(LEN=2) :: YNUMBER ! number of the start for the lag. var
+INTEGER :: ILENTRIMSV3 ! length of the CGROUPSV3 var.
+REAL,DIMENSION(:,:,:,:),ALLOCATABLE,SAVE :: ZFIELD_LAG
+LOGICAL :: GLAG
+CHARACTER(LEN=16) :: YSTO_CGROUPSV3 ! storage of CGROUPSV3
+CHARACTER(LEN=100),SAVE :: YTEM2
+CHARACTER(LEN=110),SAVE :: YTEM1
+!
+!-------------------------------------------------------------------------------
+IGRID=NMGRID
+NMGRID=1
+CALL TABCOL_FORDIACHRO
+DO J=1,NBFILES
+ IF(NUMFILES(J) == NUMFILECUR)THEN
+ JM=J
+ ENDIF
+ENDDO
+!
+IF(LXYZ00)THEN
+ YSTO_CGROUPSV3=CGROUPSV3
+ ILENTRIMSV3=LEN(TRIM(CGROUPSV3))
+ YNUMBER=CGROUPSV3(ILENTRIMSV3-1:ILENTRIMSV3)
+ ! on verifie que CGROUPSV3 contient une variable lagrangienne
+ ! pertinente sinon on remet Z000 pour cette routine puis on remet
+ ! CROUPSV3 a ce qu il etait avant de rentrer dans cette routine
+ IF (ICHAR(YNUMBER(1:1))<48 .OR. ICHAR(YNUMBER(1:1))>57 .OR. &
+ ICHAR(YNUMBER(2:2))<48 .OR. ICHAR(YNUMBER(2:2))>57 ) THEN
+ CGROUPSV3='Z000'
+ PRINT*,'**TRAMASK3D: CGROUPSV3 force a Z000'
+ PRINT*,'son ancienne valeur ',YSTO_CGROUPSV3, &
+ ' sera remise a la sortie de tramask3d'
+ ILENTRIMSV3=LEN(TRIM(CGROUPSV3))
+ YNUMBER=CGROUPSV3(ILENTRIMSV3-1:ILENTRIMSV3)
+ ENDIF
+ENDIF
+!
+!
+! Lecture des X0 -> chargement dans ZSVM1
+!
+IF(LXYZ00)THEN
+ YGROUP='X0'//YNUMBER
+ELSE
+ YGROUP='LGXM'
+ENDIF
+CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+IF(LPBREAD)THEN
+ IF(LXYZ00)THEN
+ print *,' Absence de variable X00 .. Operation impossible'
+ RETURN
+ ELSE
+ YGROUP='LGXT'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM001'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT001'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM1'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT1'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ !
+ IF(LPBREAD)THEN
+ print *,' Absence de variable LGXM, SVM001, LGXT ou SVT001 .. Operation impossible'
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ENDIF
+IF(LGROUP)THEN
+ IF(LMASK3D)THEN
+ print *,' **TRAMASK3D utilisation de ',YGROUP
+ ENDIF
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ENDIF
+! Chargement clegend clegend2
+CALL RESOLV_TIMES(1)
+YTEM2=' '
+YTEM2=CLEGEND2
+YTEM1=' '
+! Elimination volontaire de 104 a 108 charge ds resolv_times pour RS
+YTEM1=CLEGEND(1:103)
+!
+IF(.NOT.LFIC1)THEN
+ CALL REALLOC_AND_LOAD(YGROUP)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE .',YGROUP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ENDIF
+ALLOCATE(ZSVM1(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4)))
+!IF(YGROUP == 'SVM1')THEN
+IF(MAXVAL(XXHAT)/MAXVAL(XVAR) > 1.E2)THEN
+ print *,' ** Tramask3D MAXVAL(XXHAT),MAXVAL(XVAR),*1000(KM->M) ',MAXVAL(XXHAT),MAXVAL(XVAR)
+ WHERE(XVAR(:,:,:,:,1,1) /= XSPVAL)
+ ZSVM1(:,:,:,:)=XVAR(:,:,:,:,1,1)*1000.
+ ELSEWHERE
+ ZSVM1(:,:,:,:)=XVAR(:,:,:,:,1,1)
+ ENDWHERE
+ELSE
+ ZSVM1(:,:,:,:)=XVAR(:,:,:,:,1,1)
+ENDIF
+CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+!
+! Lecture des Y0 -> chargement dans ZSVM2
+!
+IF(LXYZ00)THEN
+ YGROUP='Y0'//YNUMBER
+ELSE
+ YGROUP='LGYM'
+ENDIF
+CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+IF(LPBREAD)THEN
+ IF(LXYZ00)THEN
+ print *,' Absence de variable Y00 .. Operation impossible'
+ RETURN
+ ELSE
+ YGROUP='LGYT'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM002'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT002'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM2'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT2'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ !
+ IF(LPBREAD)THEN
+ print *,' Absence de variable LGYM ou SVM002 ou LGYT ou SVT002 .. Operation impossible'
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ENDIF
+IF(LGROUP)THEN
+ IF(LMASK3D)THEN
+ print *,' **TRAMASK3D utilisation de ',YGROUP
+ ENDIF
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ENDIF
+IF(.NOT.LFIC1)THEN
+ CALL REALLOC_AND_LOAD(YGROUP)
+ print *,' REQUETE IMPOSSIBLE .',YGROUP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ENDIF
+ALLOCATE(ZSVM2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4)))
+!IF(YGROUP == 'SVM2')THEN
+IF(MAXVAL(XYHAT)/MAXVAL(XVAR) > 1.E2)THEN
+ print *,' ** Tramask3D MAXVAL(XYHAT),MAXVAL(XVAR),*1000(KM->M) ',MAXVAL(XYHAT),MAXVAL(XVAR)
+ WHERE(XVAR(:,:,:,:,1,1) /= XSPVAL)
+ ZSVM2(:,:,:,:)=XVAR(:,:,:,:,1,1)*1000.
+ ELSEWHERE
+ ZSVM2(:,:,:,:)=XVAR(:,:,:,:,1,1)
+ ENDWHERE
+ELSE
+ ZSVM2(:,:,:,:)=XVAR(:,:,:,:,1,1)
+ENDIF
+CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+!
+! Lecture des Z0 -> chargement dans ZSVM3
+!
+IF(LXYZ00)THEN
+ YGROUP='Z0'//YNUMBER
+ELSE
+ YGROUP='LGZM'
+ENDIF
+CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+IF(LPBREAD)THEN
+ IF(LXYZ00)THEN
+ print *,' Absence de variable Z00 .. Operation impossible'
+ RETURN
+ ELSE
+ YGROUP='LGZT'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM003'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT003'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM3'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT3'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ !
+ IF(LPBREAD)THEN
+ print *,' Absence de variable LGZM ou SVM003 ou LGZT ou SVT003 .. Operation impossible'
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ENDIF
+IF(LGROUP)THEN
+ IF(LMASK3D)THEN
+ print *,' **TRAMASK3D utilisation de ',YGROUP
+ ENDIF
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ENDIF
+IF(.NOT.LFIC1)THEN
+ CALL REALLOC_AND_LOAD(YGROUP)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE .',YGROUP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ENDIF
+ALLOCATE(ZSVM3(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4)))
+!IF(YGROUP == 'SVM3')THEN
+IF(MAXVAL(XZHAT)/MAXVAL(XVAR) > 1.E2)THEN
+ print *,' ** Tramask3D MAXVAL(XZHAT),MAXVAL(XVAR),*1000(KM->M) ',MAXVAL(XZHAT),MAXVAL(XVAR)
+ WHERE(XVAR(:,:,:,:,1,1) /= XSPVAL)
+ ZSVM3(:,:,:,:)=XVAR(:,:,:,:,1,1)*1000.
+ ELSEWHERE
+ ZSVM3(:,:,:,:)=XVAR(:,:,:,:,1,1)
+ ENDWHERE
+ELSE
+ ZSVM3(:,:,:,:)=XVAR(:,:,:,:,1,1)
+ENDIF
+CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+!
+! Lecture du champ lagrangien suppl -> chargement dans ZFIELD_LAG
+!
+GLAG=LXYZ00 .AND. &
+ (CGROUPSV3(1:2).NE.'SV' .AND. CGROUPSV3(1:2).NE.'LG' &
+ .AND. CGROUPSV3(1:2).NE.'Z0' &
+ )
+!
+IF( GLAG )THEN
+ YGROUP=CGROUPSV3
+ CALL VERIF_GROUP(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ IF(LPBREAD)THEN
+ print *,' Absence de variable ',CGROUPSV3,' .. Operation impossible'
+ RETURN
+ ENDIF
+ IF(LGROUP)THEN
+ IF(LMASK3D)THEN
+ print *,' **TRAMASK3D utilisation suppl. de ',YGROUP
+ ENDIF
+ CALL READ_DIACHRO(CFILEDIAS(JM),CLUOUTDIAS(JM),YGROUP)
+ ENDIF
+ IF(.NOT.LFIC1)THEN
+ CALL REALLOC_AND_LOAD(YGROUP)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE .',YGROUP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ ALLOCATE(ZFIELD_LAG(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4)))
+ ZFIELD_LAG(:,:,:,:)=XVAR(:,:,:,:,1,1)
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ENDIF
+!
+! Determination du masque en fonction de la fenetre XXL,XXH,XYL,XYH,XZL,XZH
+!
+IF(ALLOCATED(LMASK3))THEN
+ DEALLOCATE(LMASK3)
+ENDIF
+ALLOCATE(LMASK3(SIZE(ZSVM1,1),SIZE(ZSVM1,2),SIZE(ZSVM1,3),SIZE(ZSVM1,4)))
+LMASK3=.FALSE.
+!
+IF (GLAG) THEN
+ LMASK3=(XXL < ZSVM1 .AND. XXH >ZSVM1) .AND. (XYL < ZSVM2 .AND. XYH > ZSVM2) &
+ .AND. (XZL < ZFIELD_LAG .AND. XZH > ZFIELD_LAG)
+ELSE
+ LMASK3=(XXL < ZSVM1 .AND. XXH >ZSVM1) .AND. (XYL < ZSVM2 .AND. XYH > ZSVM2) &
+ .AND. (XZL < ZSVM3 .AND. XZH > ZSVM3)
+ENDIF
+!
+! Calcul des altitudes pour la grille 1 dans XZZ
+!
+CALL COMPCOORD_FORDIACHRO(1)
+!
+!-------------------------------------------------------------------------------
+!
+! Visualisation du masque sur XY, XZ, YZ
+!
+IF(LMASK3D .OR. LMASK3D_XY .OR. LMASK3D_XZ .OR. LMASK3D_YZ)THEN
+!IF(LMASK3D)THEN
+!
+ IF(LPRINT)THEN
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ ENDIF
+
+! Recuperation de la fenetre d'affichage courante pour restauration en fin de
+! routine
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!
+! Determination de NIINF NJINF NISUP NJSUP si non initialises par l'utilisateur
+IF(NIINF == 0 .AND. NISUP == 0 .AND. NJINF == 0 .AND. NJSUP == 0)THEN
+ CALL RESOLV_NIJINF_NIJSUP
+ENDIF
+
+IIB=1+JPHEXT; IIE=SIZE(ZSVM1,1)-JPHEXT
+IJB=1+JPHEXT; IJE=SIZE(ZSVM1,2)-JPHEXT
+IKB=1+JPVEXT; IKE=SIZE(ZSVM1,3)-JPVEXT
+
+DO JTLOOP=1,SIZE(ZSVM1,4)
+if(nverbia >0)then
+print *,' ** TRAMASK3D JTLOOP ',JTLOOP
+endif
+!
+!!!!!! XY
+!
+IF(LMASK3D_XY)THEN
+
+IF(NJMAX /= 1)THEN
+ IF(LPRINT)THEN
+ ILOOP=SIZE(ZSVM1,1)/5
+ IF(ILOOP * 5 < SIZE(ZSVM1,1)) ILOOP=ILOOP+1
+ WRITE(INUM,'(''CH '',''G:'',A16,'' P:'',A25,'' T:'',F8.0,''s'')') &
+ CGROUPSV3,CTITRE(1)(1:25),XTRAJT(JTLOOP,1)
+ WRITE(INUM,'(A40,''(NIINF-NISUP,NJINF-NJSUP)'')')CTITGAL
+ WRITE(INUM,'(''niinf'',i4,'' njinf'',i4,'' nisup'',i4,'' njsup'',i4,&
+ &'' '',A1,'' '',i6)')&
+ &NIINF,NJINF,NISUP,NJSUP,CTYPHOR,IKE
+ WRITE(INUM,'(''NBVAL en I '',i4,'' NBVAL en J '',i4,'' iter'',i3)') &
+ &NISUP-NIINF+1,NJSUP-NJINF+1,ILOOP
+ ENDIF
+
+YCAR(1:LEN_TRIM(YCAR))=' '
+WRITE(YCAR,'(''MASK **XY- ** window:('',F8.0,'':'',F8.0,'','',F8.0,'':'',F8.0,'','',F6.0,'':'',F6.0,'')'')') &
+ XXL,XXH,XYL,XYH,XZL,XZH
+YCAR(11:12)=YGROUP(3:4)
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+!CALL PCSETC('FC','/')
+!CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+!CALL PCSETC('FC',':')
+CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+IF(LCARTESIAN)THEN
+ CALL DEFENETRE
+ELSE
+ ! trace de la grille lat-lon
+ CALL GSLWSC(1.)
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+ CALL BCGRD_FORDIACHRO(2)
+ !CALL BCGRD_FORDIACHRO(1)
+ENDIF
+! trace du masque (etoiles colorees)
+CALL GSMK(3)
+DO JKLOOP=IKE,IKB,-1
+DO JILOOP=IIB,IIE
+ DO JJLOOP=IJB,IJE
+ IF(LMASK3(JILOOP,JJLOOP,JKLOOP,JTLOOP))THEN
+ ZX=XXX(JILOOP,1)
+ ZY=XXY(JJLOOP,1)
+ CALL GPM(1,ZX,ZY)
+ ENDIF
+ ENDDO
+ENDDO
+ENDDO
+! trace de la boite de lacher
+CALL GSPLCI(4)
+CALL GSLWSC(3.)
+CALL FRSTPT(XXL,XYL)
+CALL VECTOR(XXH,XYL)
+CALL VECTOR(XXH,XYH)
+CALL VECTOR(XXL,XYH)
+CALL VECTOR(XXL,XYL)
+CALL FRAME
+ENDIF
+
+ENDIF
+CALL GSLWSC(1.)
+CALL GSPLCI(1)
+!
+!!!!!! XZ
+!
+IF(LMASK3D_XZ)THEN
+WRITE(YCAR,'(''MASK **XZ- ** window:('',F8.0,'':'',F8.0,'','',F8.0,'':'',F8.0,'','',F6.0,'':'',F6.0,'')'')') &
+ XXL,XXH,XYL,XYH,XZL,XZH
+!
+IF(GLAG) THEN
+ YCAR(11:12)=YNUMBER
+ELSE
+ YCAR(11:12)=YGROUP(3:4)
+ENDIF
+!
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+!CALL PCSETC('FC','/')
+!CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+!CALL PCSETC('FC',':')
+CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+CALL SET(.1,.9,.1,.9,XXX(NIINF,1),XXX(NISUP,1), &
+ XHMIN,XHMAX,1)
+YFORMAX=' '
+IF(LFMTAXEX)THEN
+ YFORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ELSE
+ YFORMAX='(F8.0)'
+ENDIF
+YFORMAY=' '
+IF(LFMTAXEY)THEN
+ YFORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ELSE
+ YFORMAY='(F6.0)'
+ENDIF
+!
+CALL LABMOD(YFORMAX,YFORMAY,0,0,10,10,0,0,0)
+!CALL LABMOD('(F8.0)','(F6.0)',9,6,10,10,0,0,0)
+CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,1,5,0.,0.)
+!
+IF (GLAG) THEN
+ ! trace du masque (etoiles colorees)
+ CALL GSMK(3)
+ CALL GSPMCI(1)
+ DO JILOOP=IIB,IIE
+ DO JJLOOP=IJB,IJE
+ DO JKLOOP=IKB,IKE
+ IF(LMASK3(JILOOP,JJLOOP,JKLOOP,JTLOOP) )THEN
+ ZX=XXX(JILOOP,1)
+ ZY=XZZ(JILOOP,JJLOOP,JKLOOP)
+ CALL GPM(1,ZX,ZY)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ !
+ ! trace de la zone de lacher (cercles)
+ CALL GSMK(4)
+ CALL GSPMCI(3)
+ DO JILOOP=IIB,IIE
+ DO JJLOOP=IJB,IJE
+ DO JKLOOP=IKB,IKE
+ IF(LMASK3(JILOOP,JJLOOP,JKLOOP,JTLOOP) )THEN
+ ZX=ZSVM1(JILOOP,JJLOOP,JKLOOP,JTLOOP)
+ ZY=ZSVM3(JILOOP,JJLOOP,JKLOOP,JTLOOP)
+ CALL GPM(1,ZX,ZY)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ !
+ELSE
+ ! trace du masque (etoiles colorees)
+ DO JILOOP=IIB,IIE
+ DO JJLOOP=IJB,IJE
+ DO JKLOOP=IKB,IKE
+ IF(LMASK3(JILOOP,JJLOOP,JKLOOP,JTLOOP) )THEN
+ ZX=XXX(JILOOP,1)
+ ZY=XZZ(JILOOP,JJLOOP,JKLOOP)
+ CALL GPM(1,ZX,ZY)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ ! trace de la boite de lacher
+ CALL GSPLCI(3)
+ CALL GSLWSC(3.)
+ CALL FRSTPT(XXL,XZL)
+ CALL VECTOR(XXH,XZL)
+ CALL VECTOR(XXH,XZH)
+ CALL VECTOR(XXL,XZH)
+ CALL VECTOR(XXL,XZL)
+ENDIF
+!
+CALL FRAME
+ENDIF
+CALL GSLWSC(1.)
+CALL GSPLCI(1)
+!
+!!!!!! YZ
+!
+IF(LMASK3D_YZ)THEN
+
+IF(NJMAX /= 1)THEN
+WRITE(YCAR,'(''MASK **YZ- ** window:('',F8.0,'':'',F8.0,'','',F8.0,'':'',F8.0,'','',F6.0,'':'',F6.0,'')'')') &
+ XXL,XXH,XYL,XYH,XZL,XZH
+IF(GLAG) THEN
+ YCAR(11:12)=YNUMBER
+ELSE
+ YCAR(11:12)=YGROUP(3:4)
+ENDIF
+!
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+!CALL PCSETC('FC','/')
+!CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+!CALL PCSETC('FC',':')
+CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+CALL SET(.1,.9,.1,.9,XXY(NJINF,1),XXY(NJSUP,1), &
+ XHMIN,XHMAX,1)
+YFORMAX=' '
+IF(LFMTAXEX)THEN
+ YFORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ELSE
+ YFORMAX='(F8.0)'
+ENDIF
+YFORMAY=' '
+IF(LFMTAXEY)THEN
+ YFORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ELSE
+ YFORMAY='(F6.0)'
+ENDIF
+
+CALL LABMOD(YFORMAX,YFORMAY,0,0,10,10,0,0,0)
+!CALL LABMOD('(F8.0)','(F6.0)',9,6,10,10,0,0,0)
+CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,1,5,0.,0.)
+IF (GLAG) THEN
+ ! trace du masque (etoiles colorees)
+ CALL GSMK(3)
+ CALL GSPMCI(1)
+ DO JILOOP=IIB,IIE
+ DO JJLOOP=IJB,IJE
+ DO JKLOOP=IKB,IKE
+ IF(LMASK3(JILOOP,JJLOOP,JKLOOP,JTLOOP) )THEN
+ ZX=XXY(JJLOOP,1)
+ ZY=XZZ(JILOOP,JJLOOP,JKLOOP)
+ CALL GPM(1,ZX,ZY)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ !
+ ! trace de la zone de lacher (cercles)
+ CALL GSMK(4)
+ CALL GSPMCI(2)
+ DO JILOOP=IIB,IIE
+ DO JJLOOP=IJB,IJE
+ DO JKLOOP=IKB,IKE
+ IF(LMASK3(JILOOP,JJLOOP,JKLOOP,JTLOOP) )THEN
+ ZX=ZSVM2(JILOOP,JJLOOP,JKLOOP,JTLOOP)
+ ZY=ZSVM3(JILOOP,JJLOOP,JKLOOP,JTLOOP)
+ CALL GPM(1,ZX,ZY)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ !
+ELSE
+ ! trace du masque (etoiles colorees)
+ DO JILOOP=IIB,IIE
+ DO JJLOOP=IJB,IJE
+ DO JKLOOP=IKB,IKE
+ IF(LMASK3(JILOOP,JJLOOP,JKLOOP,JTLOOP) )THEN
+ ZX=XXY(JJLOOP,1)
+ ZY=XZZ(JILOOP,JJLOOP,JKLOOP)
+ CALL GPM(1,ZX,ZY)
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+ ! trace de la boite de lacher
+ CALL GSPLCI(2)
+ CALL GSLWSC(3.)
+ CALL FRSTPT(XYL,XZL)
+ CALL VECTOR(XYH,XZL)
+ CALL VECTOR(XYH,XZH)
+ CALL VECTOR(XYL,XZH)
+ CALL VECTOR(XYL,XZL)
+ENDIF
+!
+CALL FRAME
+ENDIF
+ENDIF
+
+ENDDO
+! Recuperation du viewport courant pour son eventuelle impression
+CALL GETSET(XCURVPTL,XCURVPTR,XCURVPTB,XCURVPTT,ZWLBID,ZWRBID,ZWBBID,ZWTBID,IDBID)
+! Restauration de la fenetre a l'entree de la routine
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ENDIF
+
+CALL GSPLCI(1)
+CALL GSPMCI(1)
+CALL GSLWSC(1.)
+CALL GSLN(1)
+DEALLOCATE(ZSVM1,ZSVM2,ZSVM3)
+IF (GLAG) DEALLOCATE(ZFIELD_LAG)
+IF (LXYZ00) CGROUPSV3=YSTO_CGROUPSV3
+NMGRID=IGRID
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+!
+RETURN
+END SUBROUTINE TRAMASK3D
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/trapro_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/trapro_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b42fb5d84905e20229da22143eaa053d2ae4ed3e
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/trapro_fordiachro.f90
@@ -0,0 +1,829 @@
+! ######spl
+ MODULE MODI_TRAPRO_FORDIACHRO
+! #############################
+!
+INTERFACE
+!
+SUBROUTINE TRAPRO_FORDIACHRO(PTEM1D,PWORKZ,KLOOP)
+INTEGER :: KLOOP
+REAL,DIMENSION(:) :: PTEM1D, PWORKZ
+END SUBROUTINE TRAPRO_FORDIACHRO
+!
+END INTERFACE
+END MODULE MODI_TRAPRO_FORDIACHRO
+! ######spl
+ SUBROUTINE TRAPRO_FORDIACHRO(PTEM1D,PWORKZ,KLOOP)
+! #################################################
+!
+!!**** *TRAPRO_FORDIACHRO* - Manager of the 1D vertical profile plots
+!!
+!! PURPOSE
+!! -------
+!! Controls 1D vertical profiles of scalar or vector variables.
+!! The displayed variables may be either from the Meso-NH basic
+!! set or generic.
+!
+!!** METHOD
+!! ------
+!! Arrays are allocated, interactive dialogue is performed, and
+!! a branching is made either on the 'basic Meso-NH' set section
+!! or on the "generic variable" section where calls are made to the
+!! tracing routine PRO1D.
+!!
+!! EXTERNAL
+!! --------
+!! VALNGRID : retrieves NGRID, the grid indicator, for the current
+!! variable name
+!! PRO1D : tracing routine for the 1D vertical profiles
+!! OPNGKS : opens NCAR and GKS graphics
+!! CLSGKS : closes NCAR and GKS graphics
+!! COMPCOORD : computes gridpoint locations, meshsizes and topography
+!! for all the possible grids, and true altitude where
+!! required.
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_TITLE : Declares heading variables for the plots (TRACE)
+!! CLEGEND: Current plot heading title
+!!
+!! Module MODD_NMGRID : declares global variable NMGRID
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!!
+!! Module MODN_PARA: Defines NAM_DOMAIN_POS namelist (former PARA common)
+!! NLMAX : Number of points horizontally along
+!! the vertical section
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NKMAX : z array dimension
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!! JPVEXT : Vertical external points number
+!!
+!! Module MODN_NCAR
+!!>>>>> DRAGOON NOTICE: <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+!!>>>>> Apparently not used
+!!>>>>> DRAGOON NOTICE: <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+!!
+!! Module MODD_CVERT: Declares work arrays for vertical cross-sections
+!! XWORKZ : working array for true altitude storage (all grids)
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXZ : Gal-Chen z coordinate values for all the MESO-NH grids
+!!
+!! Module MODD_GRID1 : declares grid variables (Model module)
+!! XZZ : true gridpoint z altitude
+!!
+!! Module MODD_SUPER : defines plot overlay control variables
+!! LSUPER : =.TRUE. --> plot overlay is active
+!! =.FALSE. --> plot overlay is not active
+!!
+#ifdef NAGf95
+USE F90_UNIX ! for FLUSH and GETENV
+#endif
+
+USE MODD_TITLE
+USE MODD_TIT
+USE MODD_NMGRID
+USE MODN_PARA
+USE MODD_PARAMETERS
+USE MODN_NCAR
+USE MODD_COORD
+USE MODD_GRID1
+USE MODD_GRID
+USE MODD_CONF
+USE MODE_GRIDPROJ
+USE MODD_SUPER
+USE MODD_OUT
+USE MODD_DEFCV
+USE MODD_TYPE_AND_LH
+USE MODD_RESOLVCAR
+USE MODD_CTL_AXES_AND_STYL
+USE MODI_READMNMX_FT_PVKT
+!
+USE MODI_WRITEDIR
+!
+IMPLICIT NONE
+!
+!* 0.1 interface declarations
+!
+INTERFACE
+ SUBROUTINE PRO1D_FORDIACHRO(KPRO,PPRO,PTAB,PTABMIN,PTABMAX,KXDOT,HLEGEND,HTEXT)
+ INTEGER :: KPRO, KXDOT
+ REAL :: PTABMIN, PTABMAX
+ REAL,DIMENSION(:) :: PTAB, PPRO
+ CHARACTER(LEN=*) :: HTEXT, HLEGEND
+ END SUBROUTINE PRO1D_FORDIACHRO
+END INTERFACE
+INTERFACE
+ SUBROUTINE VALMNMX(PMIN,PMAX)
+ REAL :: PMIN, PMAX
+ END SUBROUTINE VALMNMX
+END INTERFACE
+!
+!* 0.1 Dummy arguments
+!
+INTEGER :: KLOOP
+REAL,DIMENSION(:) :: PTEM1D, PWORKZ
+!
+!* 0.2 local variables
+!
+!
+INTEGER :: IKU, IKE, IKB
+INTEGER :: IMJ
+INTEGER :: I, IM, IMB, J
+INTEGER :: ILENT, ILENU, IENDTXT
+INTEGER :: ISTA, IER, INB, IWK, ICOL
+INTEGER :: IPROFILE, IKL, IKH
+INTEGER :: INUM, IRESP
+INTEGER :: ISTYL !, ISTY
+!
+REAL,SAVE :: ZMIN, ZMAX, ZMN, ZMX
+REAL :: ZBMIN, ZBMAX
+REAL,SAVE :: ZHMIN, ZHMAX
+REAL,SAVE :: ZMNM, ZMXM
+REAL,SAVE :: ZX, ZY, ZLAT, ZLON
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZLA, ZLO
+#ifdef RHODES
+INTEGER :: ISTAF
+#endif
+!
+CHARACTER(LEN=20) :: YNOM
+CHARACTER(LEN=40):: YTEXTE
+CHARACTER(LEN=80):: YCAR80
+CHARACTER(LEN=20):: YCAR20
+CHARACTER(LEN=3) :: YREP
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. PRELIMINARY CALCULATIONS
+! ------------------------
+!
+!!!!!!!!!!! 110797
+IF(NLOOPSUPER == 1)THEN
+ZHMIN=XHMIN; ZHMAX=XHMAX
+ENDIF
+!!!!!!!!!!! 110797
+NGSLNP=0
+IKU=NKMAX+2*JPVEXT
+SELECT CASE(CTYPE)
+ CASE('CART','MASK')
+ IKB=1+JPVEXT
+ IKE=IKU-JPVEXT
+ CASE('SSOL','DRST','RAPL')
+ IKB=1
+ IKE=SIZE(PTEM1D)
+ IKL=NKL
+ IKH=NKH
+ NKL=1
+ NKH=SIZE(PTEM1D)
+END SELECT
+YTEXTE(1:LEN(YTEXTE)) = ' '
+ILENT=LEN_TRIM(CTITGAL)
+ILENU=LEN_TRIM(CUNITGAL)
+YTEXTE(1:ILENT)=CTITGAL(1:ILENT)
+YTEXTE(ILENT+1:ILENT+1)=' '
+YTEXTE(ILENT+2:ILENT+2+ILENU-1)=CUNITGAL(1:ILENU)
+IENDTXT=ILENT+2+ILENU
+!
+ IF(CTYPE == 'CART' .AND. .NOT.L1DT)THEN
+ IF(.NOT.LCARTESIAN)THEN
+ ALLOCATE(ZLA(NLMAX),ZLO(NLMAX))
+ DO J=1,NLMAX
+ ZX=XDSX(J,NMGRID)
+ ZY=XDSY(J,NMGRID)
+ CALL SM_LATLON_S(XLATORI,XLONORI,ZX,ZY,ZLAT,ZLON)
+ ZLA(J)=ZLAT
+ ZLO(J)=ZLON
+ ENDDO
+ if(nverbia > 0)then
+ print *,' ZLA'
+ print *,ZLA
+ print *,' ZLO'
+ print *,ZLO
+ endif
+ IF(LDEFCV2LL)THEN
+ ZLA(1)=XIDEBCVLL
+ ZLO(1)=XJDEBCVLL
+ ENDIF
+! print *,' ZLA'
+! print *,ZLA
+! print *,' ZLO'
+! print *,ZLO
+ XIPROFV=ZLA(NPROFILE); XJPROFV=ZLO(NPROFILE)
+ if(nverbia > 0)then
+ print *,' NPROFILE ZLA ZLO ',NPROFILE,ZLA(NPROFILE),ZLO(NPROFILE)
+ endif
+ DEALLOCATE(ZLA,ZLO)
+ ENDIF
+ ENDIF
+IF(LPRINT)THEN
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ IF(CTYPE == 'CART' .OR. CTYPE == 'MASK')THEN
+ WRITE(INUM,'(''TRAPRO '',''G:'',A16,'' P:'',A25,'' '',A16,'' (1-IKU)''&
+& )')CGROUP,CTITGAL(1:25),ADJUSTL(CTIMEC)
+ ELSE
+ WRITE(INUM,'(''TRAPRO '',''G:'',A16,'' P:'',A25,'' '',A16,'' NBVAL:'',&
+& I8)')CGROUP,CTITGAL(1:25),ADJUSTL(CTIMEC),SIZE(PTEM1D)
+ ENDIF
+ IF(LPLUS .OR.LMINUS)THEN
+ WRITE(INUM,'(A70,A4)')CTITB3,CTYPE
+ ELSE
+ WRITE(INUM,'(A40,A4)')CTITGAL,CTYPE
+ ENDIF
+ IF(CTYPE == 'CART' .AND. .NOT.L1DT)THEN
+ IF(.NOT.LCARTESIAN)THEN
+ ALLOCATE(ZLA(NLMAX),ZLO(NLMAX))
+ DO J=1,NLMAX
+ ZX=XDSX(J,NMGRID)
+ ZY=XDSY(J,NMGRID)
+ CALL SM_LATLON_S(XLATORI,XLONORI,ZX,ZY,ZLAT,ZLON)
+ ZLA(J)=ZLAT
+ ZLO(J)=ZLON
+ ENDDO
+ IF(LDEFCV2LL)THEN
+ ZLA(1)=XIDEBCVLL
+ ZLO(1)=XJDEBCVLL
+ ENDIF
+! print *,' ZLA'
+! print *,ZLA
+! print *,' ZLO'
+! print *,ZLO
+ XIPROFV=ZLA(NPROFILE); XJPROFV=ZLO(NPROFILE)
+ print *,' NPROFILE ZLA ZLO ',NPROFILE,ZLA(NPROFILE),ZLO(NPROFILE)
+ DEALLOCATE(ZLA,ZLO)
+ ENDIF
+ IF(LDEFCV2CC)THEN
+ IF(LDEFCV2)THEN
+ WRITE(INUM,'(''cc(deb)-(fin)=('',F8.0,'','',F8.0,'')-('',F8.0,'','',F8.0,'')'','' nlmax'',i5,&
+& '' profile'',i4)')XIDEBCV,XJDEBCV,XIFINCV,XJFINCV,NLMAX,NPROFILE
+ ELSE IF(LDEFCV2LL)THEN
+ WRITE(INUM,'(''ll(deb)-(fin)=('',F8.3,'','',F8.3,'')-('',F8.3,'','',F8.3,'')'','' nlmax'',i5,&
+& '' profile'',i4)')XIDEBCVLL,XJDEBCVLL,XIFINCVLL,XJFINCVLL,NLMAX,NPROFILE
+ ELSE IF(LDEFCV2IND)THEN
+ WRITE(INUM,'(''ij(deb)-(fin)=('',I4,'','',I4,'')-('',I4,'','',I4,'')'','' nlmax'',i5,&
+& '' profile'',i4)')NIDEBCV,NJDEBCV,NIFINCV,NJFINCV,NLMAX,NPROFILE
+ ENDIF
+ ELSE
+ IF(XIDEBCOU /= -999.)THEN
+ WRITE(INUM,'(''xidebcou'',F8.0,'' xjdebcou'',F8.0,'' nlmax'',i5,'' nlangle'',i4,&
+ & '' profile'',i4)')XIDEBCOU,XJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ELSE
+ WRITE(INUM,'(''nidebcou'',i4,'' njdebcou'',i4,'' nlmax'',i5,'' nlangle'',i4,&
+ & '' profile'',i4)')NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ENDIF
+ ENDIF
+ ENDIF
+! JUin 2001 Ecriture des dates (Demande G.Jaubert ) si LPRDAT=T
+ IF(LPRDAT)THEN
+ IF(.NOT.ALLOCATED(XPRDAT))THEN
+ print *,'**TRAPRO XPRDAT NON ALLOUE.Dates non ecrites ds FICVAL .Prevenir J.Duron'
+ ELSE
+ WRITE(INUM,'(1X,75(''*''))')
+ WRITE(INUM,'(1X,'' Dates courante * modele * experience * segment'')')
+ WRITE(INUM,'(1X,'' J An M J Sec. * An M J Sec. * An M J Sec. * An M J Sec.'')')
+ WRITE(INUM,'(1X,75(''*''))')
+ DO J=1,SIZE(XPRDAT,2)
+ WRITE(INUM,'(1X,I3,1X,3(I4,I3,I3,I6,'' *''),I4,I3,I3,I6)')J,INT(XPRDAT(:,J))
+
+ ENDDO
+ ENDIF
+ ENDIF
+! JUin 2001 Ecriture des dates
+ WRITE(INUM,'(1X,45(''*''))')
+ WRITE(INUM,'('' K'',12X,''X'',19X,''Z''," NBVAL:",I6)')SIZE(PTEM1D)
+ WRITE(INUM,'(1X,45(''*''))')
+ DO J=SIZE(PTEM1D),1,-1
+ WRITE(INUM,'(I5,4X,E15.8,4X,E15.8)')J,PTEM1D(J),PWORKZ(J)
+ ENDDO
+ENDIF
+!
+!
+!
+!* 1.4 Interactive selection of the profile location, and
+!* field name
+!
+! Profile point selection
+!
+IF(.NOT. L1DT)THEN
+
+IF(NPROFILE.GT.NLMAX)THEN
+ PRINT *,' This point ',NPROFILE,' lays out of the section limits..'
+ PRINT *,' index has to be smaller than ',NLMAX
+ PRINT *,' Enter the gridpoint location for the profile: '
+ PRINT *,' i.e. the gridpoint index along the oblique vertical section '
+ PRINT *,' starting at (NIDEBCOU,NJDEBCOU or XIDEBCOU,XJDEBCOU or .....)?'
+ READ(5,*)NPROFILE
+ENDIF
+
+ELSE
+
+ IPROFILE=NPROFILE
+ NPROFILE=1
+
+ENDIF
+!
+! Field name selection
+!
+YNOM=ADJUSTL(CGROUP)
+IF(YNOM.EQ.'QUIT')THEN
+!
+!* 1.5 End of job: EXIT
+!
+ CALL GQOPS(ISTA)
+ CALL GQACWK(1,IER,INB,IWK)
+ IF(ISTA >1 .AND. INB >1)THEN
+ CALL GDAWK(2)
+ CALL GCLWK(2)
+ ENDIF
+! CALL FRAME
+ CALL NGPICT(1,1)
+ CALL CLSGKS
+ STOP
+! print *,' Profile''s bounds (min and max )? '
+! READ(5,*)ZBMIN,ZBMAX
+ELSE
+ ZBMIN=0.;ZBMAX=0.
+END IF
+!
+!* 1.6 Ooverlay control
+!
+IF(NSUPERDIA > 1)THEN
+ LSUPER=.TRUE.
+ELSE
+ LSUPER=.FALSE.
+ENDIF
+IF(KLOOP == 1)NSUPER=0
+!
+!
+!* 1.8 Line width changes to differentiate the
+!* successive plots in an overlay sequence
+!
+CALL TABCOL_FORDIACHRO
+CALL GSLWSC(2.)
+CALL GSLN(1)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF(LSUPER)THEN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ NSUPER=NSUPER+1
+!----------------------------------------------------------
+ IF(LCOLINE)THEN
+!----------------------------------------------------------
+ SELECT CASE(NSUPER)
+ CASE(1)
+ IF(XLWPV1 /= 0.)CALL GSLWSC(XLWPV1)
+ CASE(2)
+ IF(XLWPV2 /= 0.)CALL GSLWSC(XLWPV2)
+ CASE(3)
+ IF(XLWPV3 /= 0.)CALL GSLWSC(XLWPV3)
+ CASE(4)
+ IF(XLWPV4 /= 0.)CALL GSLWSC(XLWPV4)
+ CASE(5)
+ IF(XLWPV5 /= 0.)CALL GSLWSC(XLWPV5)
+ CASE(6)
+ IF(XLWPV6 /= 0.)CALL GSLWSC(XLWPV6)
+ CASE(7)
+ IF(XLWPV7 /= 0.)CALL GSLWSC(XLWPV7)
+ CASE(8)
+ IF(XLWPV8 /= 0.)CALL GSLWSC(XLWPV8)
+!!!!!!!!!!!!!!!!!
+ CASE(9)
+ IF(XLWPV9 /= 0.)CALL GSLWSC(XLWPV9)
+ CASE(10)
+ IF(XLWPV10 /= 0.)CALL GSLWSC(XLWPV10)
+ CASE(11)
+ IF(XLWPV11 /= 0.)CALL GSLWSC(XLWPV11)
+ CASE(12)
+ IF(XLWPV12 /= 0.)CALL GSLWSC(XLWPV12)
+ CASE(13)
+ IF(XLWPV13 /= 0.)CALL GSLWSC(XLWPV13)
+ CASE(14)
+ IF(XLWPV14 /= 0.)CALL GSLWSC(XLWPV14)
+ CASE(15)
+ IF(XLWPV15 /= 0.)CALL GSLWSC(XLWPV15)
+!!!!!!!!!!!!!!!!!
+ CASE DEFAULT
+ CALL GSLWSC(2.)
+ END SELECT
+!+++++++++++++++++++++++++++++++++
+ IF(LCOLUSER)THEN
+!+++++++++++++++++++++++++++++++++
+ IF(NSUPER == 1)THEN
+ print *,' VOUS VOULEZ VRAIMENT SELECTIONNER LES COULEURS DES PROFILS ? (y/n) '
+ YREP=' '
+ READ(5,'(A3)',END=10)YREP
+ GO TO 20
+ 10 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ READ(5,'(A3)')YREP
+ 20 CONTINUE
+ YCAR80=YREP
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,YCAR80)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ IF(YREP /= 'y' .AND. YREP /= 'yes' .AND. YREP /= 'Y' &
+ .AND. YREP /= 'YES' &
+ .AND. YREP /= 'o' .AND. YREP /= 'oui' .AND. YREP /= 'O' &
+ .AND. YREP /= 'OUI')THEN
+ LCOLUSER=.FALSE.
+ print *,' LCOLUSER REMIS A .FALSE.'
+ YCAR20(1:LEN(YCAR20))=' '
+ INQUIRE(5,NAME=YCAR20)
+ print *,' AP INQUIRE YCAR20 ',YCAR20
+ YCAR20=ADJUSTL(YCAR20)
+ IF(YCAR20(1:8) /= '/dev/tty')BACKSPACE 5
+ CALL GSLN(1)
+ CALL GSPLCI(NSUPER+1)
+ ELSE
+ print *,' INDICE DE COULEUR POUR ',CTITGAL(1:ILENT),' ? '
+ READ(5,*,END=11)ICOL
+ GO TO 21
+ 11 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ READ(5,*)ICOL
+ 21 CONTINUE
+ WRITE(YCAR80,*)ICOL
+ YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,YCAR80)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+! WRITE(NDIR,*)YCAR80
+ CALL GSLN(1)
+ CALL GSPLCI(ICOL)
+ ENDIF
+ ELSE
+ print *,' INDICE DE COULEUR POUR ',CTITGAL(1:ILENT),' ? '
+ READ(5,*,END=12)ICOL
+ GO TO 22
+ 12 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ READ(5,*)ICOL
+ 22 CONTINUE
+ WRITE(YCAR80,*)ICOL
+ YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,YCAR80)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+! WRITE(NDIR,*)YCAR80
+ CALL GSLN(1)
+ CALL GSPLCI(ICOL)
+ ENDIF
+!+++++++++++++++++++++++++++++++++
+ ELSE
+!+++++++++++++++++++++++++++++++++
+ CALL GSLN(1)
+ CALL GSPLCI(NSUPER+1)
+!+++++++++++++++++++++++++++++++++
+ ENDIF
+!+++++++++++++++++++++++++++++++++
+!----------------------------------------------------------
+ ELSE
+!----------------------------------------------------------
+ CALL GSPLCI(1)
+! IF(NSUPER == 1)CALL GSLN(1) ! Solid line : first in sequence
+! IF(NSUPER == 2)CALL GSLN(3) ! Dotted line: second in sequence
+! IF(NSUPER == 3)CALL GSLN(2) ! Dashed line
+! IF(NSUPER == 4)CALL GSLN(4) ! Dashed line: further on
+ CALL GSTXCI(1)
+ SELECT CASE(NSUPER)
+ CASE(:4)
+ CALL GSLWSC(1.)
+ IF(NSUPER == 1 .AND. XLWPV1 /= 0.)CALL GSLWSC(XLWPV1)
+ IF(NSUPER == 2 .AND. XLWPV2 /= 0.)CALL GSLWSC(XLWPV2)
+ IF(NSUPER == 3 .AND. XLWPV3 /= 0.)CALL GSLWSC(XLWPV3)
+ IF(NSUPER == 4 .AND. XLWPV4 /= 0.)CALL GSLWSC(XLWPV4)
+ CASE(5:8)
+ CALL GSLWSC(2.)
+ IF(NSUPER == 5 .AND. XLWPV5 /= 0.)CALL GSLWSC(XLWPV5)
+ IF(NSUPER == 6 .AND. XLWPV6 /= 0.)CALL GSLWSC(XLWPV6)
+ IF(NSUPER == 7 .AND. XLWPV7 /= 0.)CALL GSLWSC(XLWPV7)
+ IF(NSUPER == 8 .AND. XLWPV8 /= 0.)CALL GSLWSC(XLWPV8)
+ CASE(9:12)
+ CALL GSLWSC(3.)
+!!!!!!!!!!
+ IF(NSUPER == 9 .AND. XLWPV9 /= 0.)CALL GSLWSC(XLWPV9)
+ IF(NSUPER == 10 .AND. XLWPV10 /= 0.)CALL GSLWSC(XLWPV10)
+ IF(NSUPER == 11 .AND. XLWPV11 /= 0.)CALL GSLWSC(XLWPV11)
+ IF(NSUPER == 12 .AND. XLWPV12 /= 0.)CALL GSLWSC(XLWPV12)
+!!!!!!!!!!
+ CASE(13:16)
+ CALL GSLWSC(4.)
+!!!!!!!!!!
+ IF(NSUPER == 13 .AND. XLWPV13 /= 0.)CALL GSLWSC(XLWPV13)
+ IF(NSUPER == 14 .AND. XLWPV14 /= 0.)CALL GSLWSC(XLWPV14)
+ IF(NSUPER == 15 .AND. XLWPV15 /= 0.)CALL GSLWSC(XLWPV15)
+!!!!!!!!!!
+ CASE DEFAULT
+ CALL GSLWSC(1.)
+ END SELECT
+ NGSLNP=0
+ IF(NSUPER == 1 .AND. XSTYLPV1 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV1))
+ CALL GQLN(IER,ISTYL)
+! print *,' TRAPRO 1 INT(XSTYLPV1) ISTYL ',INT(XSTYLPV1),ISTYL
+ IF(INT(XSTYLPV1) >4)NGSLNP=XSTYLPV1-1
+ ELSEIF(NSUPER == 2 .AND. XSTYLPV2 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV2))
+ IF(INT(XSTYLPV2) >4)NGSLNP=XSTYLPV2-1
+ ELSEIF(NSUPER == 3 .AND. XSTYLPV3 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV3))
+ IF(INT(XSTYLPV3) >4)NGSLNP=XSTYLPV3-1
+ ELSEIF(NSUPER == 4 .AND. XSTYLPV4 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV4))
+ IF(INT(XSTYLPV4) >4)NGSLNP=XSTYLPV4-1
+ ELSEIF(NSUPER == 5 .AND. XSTYLPV5 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV5))
+ IF(INT(XSTYLPV5) >4)NGSLNP=XSTYLPV5-1
+ ELSEIF(NSUPER == 6 .AND. XSTYLPV6 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV6))
+ IF(INT(XSTYLPV6) >4)NGSLNP=XSTYLPV6-1
+ ELSEIF(NSUPER == 7 .AND. XSTYLPV7 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV7))
+ IF(INT(XSTYLPV7) >4)NGSLNP=XSTYLPV7-1
+ ELSEIF(NSUPER == 8 .AND. XSTYLPV8 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV8))
+ IF(INT(XSTYLPV8) >4)NGSLNP=XSTYLPV8-1
+!!!!!!!!!!
+ ELSEIF(NSUPER == 9 .AND. XSTYLPV9 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV9))
+ IF(INT(XSTYLPV9) >4)NGSLNP=XSTYLPV9-1
+ ELSEIF(NSUPER == 10 .AND. XSTYLPV10 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV10))
+ IF(INT(XSTYLPV10) >4)NGSLNP=XSTYLPV10-1
+ ELSEIF(NSUPER == 11 .AND. XSTYLPV11 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV11))
+ IF(INT(XSTYLPV11) >4)NGSLNP=XSTYLPV11-1
+ ELSEIF(NSUPER == 12 .AND. XSTYLPV12 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV12))
+ IF(INT(XSTYLPV12) >4)NGSLNP=XSTYLPV12-1
+ ELSEIF(NSUPER == 13 .AND. XSTYLPV13 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV13))
+ IF(INT(XSTYLPV13) >4)NGSLNP=XSTYLPV13-1
+ ELSEIF(NSUPER == 14 .AND. XSTYLPV14 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV14))
+ IF(INT(XSTYLPV14) >4)NGSLNP=XSTYLPV14-1
+ ELSEIF(NSUPER == 15 .AND. XSTYLPV15 /= 0.)THEN
+ CALL GSLN(INT(XSTYLPV15))
+ IF(INT(XSTYLPV15) >4)NGSLNP=XSTYLPV15-1
+!!!!!!!!!!
+ ELSE
+ CALL GSLN(MOD(NSUPER,4))
+ IF(MOD(NSUPER,4) == 0)CALL GSLN(4)
+ ENDIF
+!----------------------------------------------------------
+ END IF
+!----------------------------------------------------------
+! print *,' TRAPRO 1 entre ENDIF et ELSE INT(XSTYLPV1) ISTYL ',INT(XSTYLPV1),ISTYL
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ELSE
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! CALL GSLWSC(1.)
+ CALL GSLWSC(2.)
+ IF(XLWPV1 /= 0.)CALL GSLWSC(XLWPV1)
+ CALL GSLN(1) ! Solid line if no overlay
+! ISTY=NINT(XSTYLPV1)
+! NGSLNP=0
+! IF(XSTYLPV1 /= 0.)THEN
+! CALL GSLN(ISTY)
+! IF(INT(XSTYLPV1) >4)NGSLNP=XSTYLPV1-1
+! print *,' TRAPRO 2 INT(XSTYLPV1) ',INT(XSTYLPV1)
+! ENDIF
+! CALL GQLN(IER,ISTYL)
+! print *,' TRAPRO 2 ISTYL ',ISTYL
+!+++++++++++++++++++++++++++++++++
+ IF(LCOLUSER)THEN
+!+++++++++++++++++++++++++++++++++
+ print *,' INDICE DE COULEUR ? '
+ READ(5,*,END=82)ICOL
+ GO TO 92
+ 82 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ READ(5,*)ICOL
+ 92 CONTINUE
+ WRITE(YCAR80,*)ICOL
+ YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,YCAR80)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+! WRITE(NDIR,*)YCAR80
+ CALL GSLN(1)
+ CALL GSPLCI(ICOL)
+!+++++++++++++++++++++++++++++++++
+ ELSE
+!+++++++++++++++++++++++++++++++++
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+!+++++++++++++++++++++++++++++++++
+ ENDIF
+!+++++++++++++++++++++++++++++++++
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+END IF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. PROCESSING THE BASIC SET OF PROGNOSTIC VARIABLES
+! ------------------------------------------------
+!
+! On a NMGRID CTITGAL CUNITGAL
+! TESTER NMGRID DANS OPER POUR LE METTRE A 1 SI IL A UNE VALEUR ABERRANTE
+IF(XHMAX-XHMIN == 0.)THEN
+
+SELECT CASE(CTYPE)
+ CASE('CART','MASK')
+ XHMIN=0.
+! XHMIN=PWORKZ(IKB)
+ XHMAX=PWORKZ(IKE)
+ CASE('SSOL','DRST','RAPL')
+ XHMIN=MIN(0.,PWORKZ(IKB))
+ XHMAX=MAX(0.,PWORKZ(IKE))
+ IF(XHMIN == 0. .AND. XHMAX == 0.)THEN
+ XHMIN=-1.
+ XHMAX=1.
+ ENDIF
+END SELECT
+
+ENDIF
+!ZPRO(:)=XWORKZ(IPRO,1:IKU,NMGRID) --> PWORKZ
+DO I=IKB,IKE
+ IF(XHMAX.LT.PWORKZ(I))THEN
+ IM=I
+ EXIT
+ ENDIF
+ IM=I
+ENDDO
+IM=MIN(IM,IKE)
+DO I=IKB,IKE
+ IF(XHMIN <= PWORKZ(I))THEN
+ IMB=MAX(I-1,IKB)
+ EXIT
+ ENDIF
+ IMB=MAX(I-1,IKB)
+ENDDO
+IF(NPVITVXMJ /= 0)THEN
+ IMJ=NPVITVXMJ
+ELSE
+ IMJ=4
+ENDIF
+ZMN=0.; ZMX=0.
+!IF(XPVMIN /=0. .OR. XPVMAX /=0.)THEN
+! ZMN=XPVMIN
+! ZMX=XPVMAX
+!ENDIF
+LOK=.FALSE.
+if(nverbia > 0)then
+ print *,' TRAPRO AP LOK=F LOK,LMNMXUSER ',LOK,LMNMXUSER
+endif
+IF(LMNMXUSER)THEN
+!666666666666666666666666666666666666666666666666666666666666666666
+ IF(XPVMAXT-XPVMINT /= 0)THEN
+ LOK=.TRUE.
+ ELSE
+!666666666666666666666666666666666666666666666666666666666666666666
+ print *,' TRAPRO ',CTITGAL
+ CALL READMNMX_FT_PVKT(CTITGAL(1:LEN_TRIM(CTITGAL)),ZMN,ZMX)
+ if(nverbia > 0)THEN
+ print *,' TRAPRO ZMN ZMX ',ZMN,ZMX,LOK
+ ENDIF
+!666666666666666666666666666666666666666666666666666666666666666666
+ ENDIF
+!666666666666666666666666666666666666666666666666666666666666666666
+ENDIF
+ZMIN=MINVAL(PTEM1D(MAX(IMB,NKL):MIN(IM,NKH)))
+ZMAX=MAXVAL(PTEM1D(MAX(IMB,NKL):MIN(IM,NKH)))
+
+print *,' TRAPRO ZMIN ZMAX TROUVES ',ZMIN,ZMAX
+
+!
+
+
+SELECT CASE(NSUPER)
+CASE(:1)
+!66666666666666666666666666666666666666666666666666
+ IF(LMNMXUSER .AND. LOK)THEN
+ IF(XPVMAXT-XPVMINT /= 0)THEN
+ print *,' TRAPRO XPVMINT,XPVMAXT UTILISES :',XPVMINT,XPVMAXT
+ CALL PRO1D_FORDIACHRO(NPROFILE,PWORKZ(:),PTEM1D(:),XPVMINT,XPVMAXT,IMJ,CLEGEND,YTEXTE&
+ (1:LEN_TRIM(YTEXTE)))
+ ELSE
+ CALL PRO1D_FORDIACHRO(NPROFILE,PWORKZ(:),PTEM1D(:),ZMN,ZMX,IMJ,CLEGEND,YTEXTE&
+ (1:LEN_TRIM(YTEXTE)))
+ ZMNM=ZMN; ZMXM=ZMX
+ ENDIF
+ ELSE
+!66666666666666666666666666666666666666666666666666
+ CALL VALMNMX(ZMIN,ZMAX)
+ IF(ZMAX-ZMIN == 0.)THEN
+ ZMIN=ZMIN-1.
+ ZMAX=ZMAX+1.
+ ENDIF
+ print *,' TRAPRO CALCUL AUTOMATIQUE DES BORNES: ',ZMIN,ZMAX
+! print *,' TRAPRO av pro1d INT(XSTYLPV1) ',INT(XSTYLPV1)
+! CALL GQLN(IER,ISTYL)
+! print *,' TRAPRO av pro1d ISTYL ',ISTYL
+ CALL PRO1D_FORDIACHRO(NPROFILE,PWORKZ(:),PTEM1D(:),ZMIN,ZMAX,IMJ,CLEGEND,YTEXTE &
+ (1:LEN_TRIM(YTEXTE)))
+ ZMNM=ZMIN; ZMXM=ZMAX
+ if(nverbia > 0)then
+ print *,' TRAPRO ap pro1d INT(XSTYLPV1) ',INT(XSTYLPV1)
+ endif
+ ENDIF
+
+!66666666666666666666666666666666666666666666666666
+!66666666666666666666666666666666666666666666666666
+CASE(2:)
+!66666666666666666666666666666666666666666666666666
+ IF(LMNMXUSER .AND. LOK)THEN
+ IF(XPVMAXT-XPVMINT /= 0)THEN
+ print *,' TRAPRO XPVMINT,XPVMAXT UTILISES :',XPVMINT,XPVMAXT
+ CALL PRO1D_FORDIACHRO(NPROFILE,PWORKZ(:),PTEM1D(:),XPVMINT,XPVMAXT,IMJ,CLEGEND,YTEXTE&
+ (1:LEN_TRIM(YTEXTE)))
+ ELSE
+ CALL PRO1D_FORDIACHRO(NPROFILE,PWORKZ(:),PTEM1D(:),ZMN,ZMX,IMJ,CLEGEND,YTEXTE &
+ (1:LEN_TRIM(YTEXTE)))
+ ENDIF
+ ELSE
+!66666666666666666666666666666666666666666666666666
+
+
+ IF(ZMIN >=ZMNM .AND. ZMAX <= ZMXM)THEN
+ CALL PRO1D_FORDIACHRO(NPROFILE,PWORKZ(:),PTEM1D(:),ZMNM,ZMXM,IMJ,CLEGEND,YTEXTE &
+ (1:LEN_TRIM(YTEXTE)))
+ ELSE
+ CALL VALMNMX(ZMIN,ZMAX)
+ IF(ZMAX-ZMIN == 0.)THEN
+ ZMIN=ZMIN-1.
+ ZMAX=ZMAX+1.
+ ENDIF
+ CALL PRO1D_FORDIACHRO(NPROFILE,PWORKZ(:),PTEM1D(:),ZMIN,ZMAX,IMJ,CLEGEND,YTEXTE &
+ (1:LEN_TRIM(YTEXTE)))
+ ENDIF
+ END IF
+!66666666666666666666666666666666666666666666666666
+!66666666666666666666666666666666666666666666666666
+END SELECT
+SELECT CASE(CTYPE)
+ CASE('SSOL','DRST','RAPL')
+ NKL=IKL
+ NKH=IKH
+ if(nverbia > 0)then
+ print *,' TRAPRO NKL NKH',NKL,NKH
+ endif
+END SELECT
+IF(L1DT)THEN
+ NPROFILE=IPROFILE
+ if(nverbia > 0)then
+ print *,' TRAPRO NPROFILE ',NPROFILE
+ endif
+ENDIF
+!
+1000 FORMAT(5X,I4,3X,A12)
+!
+!----------------------------------------------------------------------------
+!
+!* 4. EXIT
+! ----
+IF(.NOT.LSUPER .OR. (LSUPER .AND. NSUPER == NSUPERDIA))THEN
+ XHMIN=ZHMIN; XHMAX=ZHMAX
+ENDIF
+if(nverbia > 0)then
+print *,' TRAPRO SORTIE XSTYLPV1 ',XSTYLPV1
+endif
+RETURN
+!
+END SUBROUTINE TRAPRO_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/tratraj3d.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/tratraj3d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3f15c740d356227f2b5e5161f3a3169ca07a1898
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/tratraj3d.f90
@@ -0,0 +1,942 @@
+!-----------------------------------------------------------------
+! ####################
+ SUBROUTINE TRATRAJ3D
+! ####################
+!
+!!**** *TRATRAJ3D* - (Demande Joel Stein,Nicole Asencio, Francois Gheusi)
+!! (Avril 00)
+!!
+!! PURPOSE
+!! -------
+! Materialisation du positionnement de particules a divers instants
+! issues d'une position initiale connue ,
+! par transport de leurs coordonnees initiales dans les tableaux
+! scalaires SVx1, SVx2, SVx3
+!
+! Conjointement :
+! ecriture a chaque point de la trajectoire d'un champ donne
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron et J. Stein * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 12/04/00
+!! 21/11/03 J. Stein Modification of the test for the field
+!! computation along the backward trajectories
+!! 10/03/04 JD Ajout titres standard et possibilite de modification de
+!! ceux-ci
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_TRAJ3D
+USE MODD_TITLE
+USE MODD_TIT
+USE MODI_INTERPXYZ
+USE MODD_MASK3D
+USE MODD_RESOLVCAR
+USE MODD_CONF
+USE MODD_COORD
+USE MODD_GRID1
+USE MODD_NMGRID
+USE MODD_DIM1
+USE MODD_PARAMETERS
+USE MODD_SEVERAL_RECORDS
+USE MODD_FILES_DIACHRO
+USE MODD_ALLOC_FORDIACHRO
+USE MODI_REALLOC_AND_LOAD
+USE MODN_NCAR
+USE MODD_CTL_AXES_AND_STYL
+USE MODN_PARA
+USE MODI_TIT_TRA3D
+USE MODI_WRITEDIR
+!
+IMPLICIT NONE
+!
+COMMON/COLAREA/ICOL(300)
+!
+!* 0.1 Local variables
+!
+INTEGER :: JKLOOP,JILOOP , JJLOOP, J, ID, IGRID, JTLOOP, JI
+INTEGER :: IIB, IIE, IJB, IJE, IKB, IKE
+INTEGER :: ICL, ICOL, ILOOP, IDEB, IFIN, INUM, IRESP
+!
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: ZSVM1, ZSVM2, ZSVM3, ZCHAMP
+REAL :: ZVL, ZVR, ZVB, ZVT, ZWL, ZWR, ZWB, ZWT
+REAL :: ZVLL, ZVRL, ZVBL, ZVTL
+REAL :: ZMINZ, ZMAXZ, ZINTZ, ZISO
+REAL,DIMENSION(300) :: ZLEV
+!CHARACTER(LEN=8),DIMENSION(300) :: YLLBS
+CHARACTER(LEN=16) :: YGROUP
+CHARACTER(LEN=75) :: YCAR
+CHARACTER(LEN=12) :: YCHAMP
+CHARACTER(LEN=100),SAVE :: YTEM2
+CHARACTER(LEN=110),SAVE :: YTEM1
+INTEGER :: JPART,ICOLOR
+REAL, ALLOCATABLE, DIMENSION(:,:) :: ZXPOS,ZYPOS,ZZPOS, ZCHAMP_POS ! positions aux
+! instants correspondants aux differents fichiers
+LOGICAL, ALLOCATABLE, DIMENSION(:,:) :: GPART_IN ! particule in the
+ ! computational domain?
+!
+!-------------------------------------------------------------------------------
+IGRID=NMGRID
+NMGRID=1
+
+!
+! boucle generale sur les fichiers
+!
+DO JTLOOP=1,NBFILES
+! on lit les champs X0,Y0 et Z0 de la trajectoire pour tous les fichiers
+!
+! partie selon X
+ YGROUP='LGXM'
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='LGXT'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM001'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT001'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM1'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT1'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ !
+ IF(LPBREAD)THEN
+ print *,' Absence de variable LGXM, SVM001, LGXT ou SVT001 .. Operation impossible'
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+ IF (LGROUP) THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ CALL READ_DIACHRO(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ ENDIF
+ !
+ IF (.NOT. ALLOCATED(ZSVM1)) THEN
+ ALLOCATE(ZSVM1(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ZSVM1=11111.
+ ENDIF
+ IF(MAXVAL(XXHAT)/MAXVAL(XVAR) > 1.E2)THEN
+ print *,' ** Tratraj3D MAXVAL(XXHAT),MAXVAL(XVAR),*1000(KM->M) ',MAXVAL(XXHAT),MAXVAL(XVAR)
+ WHERE(XVAR(:,:,:,1,1,1) /= XSPVAL)
+ ZSVM1(:,:,:)=XVAR(:,:,:,1,1,1)*1000.
+ ELSEWHERE
+ ZSVM1(:,:,:)=XVAR(:,:,:,1,1,1)
+ ENDWHERE
+ ELSE
+ ZSVM1(:,:,:)=XVAR(:,:,:,1,1,1)
+ ENDIF
+ !
+ ! Chargement clegend clegend2
+ CALL RESOLV_TIMES(1)
+ YTEM2=' '
+ YTEM1=' '
+ YTEM2=CLEGEND2
+ ! Elimination volontaire de 104 a 108 charge ds resolv_times pour RS
+ YTEM1=CLEGEND(1:103)
+ !
+ IF(.NOT.LFIC1)THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+! CALL REALLOC_AND_LOAD(YGROUP)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE .',YGROUP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+!
+! partie selon Y
+ YGROUP='LGYM'
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='LGYT'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM002'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT002'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM2'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT2'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ !
+ IF(LPBREAD)THEN
+ print *,' Absence de variable LGYM, SVM002, LGYT ou SVT002 .. Operation impossible'
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+ IF (LGROUP) THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ CALL READ_DIACHRO(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ ENDIF
+ !
+ IF (.NOT. ALLOCATED(ZSVM2)) THEN
+ ALLOCATE(ZSVM2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ZSVM2=11111.
+ ENDIF
+ IF(MAXVAL(XYHAT)/MAXVAL(XVAR) > 1.E2)THEN
+ print *,' ** Tratraj3D MAXVAL(XYHAT),MAXVAL(XVAR),*1000(KM->M) ',MAXVAL(XYHAT),MAXVAL(XVAR)
+ WHERE(XVAR(:,:,:,1,1,1) /= XSPVAL)
+ ZSVM2(:,:,:)=XVAR(:,:,:,1,1,1)*1000.
+ ELSEWHERE
+ ZSVM2(:,:,:)=XVAR(:,:,:,1,1,1)
+ ENDWHERE
+ ELSE
+ ZSVM2(:,:,:)=XVAR(:,:,:,1,1,1)
+ ENDIF
+ !
+ IF(.NOT.LFIC1)THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE .',YGROUP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+!
+! partie selon Z
+ YGROUP='LGZM'
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='LGZT'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM003'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT003'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVM3'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ IF(LPBREAD)THEN
+ YGROUP='SVT3'
+ LPBREAD=.FALSE.
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ !
+ IF(LPBREAD)THEN
+ print *,' Absence de variable LGZM, SVM003, LGZT ou SVT003 .. Operation impossible'
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+ IF (LGROUP) THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ CALL READ_DIACHRO(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),YGROUP)
+ ENDIF
+ !
+ IF (.NOT. ALLOCATED(ZSVM3)) THEN
+ ALLOCATE(ZSVM3(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ZSVM3=11111.
+ ENDIF
+ IF(MAXVAL(XZHAT)/MAXVAL(XVAR) > 1.E2)THEN
+ print *,' ** Tratraj3D MAXVAL(XZHAT),MAXVAL(XVAR),*1000(KM->M) ',MAXVAL(XZHAT),MAXVAL(XVAR)
+ WHERE(XVAR(:,:,:,1,1,1) /= XSPVAL)
+ ZSVM3(:,:,:)=XVAR(:,:,:,1,1,1)*1000.
+ ELSEWHERE
+ ZSVM3(:,:,:)=XVAR(:,:,:,1,1,1)
+ ENDWHERE
+ ELSE
+ ZSVM3(:,:,:)=XVAR(:,:,:,1,1,1)
+ ENDIF
+ !
+ IF(.NOT.LFIC1)THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE .',YGROUP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ IF (JTLOOP==1) THEN
+ ! on calcule ici les grilles verticales a cause du cas du champ ALT
+ ! qui pose un probleme car il est situe sur un niveau de w
+ IIB=1+JPHEXT; IIE=SIZE(ZSVM1,1)-JPHEXT
+ IJB=1+JPHEXT; IJE=SIZE(ZSVM1,2)-JPHEXT
+ IKB=1+JPVEXT; IKE=SIZE(ZSVM1,3)-JPVEXT
+ !
+ ! Calcul des altitudes pour la grille 1 dans XZZ
+ !
+ CALL COMPCOORD_FORDIACHRO(1)
+ !
+ ENDIF
+!
+! on lit un champ supplementaire pour le tracer sur la trajectoire
+!
+ IF (LTRAJ_GROUP) THEN
+ IF ( CTRAJ_GROUP=='ALT') THEN
+ IF (.NOT. ALLOCATED(ZCHAMP)) THEN
+ ALLOCATE(ZCHAMP(SIZE(ZSVM3,1),SIZE(ZSVM3,2),SIZE(ZSVM3,3)))
+ ZCHAMP=11111.
+ ENDIF
+ IF (JTLOOP==1) ZCHAMP(:,:,:)=XZZ(:,:,:)
+ ELSE
+ CALL VERIF_GROUP(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),CTRAJ_GROUP)
+ IF(LPBREAD)THEN
+ print *,' Absence de variable CTRAJ_GROUP .. Operation impossible'
+ RETURN
+ ENDIF
+ !
+ IF (LGROUP) THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ CALL READ_DIACHRO(CFILEDIAS(JTLOOP),CLUOUTDIAS(JTLOOP),CTRAJ_GROUP)
+ ENDIF
+ !
+ IF (.NOT. ALLOCATED(ZCHAMP)) THEN
+ ALLOCATE(ZCHAMP(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ZCHAMP=11111.
+ ENDIF
+ !
+ ZCHAMP(:,:,:)=XVAR(:,:,:,1,1,1)
+ !
+ IF(.NOT.LFIC1)THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ IF(LPBREAD)THEN
+ print *,' REQUETE IMPOSSIBLE .',CTRAJ_GROUP,' N''EXISTE PAS DANS', &
+ ' L''UN DES FICHIERS '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+ ENDIF
+ END IF
+ ELSE
+ IF (.NOT. ALLOCATED(ZCHAMP)) ALLOCATE(ZCHAMP(0,0,0))
+ ENDIF
+!
+! on recherche la valeur R0 d'origine pour le point courant R
+!
+ IF (JTLOOP==1) THEN
+ ALLOCATE(ZXPOS(NPART,NBFILES+1))
+ ALLOCATE(ZYPOS(NPART,NBFILES+1))
+ ALLOCATE(ZZPOS(NPART,NBFILES+1))
+ ALLOCATE(GPART_IN(NPART,NBFILES+1))
+ GPART_IN=.TRUE.
+ IF (LTRAJ_GROUP) THEN
+ ALLOCATE(ZCHAMP_POS(NPART,NBFILES+1))
+ ELSE
+!!!Octobre 2001
+ ALLOCATE(ZCHAMP_POS(NPART,NBFILES+1))
+! ALLOCATE(ZCHAMP_POS(1,2))
+!!!Octobre 2001
+! ALLOCATE(ZCHAMP_POS(0,0))
+ END IF
+ !
+ ZXPOS(:,1)=XXPART(1:NPART)
+ ZYPOS(:,1)=XYPART(1:NPART)
+ ZZPOS(:,1)=XZPART(1:NPART)
+ !
+ DO JPART=1,NPART
+ IF (ZXPOS(JPART,1).LT.XXX(IIB,1) .OR. ZXPOS(JPART,1).GT.XXX(IIE,1) .OR. &
+ ZYPOS(JPART,1).LT.XXY(IJB,1) .OR. ZYPOS(JPART,1).GT.XXY(IJE,1) &
+ ) THEN
+ ZXPOS(JPART,1)=MIN(XXX(IIE,1),MAX(XXX(IIB,1),ZXPOS(JPART,1)))
+ ZYPOS(JPART,1)=MIN(XXY(IJE,1),MAX(XXY(IJB,1),ZYPOS(JPART,1)))
+ print *,' la particule ',JPART,' est sortie du domaine'
+ print *,'nouvelles valeurs de XXPART et XYPART:'
+ print *,'XXPART=',ZXPOS(JPART,1),'XYPART=',ZYPOS(JPART,1)
+ END IF
+ END DO
+ ENDIF
+!
+!
+ DO JPART=1,NPART
+ !
+ IF(GPART_IN(JPART,JTLOOP)) THEN
+ ! the particule is in the simulation domain
+ CALL INTERPXYZ(ZSVM1(:,:,:), &
+ ZSVM2(:,:,:), &
+ ZSVM3(:,:,:), &
+ ZCHAMP(:,:,:), &
+ ZXPOS(JPART,JTLOOP), &
+ ZYPOS(JPART,JTLOOP), &
+ ZZPOS(JPART,JTLOOP), &
+ XXX(2,1),XXY(2,1), &
+ XXDXHAT(3,1),XXDYHAT(3,1), &
+ XZZ,LTRAJ_GROUP, &
+ ZXPOS(JPART,JTLOOP+1), &
+ ZYPOS(JPART,JTLOOP+1), &
+ ZZPOS(JPART,JTLOOP+1), &
+ ZCHAMP_POS(JPART,JTLOOP) )
+ !
+ IF (ZXPOS(JPART,JTLOOP+1).LT.XXX(IIB,1) .OR. &
+ ZXPOS(JPART,JTLOOP+1).GT.XXX(IIE,1) .OR. &
+ ZYPOS(JPART,JTLOOP+1).LT.XXY(IJB,1) .OR. &
+ ZYPOS(JPART,JTLOOP+1).GT.XXY(IJE,1) &
+ ) THEN
+ ! it is the first time the particule has been gone out
+ GPART_IN(JPART,JTLOOP+1)=.FALSE.
+ ZXPOS(JPART,JTLOOP+1)=ZXPOS(JPART,JTLOOP)
+ ZYPOS(JPART,JTLOOP+1)=ZYPOS(JPART,JTLOOP)
+ ZZPOS(JPART,JTLOOP+1)=ZZPOS(JPART,JTLOOP)
+ print *,'la particule ',JPART,' est sortie du domaine apres ',JTLOOP+1,' avances'
+ ENDIF
+ ELSE
+ ! the particule is out of the simulation domain
+ GPART_IN(JPART,JTLOOP+1)=.FALSE.
+ ZXPOS(JPART,JTLOOP+1)=ZXPOS(JPART,JTLOOP)
+ ZYPOS(JPART,JTLOOP+1)=ZYPOS(JPART,JTLOOP)
+ ZZPOS(JPART,JTLOOP+1)=ZZPOS(JPART,JTLOOP)
+ ZCHAMP_POS(JPART,JTLOOP)=ZCHAMP_POS(JPART,JTLOOP-1)
+ END IF
+ ! fin de la boucle sur les particules
+ ENDDO
+!
+! fin de la boucle sur les instants de la trajectoire
+!
+ENDDO
+!
+DEALLOCATE(ZSVM1,ZSVM2,ZSVM3,ZCHAMP,GPART_IN) ! dealloc des champs
+!
+! sortie des trajectoires
+IF(LPRINT)THEN
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ ILOOP=NPART/5
+ IF(ILOOP * 5 < NPART)ILOOP=ILOOP+1
+ENDIF
+DO JTLOOP=1,NBFILES+1
+ print*,'*****************'
+ print*,'JTLOOP= ', JTLOOP
+ print*,'*****************'
+ print*,'XPOS= ',ZXPOS(1:NPART,JTLOOP)
+ print*,'YPOS= ',ZYPOS(1:NPART,JTLOOP)
+ print*,'ZPOS= ',ZZPOS(1:NPART,JTLOOP)
+ IF (LTRAJ_GROUP) print*,'CHAMPPOS= ',ZCHAMP_POS(1:NPART,JTLOOP)
+ IF(LPRINT)THEN
+ WRITE(INUM,'(A,I3)') 'LOOP= ',JTLOOP
+ DO JI=1,ILOOP
+ IF (JI==1) THEN
+ IDEB=1 ; IFIN=4
+ ELSE
+ IDEB=IFIN+1 ; IFIN=IFIN+5
+ ENDIF
+ IF (JI==ILOOP) THEN
+ IFIN=NPART
+ ENDIF
+ IF (JI==1) THEN
+ WRITE(INUM,'(A12,4(3X,E12.6))')' XPOS=',ZXPOS(IDEB:IFIN,JTLOOP)
+ ELSE
+ WRITE(INUM,'(4(E12.6,3X),E12.6)') ZXPOS(IDEB:IFIN,JTLOOP)
+ ENDIF
+ END DO
+ DO JI=1,ILOOP
+ IF (JI==1) THEN
+ IDEB=1 ; IFIN=4
+ ELSE
+ IDEB=IFIN+1 ; IFIN=IFIN+5
+ ENDIF
+ IF (JI==1) THEN
+ WRITE(INUM,'(A12,4(3X,E12.6))')' YPOS=',ZYPOS(IDEB:IFIN,JTLOOP)
+ ELSE
+ WRITE(INUM,'(4(E12.6,3X),E12.6)') ZYPOS(IDEB:IFIN,JTLOOP)
+ ENDIF
+ END DO
+ DO JI=1,ILOOP
+ IF (JI==1) THEN
+ IDEB=1 ; IFIN=4
+ ELSE
+ IDEB=IFIN+1 ; IFIN=IFIN+5
+ ENDIF
+ IF (JI==1) THEN
+ WRITE(INUM,'(A12,4(3X,E12.6))')' ZPOS=',ZZPOS(IDEB:IFIN,JTLOOP)
+ ELSE
+ WRITE(INUM,'(4(E12.6,3X),E12.6)') ZZPOS(IDEB:IFIN,JTLOOP)
+ ENDIF
+ IF (JI==ILOOP) WRITE(INUM,*)
+ END DO
+ ENDIF
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+! Visualisation des trajectoires sur XY, XZ, YZ
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!!!!!!!!!!!!JOEL!!!!!!!!!!
+!
+! Recuperation de la fenetre d'affichage courante pour restauration en fin de
+! routine
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!
+! Determination de NIINF NJINF NISUP NJSUP si non initialises par l'utilisateur
+IF(NIINF == 0 .AND. NISUP == 0 .AND. NJINF == 0 .AND. NJSUP == 0)THEN
+ CALL RESOLV_NIJINF_NIJSUP
+ENDIF
+
+!
+!!!!!! XY
+!
+YCAR(1:LEN_TRIM(YCAR))=' '
+WRITE(YCAR,'(''TRAJ **XY** '')')
+IF( LTRAJ_GROUP) THEN
+ ! car TIT_TRA3D ne trace rien sur la 1e image dans le cas LTRAJ_GROUP ...!
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ CALL PCSETC('FC','/')
+ CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+ CALL PCSETC('FC',':')
+ELSE
+ CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+ENDIF
+
+IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+IF(LCARTESIAN)THEN
+ CALL DEFENETRE
+ELSE
+ ! trace de la grille lat-lon
+ CALL GSLWSC(1.)
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+ CALL BCGRD_FORDIACHRO(2)
+ !CALL BCGRD_FORDIACHRO(1)
+ENDIF
+!
+! couleur en fct de l alt ZZPOS (15 intervalles)
+ICL=15
+CALL COLOR_FORDIACHRO(ICL+2,1)
+CALL TABCOL_FORDIACHRO
+ZMAXZ=MAXVAL(ZZPOS) ; ZMINZ=MINVAL(ZZPOS)
+ZINTZ=NINT(ZMAXZ-ZMINZ)/15
+IF(ZMINZ + ICL*ZINTZ <= ZMAXZ)ICL=ICL+1
+CALL CPSETI('NCL',ICL)
+CALL CPSETI('CLS',0)
+ZISO=ZMINZ-ZINTZ
+DO JI=1,ICL
+ CALL CPSETI('PAI',JI)
+ CALL CPSETI('AIA',JI+1)
+ CALL CPSETI('AIB',JI)
+ ZISO=ZISO+ZINTZ
+ IF(ABS(ZISO)<1.E-20)ZISO=0.
+ CALL CPSETR('CLV',ZISO)
+ CALL CPSETR('CLU',1.)
+ ZLEV(JI)=ZISO
+ !CALL GENFORMAT_FORDIACHRO(ZISO,YLLBS(JI))
+ ICOL(JI)=JI
+END DO
+!
+IF (.NOT.LCOLINE) THEN
+ print *,' LCOLINE=F: Retro-trajectoires et marqueurs noirs dans le plan XY'
+ENDIF
+!
+CALL GSLWSC(3.)
+DO JPART=1,NPART
+ CALL GSMK(4)
+ IF (.NOT.LCOLINE) THEN
+ ICOLOR=1
+ CALL GSPMCI(1)
+ ELSE
+ ICOLOR= 1+ MOD((JPART-1),16) ! boucle sur les 16 premieres couleurs
+ ! couleur du marker en fct de l alt ZZPOS
+ IF(ZZPOS(JPART,1) <ZLEV(1))THEN
+ CALL GSPMCI(1)
+ ELSEIF(ZZPOS(JPART,1) >=ZLEV(ICL))THEN
+ CALL GSPMCI(ICL+1)
+ ELSE
+ DO JI=1,ICL-1
+ IF(ZZPOS(JPART,1) >= ZLEV(JI) .AND. &
+ ZZPOS(JPART,1) < ZLEV(JI+1))THEN
+ CALL GSPMCI(JI+1)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+ CALL GSTXCI(ICOLOR)
+ CALL GSPLCI(ICOLOR)
+ CALL GPM(1,ZXPOS(JPART,1),ZYPOS(JPART,1))
+ CALL FRSTD(ZXPOS(JPART,1),ZYPOS(JPART,1))
+ CALL GSMK(3)
+ DO JTLOOP=2,NBFILES+1
+ IF (LCOLINE) THEN ! couleur du marker en fct de l alt ZZPOS
+ IF(ZZPOS(JPART,JTLOOP) <ZLEV(1))THEN
+ CALL GSPMCI(1)
+ ELSEIF(ZZPOS(JPART,JTLOOP) >=ZLEV(ICL))THEN
+ CALL GSPMCI(ICL+1)
+ ELSE
+ DO JI=1,ICL-1
+ IF(ZZPOS(JPART,JTLOOP) >= ZLEV(JI) .AND. &
+ ZZPOS(JPART,JTLOOP) < ZLEV(JI+1))THEN
+ CALL GSPMCI(JI+1)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+ CALL VECTD(ZXPOS(JPART,JTLOOP),ZYPOS(JPART,JTLOOP))
+ CALL GPM(1,ZXPOS(JPART,JTLOOP),ZYPOS(JPART,JTLOOP))
+ ENDDO
+ CALL LASTD
+ENDDO
+! Trace des valeurs de ZZPOS en legende: A revoir...
+!CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!CALL GSFAIS(1)
+!CALL LBSETI('CBL',0)
+!DO JI=1,ICL
+! YLLBS(JI)=ADJUSTL(YLLBS(JI))
+!ENDDO
+!IF(ZVR < .9)THEN
+! CALL LBLBAR_FORDIACHRO(1,ZVR+(MIN(ZVR+.2,1.)-ZVR)/10.,MIN(ZVR+.2,1.),ZVB,ZVT,ICL+1,.15,1.,ICOL,1,YLLBS,ICL,1)
+!ELSE
+! CALL LBLBAR_FORDIACHRO(1,ZVR+(1.-ZVR)/10.,1.,ZVB,ZVT,ICL+1,.15,1.,ICOL,1,YLLBS,ICL,1)
+!ENDIF
+!
+CALL FRAME
+!
+!
+IF( LTRAJ_GROUP) THEN
+ CALL GSLWSC(1.)
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ YCAR(1:LEN_TRIM(YCAR))=' '
+ WRITE(YCAR,'(''TRAJ **XY** '',A16)') CTRAJ_GROUP
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ !CALL PCSETC('FC','/')
+ !CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+ !CALL PCSETC('FC',':')
+ CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+ IF(LCARTESIAN)THEN
+ CALL DEFENETRE
+ ELSE
+ CALL BCGRD_FORDIACHRO(1)
+ ENDIF
+
+ CALL GSLWSC(3.)
+ DO JPART=1,NPART
+ CALL GSMK(4)
+ ICOLOR= 1+ MOD((JPART-1),16) ! boucle sur les 16 premieres couleurs
+ CALL GSTXCI(ICOLOR)
+ CALL GSPLCI(ICOLOR)
+ CALL GSPMCI(ICOLOR)
+ CALL GPM(1,ZXPOS(JPART,1),ZYPOS(JPART,1))
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! WRITE(YCHAMP,'(E10.5)') ZCHAMP_POS(JPART,1)
+ ! CALL PLCHHQ(ZXPOS(JPART,1),ZYPOS(JPART,1),YCHAMP,10.,0.,-1.)
+
+ WRITE(YCHAMP,CFMTRTRAJ) ZCHAMP_POS(JPART,1)
+ CALL PLCHHQ(ZXPOS(JPART,1),ZYPOS(JPART,1),YCHAMP,NSZRTRAJ,0.,-1.)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ CALL FRSTD(ZXPOS(JPART,1),ZYPOS(JPART,1))
+ CALL GSMK(3)
+ DO JTLOOP=2,NBFILES+1
+ CALL VECTD(ZXPOS(JPART,JTLOOP),ZYPOS(JPART,JTLOOP))
+ CALL GPM(1,ZXPOS(JPART,JTLOOP),ZYPOS(JPART,JTLOOP))
+ IF (JTLOOP<NBFILES+1) THEN
+ ! le dernier point pour CHAMP se rapporte a l'echeance precedente
+ ! donc il ne peut pas etre calcule et trace
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! WRITE(YCHAMP,'(E10.5)') ZCHAMP_POS(JPART,JTLOOP)
+ ! CALL PLCHHQ(ZXPOS(JPART,JTLOOP),ZYPOS(JPART,JTLOOP),YCHAMP,10.,0.,-1.)
+
+ WRITE(YCHAMP,CFMTRTRAJ) ZCHAMP_POS(JPART,JTLOOP)
+ CALL PLCHHQ(ZXPOS(JPART,JTLOOP),ZYPOS(JPART,JTLOOP),YCHAMP,NSZRTRAJ,0.,-1.)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ENDIF
+ ENDDO
+ CALL LASTD
+ ENDDO
+ !
+ ! trace de la grille lat-lon
+ CALL GSLWSC(1.)
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+ CALL BCGRD_FORDIACHRO(2)
+ CALL FRAME
+ENDIF
+!
+!!!!!! XZ
+!
+CALL GSLWSC(1.)
+CALL GSTXCI(1)
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+WRITE(YCAR,'(''TRAJ **XZ** '')')
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+!CALL PCSETC('FC','/')
+!CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+!CALL PCSETC('FC',':')
+CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+CALL SET(.1,.9,.1,.9,XXX(NIINF,1),XXX(NISUP,1), &
+XHMIN,XHMAX,1)
+CALL LABMOD('(F8.0)','(F6.0)',9,6,10,10,0,0,0)
+CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,1,5,0.,0.)
+!
+CALL GSLWSC(3.)
+DO JPART=1,NPART
+ CALL GSMK(4)
+ ICOLOR= 1+ MOD((JPART-1),16) ! boucle sur les 16 premieres couleurs
+ CALL GSPLCI(ICOLOR)
+ CALL GSTXCI(ICOLOR)
+ CALL GSPMCI(ICOLOR)
+ CALL GPM(1,ZXPOS(JPART,1),ZZPOS(JPART,1))
+ CALL FRSTD(ZXPOS(JPART,1),ZZPOS(JPART,1))
+ CALL GSMK(3)
+ DO JTLOOP=2,NBFILES+1
+ CALL VECTD(ZXPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ CALL GPM(1,ZXPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ ENDDO
+ CALL LASTD
+ENDDO
+!
+CALL FRAME
+!
+!
+IF (LTRAJ_GROUP) THEN
+ CALL GSLWSC(1.)
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ WRITE(YCAR,'(''TRAJ **XZ** '',A16)') CTRAJ_GROUP
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+! CALL PCSETC('FC','/')
+! CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+! CALL PCSETC('FC',':')
+ CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+ CALL SET(.1,.9,.1,.9,XXX(NIINF,1),XXX(NISUP,1), &
+ XHMIN,XHMAX,1)
+ CALL LABMOD('(F8.0)','(F6.0)',9,6,10,10,0,0,0)
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,1,5,0.,0.)
+ !
+ CALL GSLWSC(3.)
+ DO JPART=1,NPART
+ CALL GSMK(4)
+ ICOLOR= 1+ MOD((JPART-1),16) ! boucle sur les 16 premieres couleurs
+ CALL GSPLCI(ICOLOR)
+ CALL GSTXCI(ICOLOR)
+ CALL GSPMCI(ICOLOR)
+ CALL GPM(1,ZXPOS(JPART,1),ZZPOS(JPART,1))
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! WRITE(YCHAMP,'(E10.5)') ZCHAMP_POS(JPART,1)
+ ! CALL PLCHHQ(ZXPOS(JPART,1),ZZPOS(JPART,1),YCHAMP,10.,0.,-1.)
+
+ WRITE(YCHAMP,CFMTRTRAJ) ZCHAMP_POS(JPART,1)
+ CALL PLCHHQ(ZXPOS(JPART,1),ZZPOS(JPART,1),YCHAMP,NSZRTRAJ,0.,-1.)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ CALL FRSTD(ZXPOS(JPART,1),ZZPOS(JPART,1))
+ CALL GSMK(3)
+ DO JTLOOP=2,NBFILES+1
+ CALL VECTD(ZXPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ CALL GPM(1,ZXPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ IF (JTLOOP<NBFILES+1) THEN
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! WRITE(YCHAMP,'(E10.5)') ZCHAMP_POS(JPART,JTLOOP)
+ ! CALL PLCHHQ(ZXPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP),YCHAMP,10.,0.,-1.)
+
+ WRITE(YCHAMP,CFMTRTRAJ) ZCHAMP_POS(JPART,JTLOOP)
+ CALL PLCHHQ(ZXPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP),YCHAMP,NSZRTRAJ,0.,-1.)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ENDIF
+ ENDDO
+ CALL LASTD
+ ENDDO
+ !
+ CALL FRAME
+END IF
+!
+!!!!!! YZ
+!
+CALL GSLWSC(1.)
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+WRITE(YCAR,'(''TRAJ **YZ** '')')
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+!CALL PCSETC('FC','/')
+!CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+!CALL PCSETC('FC',':')
+CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+CALL SET(.1,.9,.1,.9,XXY(NJINF,1),XXY(NJSUP,1), &
+XHMIN,XHMAX,1)
+CALL LABMOD('(F8.0)','(F6.0)',9,6,10,10,0,0,0)
+CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,1,5,0.,0.)
+!
+CALL GSLWSC(3.)
+DO JPART=1,NPART
+ CALL GSMK(4)
+ ICOLOR= 1+ MOD((JPART-1),16) ! boucle sur les 16 premieres couleurs
+ CALL GSPLCI(ICOLOR)
+ CALL GSTXCI(ICOLOR)
+ CALL GSPMCI(ICOLOR)
+ CALL GPM(1,ZYPOS(JPART,1),ZZPOS(JPART,1))
+ CALL FRSTD(ZYPOS(JPART,1),ZZPOS(JPART,1))
+ CALL GSMK(3)
+ DO JTLOOP=2,NBFILES+1
+ CALL VECTD(ZYPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ CALL GPM(1,ZYPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ ENDDO
+ CALL LASTD
+ENDDO
+!
+CALL FRAME
+!
+IF (LTRAJ_GROUP) THEN
+ CALL GSLWSC(1.)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ WRITE(YCAR,'(''TRAJ **YZ** '',A16)') CTRAJ_GROUP
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+! CALL PCSETC('FC','/')
+! CALL PLCHHQ(.002,.98,YCAR(1:LEN_TRIM(YCAR)),.012,0.,-1.)
+! CALL PCSETC('FC',':')
+ CALL TIT_TRA3D(YCAR,YTEM1,YTEM2,ZVR)
+
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+ CALL SET(.1,.9,.1,.9,XXY(NJINF,1),XXY(NJSUP,1), &
+ XHMIN,XHMAX,1)
+ CALL LABMOD('(F8.0)','(F6.0)',9,6,10,10,0,0,0)
+ CALL GRIDAL(NCVITVXMJ,NCVITVXMN,NINT((XHMAX-XHMIN)/1000.),1,1,1,5,0.,0.)
+ !
+ CALL GSLWSC(3.)
+ DO JPART=1,NPART
+ CALL GSMK(4)
+ ICOLOR= 1+ MOD((JPART-1),16) ! boucle sur les 16 premieres couleurs
+ CALL GSPLCI(ICOLOR)
+ CALL GSTXCI(ICOLOR)
+ CALL GSPMCI(ICOLOR)
+ CALL GPM(1,ZYPOS(JPART,1),ZZPOS(JPART,1))
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! WRITE(YCHAMP,'(E10.5)') ZCHAMP_POS(JPART,1)
+ !CALL PLCHHQ(ZYPOS(JPART,1),ZZPOS(JPART,1),YCHAMP,10.,0.,-1.)
+
+ WRITE(YCHAMP,CFMTRTRAJ) ZCHAMP_POS(JPART,1)
+ CALL PLCHHQ(ZYPOS(JPART,1),ZZPOS(JPART,1),YCHAMP,NSZRTRAJ,0.,-1.)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ CALL FRSTD(ZYPOS(JPART,1),ZZPOS(JPART,1))
+ CALL GSMK(3)
+ DO JTLOOP=2,NBFILES+1
+ CALL VECTD(ZYPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ CALL GPM(1,ZYPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP))
+ IF (JTLOOP<NBFILES+1) THEN
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! WRITE(YCHAMP,'(E10.5)') ZCHAMP_POS(JPART,JTLOOP)
+ ! CALL PLCHHQ(ZYPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP),YCHAMP,10.,0.,-1.)
+
+ WRITE(YCHAMP,CFMTRTRAJ) ZCHAMP_POS(JPART,JTLOOP)
+ CALL PLCHHQ(ZYPOS(JPART,JTLOOP),ZZPOS(JPART,JTLOOP),YCHAMP,NSZRTRAJ,0.,-1.)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ENDIF
+ ENDDO
+ CALL LASTD
+ ENDDO
+ !
+ CALL FRAME
+END IF
+!
+!
+CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!
+!
+CALL GSTXCI(1)
+CALL GSPLCI(1)
+CALL GSLWSC(1.)
+CALL GSLN(1)
+DEALLOCATE(ZXPOS,ZYPOS,ZZPOS,ZCHAMP_POS) ! dealloc des champs
+NMGRID=IGRID
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+!
+END SUBROUTINE TRATRAJ3D
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/traxy.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/traxy.f90
new file mode 100644
index 0000000000000000000000000000000000000000..237316693824d4c9b2ccf28bc2698c1d220c7d72
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/traxy.f90
@@ -0,0 +1,1355 @@
+! ######spl
+ SUBROUTINE TRAXY(PTEMX,PTEMY,KLOOP,HTITX,HTITY,PTIMED,PTIMEF)
+! #############################################################
+!
+!!**** *TRAXY* -
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! modif juin 2010 : ajout de LVARNPHUSER=T et LFACTAXEX=T
+!!
+USE MODD_NMGRID
+USE MODN_PARA
+USE MODN_NCAR
+USE MODD_COORD
+USE MODD_FILES_DIACHRO
+USE MODD_TYPE_AND_LH
+USE MODD_GRID1
+!USE MODD_GRID
+USE MODD_CONF
+USE MODD_DIM1
+USE MODD_SUPER
+USE MODD_TIT
+USE MODD_NMGRID
+USE MODD_TITLE
+USE MODD_RESOLVCAR
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_PARAMETERS
+USE MODD_CTL_AXES_AND_STYL
+USE MODI_SET_DIM
+!
+IMPLICIT NONE
+!
+INTERFACE
+ SUBROUTINE IMAGE_FORDIACHRO(PTAB,KLREF,PTABINT,KNHI,KNDOT,HTEXTE)
+ CHARACTER(LEN=*) :: HTEXTE
+ REAL :: PTABINT
+ REAL,DIMENSION(:,:) :: PTAB
+ INTEGER :: KNI, KNDOT, KLREF
+ END SUBROUTINE IMAGE_FORDIACHRO
+END INTERFACE
+!
+!* 0.1 Dummy arguments
+!
+INTEGER :: KLOOP
+REAL,DIMENSION(:) :: PTEMX, PTEMY
+REAL :: PTIMED, PTIMEF
+CHARACTER(LEN=*) :: HTITX, HTITY
+!
+!* 0.2 Local variables
+!
+!
+INTEGER :: ICOMPT=0
+INTEGER,SAVE :: ISUPERDIA, ILENW, ILR
+INTEGER,SAVE :: J, IC, ID, ITOT, JMCUR
+INTEGER :: JD, JE, JF, JI, J2, JJE, JA, JM
+INTEGER :: ISUIT
+INTEGER :: INUM, IRESP, IER, IERR
+INTEGER :: ISTYL
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: ICOMPTSZ, IBRECOUV, IST
+INTEGER,DIMENSION(:,:),ALLOCATABLE,SAVE :: IRECOUV, IWORK
+!
+REAL,SAVE :: ZMINX, ZMAXX, ZMINY, ZMAXY, ZZMINY, ZZMAXY
+REAL,SAVE :: ZVL, ZVR, ZVB, ZVT, ZWL, ZWR, ZWB,ZWT
+REAL :: ZWLL,ZWRR,ZWBB,ZWTT
+INTEGER,SAVE :: IDD
+REAL,SAVE :: ZZVT, ZZT
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZTEMX2D, ZTEMY2D
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZTEM2D, ZWORK2D
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZTIMD, ZTIMF, ZWORK1D
+REAL,DIMENSION(:),ALLOCATABLE :: ZWT1, ZWT2
+REAL,SAVE :: ZW, ZE36, ZLWSC
+REAL :: ZXPOSTITT1, ZXYPOSTITT1
+REAL :: ZXPOSTITT2, ZXYPOSTITT2
+REAL :: ZXPOSTITT3, ZXYPOSTITT3
+REAL :: ZXPOSTITB1, ZXYPOSTITB1
+REAL :: ZXPOSTITB2, ZXYPOSTITB2
+REAL :: ZXPOSTITB3, ZXYPOSTITB3
+REAL :: ZCONSTIM
+!INTEGER :: ICLIP
+!REAL,DIMENSION(4) :: ZCL
+!
+CHARACTER(LEN=80) :: YTEM, YCAR
+CHARACTER(LEN=40),SAVE :: YTITY
+CHARACTER(LEN=40),DIMENSION(:),ALLOCATABLE,SAVE :: YTITGAL
+CHARACTER(LEN=1) :: YC1
+CHARACTER(LEN=2) :: YC2, YTEXT
+CHARACTER(LEN=3) :: YC3
+!
+LOGICAL,SAVE :: GOK
+LOGICAL :: GCOLINE
+!
+!-------------------------------------------------------------------------------
+ZZVT=0.; ZZT=0.
+GOK=.FALSE.
+ZE36=1.E36
+ICOMPT=ICOMPT+1
+IF(NVERBIA > 0)THEN
+print *,'TRAXY ICOMPT ',ICOMPT
+print *,'TRAXY LCONT, LRELIEF',LCONT, LRELIEF
+ENDIF
+!print *,' PTEMX ',PTEMX
+!print *,' PTEMY ',PTEMY
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF(LPRINT)THEN
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ WRITE(INUM,'(''TRAXY '',''G:'',A16,'' P:'',A25,'' TD:'',F8.0,''s'','' TF:'', &
+& F8.0,''s'')')CGROUP,CTITGAL(1:25),PTIMED,PTIMEF
+ WRITE(INUM,'(''TITX:'',A25,'' TITY:'',A25,'' NBVAL:'',I8)')HTITX,HTITY,SIZE(PTEMX)
+ IF(LPLUS .OR.LMINUS)THEN
+ WRITE(INUM,'(A70)')CTITB3
+ ELSE
+ WRITE(INUM,'(A40)')CTITGAL
+ ENDIF
+! JUin 2001 Ecriture des dates (Demande G.Jaubert ) si LPRDAT=T
+ IF(LPRDAT)THEN
+ IF(.NOT.ALLOCATED(XPRDAT))THEN
+ print *,'**TRAXY XPRDAT NON ALLOUE.Dates non ecrites ds FICVAL .Prevenir J.Duron'
+ ELSE
+ if(nverbia >0)then
+ print *,' ** traxy AV toute ecriture et avec LPRDAT=T'
+ endif
+ WRITE(INUM,'(1X,75(1H*))')
+ WRITE(INUM,'(1X,'' Dates courante * modele * experience * segment'')')
+ WRITE(INUM,'(1X,'' J An M J Sec. * An M J Sec. * An M J Sec. * An M J Sec.'')')
+ WRITE(INUM,'(1X,75(1H*))')
+ if(nverbia >0)then
+ print *,' ** traxy AP ecriture entete dates et avec LPRDAT=T'
+ endif
+ DO J=1,SIZE(XPRDAT,2)
+ if(nverbia >0)then
+ print *,' ** ecriture dates et avec LPRDAT=T j SIZE(XPRDAT,2) ',J,SIZE(XPRDAT,2)
+ endif
+ WRITE(INUM,'(1X,I3,1X,3(I4,I3,I3,I6,'' *''),I4,I3,I3,I6)')J,INT(XPRDAT(:,J))
+ ENDDO
+ if(nverbia >0)then
+ print *,' ** traxy AP ecriture dates et avec LPRDAT=T'
+ endif
+ ENDIF
+ ENDIF
+! JUin 2001 Ecriture des dates
+!!Avril 2002 + lat et lon
+ IF(LCV .AND. .NOT.LCARTESIAN)THEN
+ WRITE(INUM,'(1X,78(1H*))')
+ WRITE(INUM,'(16X,''X'',19X,''Y'',16X,''LAT'',16X,''LON'')')
+ WRITE(INUM,'(1X,78(1H*))')
+ DO J=1,SIZE(PTEMX)
+ WRITE(INUM,'(I5,4X,E15.8,4X,E15.8,3X,E15.7,3X,E15.7)')J,PTEMX(J),PTEMY(J),&
+ XLATCV(J),XLONCV(J)
+ ENDDO
+ ELSE
+ WRITE(INUM,'(1X,45(1H*))')
+ WRITE(INUM,'(16X,''X'',19X,''Y'')')
+ WRITE(INUM,'(1X,45(1H*))')
+ DO J=1,SIZE(PTEMX)
+ WRITE(INUM,'(I5,4X,E15.8,4X,E15.8)')J,PTEMX(J),PTEMY(J)
+ ENDDO
+ ENDIF
+ if(nverbia >0)then
+ print *,' ** traxy AP ecriture coordonnees et avec LPRDAT=T ou F'
+ endif
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+IF(ICOMPT == 1)THEN
+
+ IF((CGROUPS(NSUPERDIA) == 'ZSBIS' .OR. CGROUPS(NSUPERDIA) == 'ZS') .AND. &
+ NSUPERDIA > 1 .AND. .NOT.(LCH.AND.LCV))THEN
+ NSUPERDIA=NSUPERDIA-1
+ ISUPERDIA=NSUPERDIA
+ LRELIEF=.TRUE.
+ ELSE
+ ISUPERDIA=NSUPERDIA
+ LRELIEF=.FALSE.
+ ENDIF
+! IF(LMINUS .OR. LPLUS)ISUPERDIA=ISUPERDIA-1
+ IF(LMINUS .OR. LPLUS)ISUPERDIA=1
+! Cas LCH+LCV -> PH sur CV
+ IF(NHISTORY(KLOOP) == 3)THEN
+ DO J=1,MAX(1,KLOOP-1)
+ IF(NHISTORY(J) == 1)THEN
+ ISUPERDIA=1
+ ENDIF
+ ENDDO
+ ENDIF
+ if(nverbia > 0)then
+ print *,' TRAXY ISUPERDIA ',ISUPERDIA
+ endif
+ ALLOCATE(ZTEMX2D(SIZE(PTEMX),ISUPERDIA))
+ ALLOCATE(ZTEMY2D(SIZE(PTEMY),ISUPERDIA))
+ ALLOCATE(ICOMPTSZ(ISUPERDIA))
+ ALLOCATE(IBRECOUV(ISUPERDIA))
+ ALLOCATE(IST(ISUPERDIA))
+ ALLOCATE(IRECOUV(NBRECOUV*2,ISUPERDIA))
+ ALLOCATE(ZTIMD(ISUPERDIA))
+ ALLOCATE(ZTIMF(ISUPERDIA))
+ ALLOCATE(YTITGAL(ISUPERDIA))
+ ZTEMX2D(:,ICOMPT)=PTEMX
+ ZTEMY2D(:,ICOMPT)=PTEMY
+ ICOMPTSZ(ICOMPT)=SIZE(PTEMX)
+ IBRECOUV(ICOMPT)=NBRECOUV
+ IST(ICOMPT)=NLOOPN
+ DO J=1,NBRECOUV
+ IRECOUV(J*2-1,ICOMPT)=NRECOUV(J*2-1)
+ IRECOUV(J*2,ICOMPT)=NRECOUV(J*2)
+ ENDDO
+ IF(NBRECOUV == 1 .AND. PTIMED == PTIMEF)THEN
+ IRECOUV(1,ICOMPT)=1
+ IRECOUV(2,ICOMPT)=SIZE(PTEMX)
+ ENDIF
+ ZTIMD(ICOMPT)=PTIMED
+ ZTIMF(ICOMPT)=PTIMEF
+ YTITGAL(ICOMPT)=CTITGAL
+ YTITGAL(ICOMPT)=ADJUSTL(YTITGAL(ICOMPT))
+ YTITY=HTITY
+ YTITY=ADJUSTL(YTITY)
+
+ELSE
+
+ ILENW=SIZE(PTEMX)
+
+ IF(ILENW < MAXVAL(ICOMPTSZ(1:ICOMPT-1)))THEN
+ ZTEMX2D(:,ICOMPT)=PTEMX
+ ZTEMY2D(:,ICOMPT)=PTEMY
+ ELSE
+ ALLOCATE(ZTEM2D(SIZE(PTEMX),ISUPERDIA))
+ ALLOCATE(ZWORK2D(SIZE(PTEMX),ISUPERDIA))
+ DO J=1,ICOMPT-1
+ ZTEM2D(1:ICOMPTSZ(J),J)=ZTEMX2D(1:ICOMPTSZ(J),J)
+ ZWORK2D(1:ICOMPTSZ(J),J)=ZTEMY2D(1:ICOMPTSZ(J),J)
+ ENDDO
+ ZTEM2D(:,ICOMPT)=PTEMX
+ ZWORK2D(:,ICOMPT)=PTEMY
+ DEALLOCATE(ZTEMX2D,ZTEMY2D)
+ ALLOCATE(ZTEMX2D(SIZE(ZTEM2D,1),SIZE(ZTEM2D,2)))
+ ALLOCATE(ZTEMY2D(SIZE(ZWORK2D,1),SIZE(ZWORK2D,2)))
+ ZTEMX2D(:,:)= ZTEM2D(:,:)
+ ZTEMY2D(:,:)= ZWORK2D(:,:)
+ DEALLOCATE(ZTEM2D,ZWORK2D)
+ ENDIF
+
+ ICOMPTSZ(ICOMPT)=SIZE(PTEMX)
+ ZTIMD(ICOMPT)=PTIMED
+ ZTIMF(ICOMPT)=PTIMEF
+ YTITGAL(ICOMPT)=CTITGAL
+ YTITGAL(ICOMPT)=ADJUSTL(YTITGAL(ICOMPT))
+ HTITY=ADJUSTL(HTITY)
+ IF(HTITY /= YTITY)THEN
+ YTITGAL(ICOMPT)=ADJUSTL(ADJUSTR(YTITGAL(ICOMPT))//' '//HTITY)
+ ENDIF
+ IBRECOUV(ICOMPT)=NBRECOUV
+ IST(ICOMPT)=NLOOPN
+ ILR=NBRECOUV*2
+
+ IF(ILR <= MAXVAL(IBRECOUV(1:ICOMPT-1))*2)THEN
+ DO J=1,ILR
+ IRECOUV(J,ICOMPT)=NRECOUV(J)
+ ENDDO
+ IF(NBRECOUV == 1 .AND. PTIMED == PTIMEF)THEN
+ IRECOUV(1,ICOMPT)=1
+ IRECOUV(2,ICOMPT)=SIZE(PTEMX)
+ ENDIF
+ ELSE
+ ALLOCATE(IWORK(ILR,ISUPERDIA))
+ DO J=1,ICOMPT-1
+ IWORK(1:IBRECOUV(J)*2,J)=IRECOUV(1:IBRECOUV(J)*2,J)
+ ENDDO
+ IWORK(1:ILR,ICOMPT)=NRECOUV(1:ILR)
+ IF(NBRECOUV == 1 .AND. PTIMED == PTIMEF)THEN
+ IWORK(1,ICOMPT)=1
+ IWORK(2,ICOMPT)=SIZE(PTEMX)
+ ENDIF
+ DEALLOCATE(IRECOUV)
+ ALLOCATE(IRECOUV(ILR,ISUPERDIA))
+ IRECOUV(:,:)=IWORK(:,:)
+ DEALLOCATE(IWORK)
+ ENDIF
+
+ENDIF
+
+!----------------------------------------------------------------------------
+
+IF(ICOMPT < ISUPERDIA)THEN
+
+ RETURN
+
+ELSE
+! print *,' ICOMPT ISUPERDIA ',ICOMPT,ISUPERDIA
+! print *,' IBRECOUV, IRECOUV ',IBRECOUV,IRECOUV
+ ITOT=0
+ DO J=1,ICOMPT
+ ITOT=ITOT+ICOMPTSZ(J)
+ ENDDO
+! print *,' ITOT ',ITOT
+ ALLOCATE(ZWORK1D(ITOT))
+ ID=0
+ DO J=1,ICOMPT
+ IC=ICOMPTSZ(J)
+ IF(LXT .OR. LYT .OR. LZT)THEN
+ ZCONSTIM=0
+ IF(MOD(J,8) == 1)THEN
+ ZCONSTIM=XFT_ADTIM1
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.1 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM1 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 2)THEN
+ ZCONSTIM=XFT_ADTIM2
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.2 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM2 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 3)THEN
+ ZCONSTIM=XFT_ADTIM3
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.3 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM3 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 4)THEN
+ ZCONSTIM=XFT_ADTIM4
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.4 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM4 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 5)THEN
+ ZCONSTIM=XFT_ADTIM5
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.5 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM5 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 6)THEN
+ ZCONSTIM=XFT_ADTIM6
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.6 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM6 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 7)THEN
+ ZCONSTIM=XFT_ADTIM7
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.7 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM7 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 0)THEN
+ ZCONSTIM=XFT_ADTIM8
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.8 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM8 a zero'
+ ENDIF
+ ENDIF
+ ZTEMX2D(1:IC,J)=ZTEMX2D(1:IC,J)+ZCONSTIM
+ ENDIF
+ ZWORK1D(ID+1:ID+IC)=ZTEMX2D(1:IC,J)
+ ID=IC+ID
+ ENDDO
+! Mai 2000
+ IF(LSPVALT)THEN
+ WHERE (ZWORK1D == XSPVALT)
+ ZWORK1D = ZE36
+ ENDWHERE
+ DO J=1,SIZE(ZWORK1D)
+ IF(ZWORK1D(J) /= ZE36)THEN
+ ZMINX=ZWORK1D(J)
+ ZMAXX=ZWORK1D(J)
+ EXIT
+ ENDIF
+ ENDDO
+ DO J=1,SIZE(ZWORK1D)
+ IF(ZWORK1D(J) /= ZE36)THEN
+ ZMINX=MIN(ZMINX,ZWORK1D(J))
+ ZMAXX=MAX(ZMAXX,ZWORK1D(J))
+ ENDIF
+ ENDDO
+ print *,' ZMINX,ZMAXX trouves, (eventuelles valeurs speciales non comprises ',ZMINX,ZMAXX
+
+ ELSE
+ ZMINX=MINVAL(ZWORK1D)
+ ZMAXX=MAXVAL(ZWORK1D)
+ print *,' ZMINX,ZMAXX trouves, (eventuelles valeurs speciales comprises ',ZMINX,ZMAXX
+ ENDIF
+! CALL VALMNMX(ZMINX,ZMAXX)
+!print *,' ap VALMNMX ',ZMINX,ZMAXX
+ IF(ZMAXX - ZMINX == 0)THEN
+ ZMAXX=ZMAXX+1.
+ ZMINX=ZMINX-1.
+ ENDIF
+ print *,' ZMINX,ZMAXX utilisees ',ZMINX,ZMAXX
+
+ ID=0
+ DO J=1,ICOMPT
+ IC=ICOMPTSZ(J)
+ ZWORK1D(ID+1:ID+IC)=ZTEMY2D(1:IC,J)
+ ID=IC+ID
+ ENDDO
+! Mai 2000
+ IF(LSPVALT)THEN
+ WHERE (ZWORK1D == XSPVALT)
+ ZWORK1D = ZE36
+ ENDWHERE
+ DO J=1,SIZE(ZWORK1D)
+ IF(ZWORK1D(J) /= ZE36)THEN
+ ZMINY=ZWORK1D(J)
+ ZMAXY=ZWORK1D(J)
+ EXIT
+ ENDIF
+ ENDDO
+ DO J=1,SIZE(ZWORK1D)
+ IF(ZWORK1D(J) /= ZE36)THEN
+ ZMINY=MIN(ZMINY,ZWORK1D(J))
+ ZMAXY=MAX(ZMAXY,ZWORK1D(J))
+ ENDIF
+ ENDDO
+ print *,' ZMINY,ZMAXY trouves, (eventuelles valeurs speciales non comprises ',ZMINY,ZMAXY
+ ELSE
+ ZMINY=MINVAL(ZWORK1D)
+ ZMAXY=MAXVAL(ZWORK1D)
+ print *,' TRAXY : Bornes en Y trouvees : ',ZMINY,ZMAXY
+ print *,' (Eventuelles valeurs speciales : XSPVALT(ou XSPVAL pour trace instantane) ou 1.E36 comprises <--> relief)'
+ print *,' (Actuellement les valeurs XSPVALT(ou XSPVAL pour trace instantane) sont tracees, pas les valeurs 1.E36)'
+ print *,' Pour les supprimer, affecter sa valeur a XSPVALT (ou XSPVAL) etfournir LSPVALT=T '
+ ENDIF
+ ZZMINY=1.E35
+ ZZMAXY=-1.E35
+ JA=0
+ DO J=1,SIZE(ZWORK1D,1)
+! IF(ZWORK1D(J) /= 999. .AND. ZWORK1D(J) /= 1.E36)THEN
+! Mai 2000
+ IF(LSPVALT)THEN
+ IF(ZWORK1D(J) /= XSPVALT .AND. ZWORK1D(J) /= 1.E36)THEN
+ ZZMINY=MIN(ZZMINY,ZWORK1D(J))
+ ZZMAXY=MAX(ZZMAXY,ZWORK1D(J))
+ ELSE
+ JA=JA+1
+ ENDIF
+ ELSE
+ IF(ZWORK1D(J) /= XSPVAL .AND. ZWORK1D(J) /= 1.E36)THEN
+ ZZMINY=MIN(ZZMINY,ZWORK1D(J))
+ ZZMAXY=MAX(ZZMAXY,ZWORK1D(J))
+ ELSE
+ JA=JA+1
+ ENDIF
+ ENDIF
+ ENDDO
+ IF(ZZMINY /= 1.E35 .AND. ZZMAXY /= -1.E35 .AND. JA>0)THEN
+ print *,' Bornes en Y trouvees : ',ZZMINY,ZZMAXY
+ print *,' (Abstraction faite des valeurs speciales)'
+ ENDIF
+! CALL VALMNMX(ZMINY,ZMAXY)
+ IF(ZMAXY - ZMINY == 0)THEN
+ ZMAXY=ZMAXY+1.
+ ZMINY=ZMINY-1.
+ ENDIF
+ DEALLOCATE(ZWORK1D)
+! print *,' TRAXY ZMINX,ZMAXX,ZMINY,ZMAXY ',ZMINX,ZMAXX,ZMINY,ZMAXY
+ENDIF
+!IF(.NOT.LCONT .AND. .NOT.LRELIEF)THEN
+IF(XVARMAX-XVARMIN >0)THEN
+ print *,' Bornes en Y fournies : ',XVARMIN,XVARMAX
+ print *,' Si elles ne conviennent pas, donnez de nouvelles valeurs dans XVARMIN et XVARMAX '
+ print *,' (Retour au calcul automatique des bornes avec XVARMIN=0 et XVARMAX=0)'
+ ZMINY=XVARMIN; ZMAXY=XVARMAX
+ELSE
+ print *,' Vous pouvez fournir des bornes en Y dans XVARMIN et XVARMAX'
+ print *,' (Retour au calcul automatique des bornes avec XVARMIN=0 et XVARMAX=0)'
+ENDIF
+!ENDIF
+
+
+! IF(LRELIEF .OR. LCONT)THEN
+IF((LCONT .OR. LRELIEF .OR.(LRELIEF .AND. LCONT)) .AND. LXYDIA)THEN
+ if(nverbia > 0)then
+ print *,'passage ici NIMAX ',nimax,' LCARTESIAN ',LCARTESIAN
+ print *,'passage ici NIINF,NJINF,NISUP,NJSUP ',NIINF,NJINF,NISUP,NJSUP
+ endif
+ IF(NIMAX == 0)THEN
+ IF (NBFILES == 1)THEN
+ print *,' Impossibilite de tracer les continents; pas d''entete dans le fichier'
+ IF(LVPTXYUSER)THEN
+ CALL SET(XVPTXYL,XVPTXYR,XVPTXYB,XVPTXYT,ZMINX,ZMAXX,ZMINY,ZMAXY,1)
+ ELSE
+ CALL SET(.13,.9,.1,.9,ZMINX,ZMAXX,ZMINY,ZMAXY,1)
+ ENDIF
+ ELSE
+ DO J=1,NBFILES
+ IF(NUMFILES(J)==NUMFILECUR)THEN
+ JMCUR=J
+ if(nverbia > 0)then
+ print *,' traxy J JMCUR ',J,JMCUR
+ endif
+ EXIT
+ ENDIF
+ ENDDO
+ DO J=1,NBFILES
+ IF(NUMFILES(J)==NUMFILECUR)THEN
+ CYCLE
+ ELSE
+ JM=J
+ if(nverbia > 0 )THEN
+ print *,' traxy JM,CFILEDIAS(JM) ',JM,CFILEDIAS(JM)
+ ENDIF
+ CALL READ_FILEHEAD(JM,CFILEDIAS(JM),CLUOUTDIAS(JM))
+ IF(NIMAX /= 0)THEN
+ IF(NIINF == 0 .AND. NJINF == 0 .AND. NISUP == 0 .AND. &
+ NJSUP == 0)THEN
+ CALL SET_DIM(CFILEDIAS(JM),CLUOUTDIAS(JM),NIINF,NISUP, &
+ NJINF,NJSUP,NIMAX,NJMAX,NKMAX)
+ print *,' NIINF,NJINF,NISUP,NJSUP non definis --> '
+ print *,' On prend la totalite du domaine horizontal sans les points de garde'
+ NIINF=NIINF+JPHEXT
+ NISUP=NISUP-JPHEXT
+ NJINF=NJINF+JPHEXT
+ NJSUP=NJSUP-JPHEXT
+ IF(NVERBIA > 0)THEN
+ print *,NIINF,NJINF,NISUP,NJSUP
+ ENDIF
+ ENDIF
+ CALL COMPCOORD_FORDIACHRO(0)
+ NMGRID=1
+ CALL BCGRD_FORDIACHRO(2)
+ IF(LRELIEF)THEN
+ ALLOCATE(ZTEM2D(1:NISUP-NIINF+1,1:NJSUP-NJINF+1))
+ ZTEM2D(:,:)=XXZS(NIINF:NISUP,NJINF:NJSUP,1)
+ YTEXT=' '
+ LCHXY=.TRUE.
+ CTYPHOR='K'
+ GCOLINE=LCOLINE
+ LCOLINE=.FALSE.
+ CALL IMAGE_FORDIACHRO(ZTEM2D,1,XDIAINT,NHI,NDOT,YTEXT)
+ CALL SFLUSH
+ LCOLINE=GCOLINE
+! CALL GSTXCI(1)
+! CALL GSPLCI(1)
+ IF(LDOMAIN)THEN
+ CALL GSLWSC(XLWDOMAIN)
+ CALL FRSTPT(XXX(NDOMAINL,NMGRID),XXY(NDOMAINB,NMGRID))
+ CALL VECTOR(XXX(NDOMAINR,NMGRID),XXY(NDOMAINB,NMGRID))
+ CALL VECTOR(XXX(NDOMAINR,NMGRID),XXY(NDOMAINT,NMGRID))
+ CALL VECTOR(XXX(NDOMAINL,NMGRID),XXY(NDOMAINT,NMGRID))
+ CALL VECTOR(XXX(NDOMAINL,NMGRID),XXY(NDOMAINB,NMGRID))
+ ENDIF
+ DEALLOCATE(ZTEM2D)
+ LRELIEF=.FALSE.
+ if(nverbia > 0)THEN
+ print *,' TRAXY NSUPERDIA AP TRACE RELIEF ',NSUPERDIA
+ endif
+ CGROUPS(NSUPERDIA+1)(1:LEN(CGROUPS(NSUPERDIA+1)))=' '
+ ENDIF
+ if(nverbia > 0 )THEN
+ print *,' traxy JMCUR,CFILEDIAS(JMCUR) ',JMCUR,CFILEDIAS(JMCUR)
+ endif
+ CALL READ_FILEHEAD(JMCUR,CFILEDIAS(JMCUR),CLUOUTDIAS(JMCUR))
+ GOK=.TRUE.
+ EXIT
+ ELSE
+ CYCLE
+ ENDIF
+ ENDIF
+ ENDDO
+ IF(.NOT.GOK)THEN
+ IF(NIMAX == 0)THEN
+ print *,' Impossibilite de tracer les continents; pas d''entete dans le fichier'
+ IF(LVPTXYUSER)THEN
+ CALL SET(XVPTXYL,XVPTXYR,XVPTXYB,XVPTXYT,ZMINX,ZMAXX,ZMINY,ZMAXY,1)
+ ELSE
+ CALL SET(.13,.9,.1,.9,ZMINX,ZMAXX,ZMINY,ZMAXY,1)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE
+ if(nverbia > 0)then
+ print *,' ** traxy Cas ou NIMAX =/= 0'
+ endif
+ IF(NIINF == 0 .AND. NJINF == 0 .AND. NISUP == 0 .AND. &
+ NJSUP == 0)THEN
+ DO J=1,NBFILES
+ IF(NUMFILES(J)==NUMFILECUR)THEN
+ JMCUR=J
+ if(nverbia > 0)then
+ print *,' traxy J JMCUR ',J,JMCUR
+ endif
+ EXIT
+ ENDIF
+ ENDDO
+ CALL SET_DIM(CFILEDIAS(JMCUR),CLUOUTDIAS(JMCUR),NIINF,NISUP, &
+ NJINF,NJSUP,NIMAX,NJMAX,NKMAX)
+ print *,' NIINF,NJINF,NISUP,NJSUP non definis --> '
+ print *,' On prend la totalite du domaine horizontal sans les points de garde'
+ NIINF=NIINF+JPHEXT
+ NISUP=NISUP-JPHEXT
+ NJINF=NJINF+JPHEXT
+ NJSUP=NJSUP-JPHEXT
+ IF(NVERBIA > 0)THEN
+ print *,NIINF,NJINF,NISUP,NJSUP
+ ENDIF
+ CALL COMPCOORD_FORDIACHRO(0)
+ ENDIF
+ NMGRID=1
+ CALL BCGRD_FORDIACHRO(2)
+ GOK=.TRUE.
+ IF(LRELIEF)THEN
+ ALLOCATE(ZTEM2D(1:NISUP-NIINF+1,1:NJSUP-NJINF+1))
+ ZTEM2D(:,:)=XXZS(NIINF:NISUP,NJINF:NJSUP,1)
+ YTEXT=' '
+ LCHXY=.TRUE.
+ GCOLINE=LCOLINE
+ LCOLINE=.FALSE.
+ CTYPHOR='K'
+ CALL IMAGE_FORDIACHRO(ZTEM2D,1,XDIAINT,NHI,NDOT,YTEXT)
+ CALL SFLUSH
+ LCOLINE=GCOLINE
+! CALL GSTXCI(1)
+! CALL GSPLCI(1)
+ IF(LDOMAIN)THEN
+ CALL GSLWSC(XLWDOMAIN)
+ CALL FRSTPT(XXX(NDOMAINL,NMGRID),XXY(NDOMAINB,NMGRID))
+ CALL VECTOR(XXX(NDOMAINR,NMGRID),XXY(NDOMAINB,NMGRID))
+ CALL VECTOR(XXX(NDOMAINR,NMGRID),XXY(NDOMAINT,NMGRID))
+ CALL VECTOR(XXX(NDOMAINL,NMGRID),XXY(NDOMAINT,NMGRID))
+ CALL VECTOR(XXX(NDOMAINL,NMGRID),XXY(NDOMAINB,NMGRID))
+ ENDIF
+ DEALLOCATE(ZTEM2D)
+ LRELIEF=.FALSE.
+ if(nverbia > 0)THEN
+ print *,' TRAXY NSUPERDIA AP TRACE RELIEF ',NSUPERDIA
+ endif
+ CGROUPS(NSUPERDIA+1)(1:LEN(CGROUPS(NSUPERDIA+1)))=' '
+ ENDIF
+ ENDIF
+ELSE
+! Pour ajuster le titre en haut au dessus de la + gde fenetre en cas de
+! superposition CV et PH=CV+K
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ ZZVT=ZVT
+ IF(KLOOP > 1 .AND. NHISTORY(KLOOP) == 3)THEN
+ DO J=1,MAX(1,KLOOP-1)
+ IF(NHISTORY(J) == 1)THEN
+ IF(LVPTXYUSER)THEN
+ CALL SET(ZVL,ZVR,XVPTXYB,XVPTXYT,ZMINX,ZMAXX,ZMINY,ZMAXY,1)
+ ELSE
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZMINX,ZMAXX,ZMINY,ZMAXY,1)
+ ENDIF
+ if(nverbia > 0)then
+ print *,' **traxy fentere recuperee ZVL,ZVR,ZVB,ZVT ',ZVL,ZVR,ZVB,ZVT
+ endif
+ EXIT
+ ENDIF
+ IF(LVPTXYUSER)THEN
+ CALL SET(XVPTXYL,XVPTXYR,XVPTXYB,XVPTXYT,ZMINX,ZMAXX,ZMINY,ZMAXY,1)
+ ELSE
+ CALL SET(.13,.9,.1,.9,ZMINX,ZMAXX,ZMINY,ZMAXY,1)
+ ENDIF
+ ENDDO
+ ELSE
+ IF(LVPTXYUSER)THEN
+ CALL SET(XVPTXYL,XVPTXYR,XVPTXYB,XVPTXYT,ZMINX,ZMAXX,ZMINY,ZMAXY,1)
+ ELSE
+ IF(LXYWINCUR)THEN
+!!!PROVI
+ ELSE
+ CALL SET(.13,.9,.1,.9,ZMINX,ZMAXX,ZMINY,ZMAXY,1)
+ ENDIF
+!!!PROVI
+ ENDIF
+ ENDIF
+ENDIF
+
+CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+XCURVPTL=ZVL;XCURVPTR=ZVR;XCURVPTB=ZVB;XCURVPTT=ZVT
+
+CALL FORMATXY(ZWL,ZWR,ZWB,ZWT)
+IF(LCOLINE)CALL TABCOL_FORDIACHRO
+CALL AGSETF('SET.',4.)
+CALL AGSETF('BAC.',4.)
+CALL AGSETF('FRA.',2.)
+
+CALL GSCLIP(1)
+
+
+DO J = 1,ISUPERDIA
+!DO J = 1,NSUPERDIA
+
+ ALLOCATE(ZWT1(ICOMPTSZ(J)),ZWT2(ICOMPTSZ(J)))
+ ZWT1(:)=ZTEMX2D(:,J)
+ ZWT2(:)=ZTEMY2D(:,J)
+! Mai 2000
+ IF(LSPVALT)THEN
+ WHERE(ZWT1 == XSPVALT)
+ ZWT1=ZE36
+ ENDWHERE
+ WHERE(ZWT2 == XSPVALT)
+ ZWT2=ZE36
+ ENDWHERE
+ ENDIF
+
+ CALL GSLN(1)
+ CALL GSLWSC(1.)
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+ CALL GSCLIP(0)
+
+!!!!!!JD Avril 2009
+ IF(LXYNVARTOP)THEN
+!!!!!!JD Avril 2009
+! G.TANGUY Juin 2010
+ IF(LVARNPHUSER)THEN
+ IF(J == 1)THEN
+ IF(CVARNPH1 == 'WHITE' .OR. CVARNPH1 == 'white')THEN
+ YTITGAL(1)(1:LEN_TRIM(YTITGAL(1)))=' '
+ ELSEIF(CVARNPH1 /= ' ')THEN
+ YTITGAL(1)(1:LEN_TRIM(YTITGAL(1)))=' '
+ YTITGAL(1)=ADJUSTL(CVARNPH1)
+ YTITGAL(1)=ADJUSTL(YTITGAL(1))
+ ENDIF
+ ELSEIF(J == 2)THEN
+ IF(CVARNPH2 == 'WHITE' .OR. CVARNPH2 == 'white')THEN
+ YTITGAL(2)(1:LEN_TRIM(YTITGAL(2)))=' '
+ print *,' NSUPER=2 YTITGAL(2) ',YTITGAL(2)
+ ELSEIF(CVARNPH2 /= ' ')THEN
+ YTITGAL(2)(1:LEN_TRIM(YTITGAL(2)))=' '
+ YTITGAL(2)=CVARNPH2
+ YTITGAL(2)=ADJUSTL(YTITGAL(2))
+ ENDIF
+ ELSEIF(J == 3)THEN
+ IF(CVARNPH3 == 'WHITE' .OR. CVARNPH3 == 'white')THEN
+ YTITGAL(3)(1:LEN_TRIM(YTITGAL(3)))=' '
+ ELSEIF(CVARNPH3 /= ' ')THEN
+ YTITGAL(3)(1:LEN_TRIM(YTITGAL(3)))=' '
+ YTITGAL(3)=CVARNPH3
+ YTITGAL(3)=ADJUSTL(YTITGAL(3))
+ ENDIF
+ ELSEIF(J == 4)THEN
+ IF(CVARNPH4 == 'WHITE' .OR. CVARNPH4 == 'white')THEN
+ YTITGAL(4)(1:LEN_TRIM(YTITGAL(4)))=' '
+ ELSEIF(CVARNPH4 /= ' ')THEN
+ YTITGAL(4)(1:LEN_TRIM(YTITGAL(4)))=' '
+ YTITGAL(4)=CVARNPH4
+ YTITGAL(4)=ADJUSTL(YTITGAL(4))
+ ENDIF
+ ELSEIF(J == 5)THEN
+ IF(CVARNPH5 == 'WHITE' .OR. CVARNPH5 == 'white')THEN
+ YTITGAL(5)(1:LEN_TRIM(YTITGAL(5)))=' '
+ ELSEIF(CVARNPH5 /= ' ')THEN
+ YTITGAL(5)(1:LEN_TRIM(YTITGAL(5)))=' '
+ YTITGAL(5)=CVARNPH5
+ YTITGAL(5)=ADJUSTL(YTITGAL(5))
+ ENDIF
+ ELSEIF(J == 6)THEN
+ IF(CVARNPH6 == 'WHITE' .OR. CVARNPH6 == 'white')THEN
+ YTITGAL(6)(1:LEN_TRIM(YTITGAL(6)))=' '
+ ELSEIF(CVARNPH6 /= ' ')THEN
+ YTITGAL(6)(1:LEN_TRIM(YTITGAL(6)))=' '
+ YTITGAL(6)=CVARNPH6
+ YTITGAL(6)=ADJUSTL(YTITGAL(6))
+ ENDIF
+ ELSEIF(J == 7)THEN
+ IF(CVARNPH7 == 'WHITE' .OR. CVARNPH7 == 'white')THEN
+ YTITGAL(7)(1:LEN_TRIM(YTITGAL(7)))=' '
+ ELSEIF(CVARNPV7 /= ' ')THEN
+ YTITGAL(7)(1:LEN_TRIM(YTITGAL(7)))=' '
+ YTITGAL(7)=CVARNPH7
+ YTITGAL(7)=ADJUSTL(YTITGAL(7))
+ ENDIF
+ ELSEIF(J == 8)THEN
+ IF(CVARNPH8 == 'WHITE' .OR. CVARNPH8 == 'white')THEN
+ YTITGAL(8)(1:LEN_TRIM(YTITGAL(8)))=' '
+ ELSEIF(CVARNPV8 /= ' ')THEN
+ YTITGAL(8)(1:LEN_TRIM(YTITGAL(8)))=' '
+ YTITGAL(8)=CVARNPH8
+ YTITGAL(8)=ADJUSTL(YTITGAL(8))
+ ENDIF
+ ENDIF
+ ENDIF
+! fin G.TANGUY juin 2010
+ SELECT CASE(CTYPE)
+
+ CASE ('CART','MASK','SPXY')
+ IF(LMINUS .OR. LPLUS)THEN
+ ELSE
+ IF(NHISTORY(KLOOP) == 3)THEN
+ DO JA=1,MAX(1,KLOOP-1)
+ IF(NHISTORY(J) == 1)THEN
+! Pour placer le titre au dessus de la + gde fenetre
+ IF(ZZVT /= ZVT)THEN
+ ZZT=(ZZVT-ZVT)*(ZWT-ZWB)/(ZVT-ZVB)
+ CALL PLCHHQ(ZWL+(J-1)*(ZWR-ZWL)/6.,ZWT+ZZT+(ZWT+ZZT-ZWB)/38.,YTITGAL(J)(1:LEN_TRIM(YTITGAL(J))),.008,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZWL+(J-1)*(ZWR-ZWL)/6.,ZWT+(ZWT-ZWB)/38.,YTITGAL(J)(1:LEN_TRIM(YTITGAL(J))),.008,0.,-1.)
+ ENDIF
+ EXIT
+ ENDIF
+ CALL PLCHHQ(ZWL+(J-1)*(ZWR-ZWL)/6.,ZWT+(ZWT-ZWB)/38.,YTITGAL(J)(1:LEN_TRIM(YTITGAL(J))),.008,0.,-1.)
+ ENDDO
+ ELSE
+ CALL PLCHHQ(ZWL+(J-1)*(ZWR-ZWL)/6.,ZWT+(ZWT-ZWB)/38.,YTITGAL(J)(1:LEN_TRIM(YTITGAL(J))),.008,0.,-1.)
+ ENDIF
+ ENDIF
+ CASE DEFAULT
+ SELECT CASE(IST(J))
+ CASE(1:9)
+ WRITE(YC1,'(I1)')IST(J)
+ CALL PLCHHQ(ZWL+(J-1)*(ZWR-ZWL)/6.,ZWT+(ZWT-ZWB)/38.,YC1,.008,0.,-1.)
+ CASE(10:99)
+ WRITE(YC2,'(I2)')IST(J)
+ CALL PLCHHQ(ZWL+(J-1)*(ZWR-ZWL)/6.,ZWT+(ZWT-ZWB)/38.,YC2,.008,0.,-1.)
+ CASE(100:999)
+ WRITE(YC3,'(I3)')IST(J)
+ CALL PLCHHQ(ZWL+(J-1)*(ZWR-ZWL)/6.,ZWT+(ZWT-ZWB)/38.,YC3,.008,0.,-1.)
+ CASE DEFAULT
+ print *,' Numero de station IMPREVU ou INVALIDE : ',IST(J)
+ END SELECT
+
+ END SELECT
+!!!!!!JD Avril 2009
+ ENDIF
+!!!!!!JD Avril 2009
+
+ IF(LCOLINE)THEN
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ELSE
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+
+ SELECT CASE(J)
+ CASE(1:4)
+ CALL GSLWSC(1.)
+ CASE(5:8)
+ CALL GSLWSC(2.)
+ CASE(9:12)
+ CALL GSLWSC(3.)
+ END SELECT
+ IF(LPHSTYUSER)THEN
+ CALL AGSETR('DAS/SE.',1.)
+ IF(KLOOP == 1 .OR. J == 1)THEN
+ ISTYL=NPHSTY1
+ ELSEIF(KLOOP == 2 .OR. J == 2)THEN
+ ISTYL=NPHSTY2
+ ELSEIF(KLOOP == 3 .OR. J == 3)THEN
+ ISTYL=NPHSTY3
+ ELSEIF(KLOOP == 4 .OR. J == 4)THEN
+ ISTYL=NPHSTY4
+ ELSEIF(KLOOP == 5 .OR. J == 5)THEN
+ ISTYL=NPHSTY5
+ ELSEIF(KLOOP == 6 .OR. J == 6)THEN
+ ISTYL=NPHSTY6
+ ELSEIF(KLOOP == 7 .OR. J == 7)THEN
+ ISTYL=NPHSTY7
+ ELSEIF(KLOOP == 8 .OR. J == 8)THEN
+ ISTYL=NPHSTY8
+ ENDIF
+IF(ISTYL == 1)CALL AGSETR('DAS/PA/1.',65535.)
+IF(ISTYL == 2)CALL AGSETR('DAS/PA/1.',30583.)
+IF(ISTYL == 3)CALL AGSETR('DAS/PA/1.',21845.)
+IF(ISTYL == 4)CALL AGSETR('DAS/PA/1.',10023.)
+IF(ISTYL == 5)CALL AGSETR('DAS/PA/1.',16191.)
+IF(ISTYL == 6)CALL AGSETR('DAS/PA/1.',990.)
+IF(ISTYL == 7)CALL AGSETR('DAS/PA/1.',3855.)
+IF(ISTYL == 8)CALL AGSETR('DAS/PA/1.',24415.)
+IF(ISTYL == 9)CALL AGSETR('DAS/PA/1.',13107.)
+IF(ISTYL == 10)CALL AGSETR('DAS/PA/1.',63903.)
+ ELSE
+ CALL GSLN(MOD(J,4))
+ IF(MOD(J,4) == 0)CALL GSLN(4)
+ ENDIF
+
+ ENDIF
+
+!!!!!!JD Avril 2009
+ IF(LXYSTYLTOP)THEN
+!!!!!!JD Avril 2009
+ CALL FRSTPT(ZWL+(J-1)*(ZWR-ZWL)/6.,ZWT+ZZT+(ZWT+ZZT-ZWB)/70.)
+ CALL VECTOR(ZWL+(J-1)*(ZWR-ZWL)/6.+(ZWR-ZWL)/20.,ZWT+ZZT+(ZWT+ZZT-ZWB)/70.)
+ CALL SFLUSH
+!!!!!!JD Avril 2009
+ ENDIF
+!!!!!!JD Avril 2009
+
+ CALL GSCLIP(1)
+
+ DO JI=1,IBRECOUV(J)
+
+ JD=IRECOUV(JI*2-1,J)
+ JF=IRECOUV(JI*2,J)
+
+ IF(PTIMED /= PTIMEF)THEN
+
+! print *,' JD JF AVANT ',JD,JF
+
+ SELECT CASE(CTYPE)
+ CASE('DRST','RSPL','RAPL')
+ J2=IST(J)
+ CASE DEFAULT
+ J2=1
+ END SELECT
+
+ IF(.NOT. LTINCRDIA(J,J2))THEN
+
+ DO JE=1,NBTIMEDIA(J,J2)
+ IF(NTIMEDIA(JE,J,J2) >= JD)THEN
+ JD=JE
+ EXIT
+ ENDIF
+ ENDDO
+
+ DO JE=1,NBTIMEDIA(J,J2)
+ IF(NTIMEDIA(JE,J,J2) == JF)THEN
+ JF=JE
+ EXIT
+ ELSE IF(NTIMEDIA(JE,J,J2) > JF)THEN
+ JF=JE-1
+ EXIT
+ ENDIF
+ ENDDO
+
+ JF=MIN(JF,NBTIMEDIA(J,J2))
+! print *,' JD JF APRES ',JD,JF
+
+ ELSE
+
+ JJE=0
+ DO JE=NTIMEDIA(1,J,J2),NTIMEDIA(2,J,J2),NTIMEDIA(3,J,J2)
+ JJE=JJE+1
+ IF(JE >= JD)THEN
+ JD=JJE
+ EXIT
+ ENDIF
+ ENDDO
+
+ JJE=0
+ DO JE=NTIMEDIA(1,J,J2),NTIMEDIA(2,J,J2),NTIMEDIA(3,J,J2)
+ JJE=JJE+1
+ IF(JE == JF)THEN
+ JF=JJE
+ EXIT
+ ELSE IF(JE > JF)THEN
+ JF=MIN(JF,JJE-1)
+ EXIT
+ ENDIF
+ ENDDO
+
+ JJE=0
+ DO JE=NTIMEDIA(1,J,J2),NTIMEDIA(2,J,J2),NTIMEDIA(3,J,J2)
+ JJE=JJE+1
+ ENDDO
+ JF=MIN(JF,JJE)
+ ENDIF
+
+ ENDIF
+ CALL GQLWSC(IER,ZW)
+ IF(LXYDIA .AND. LCONT)THEN
+ CALL GSLWSC(3.)
+ ELSE IF(LXT .OR. LYT .OR. LXYDIA)THEN
+ CALL GSLWSC(2.)
+ ELSE
+ CALL GSLWSC(2.)
+ IF(KLOOP == 1 .OR. J == 1)THEN
+ CALL GSLWSC(XLWPH1)
+ ELSEIF(KLOOP == 2 .OR. J == 2)THEN
+ CALL GSLWSC(XLWPH2)
+ ELSEIF(KLOOP == 3 .OR. J == 3)THEN
+ CALL GSLWSC(XLWPH3)
+ ELSEIF(KLOOP == 4 .OR. J == 4)THEN
+ CALL GSLWSC(XLWPH4)
+ ELSEIF(KLOOP == 5 .OR. J == 5)THEN
+ CALL GSLWSC(XLWPH5)
+ ELSEIF(KLOOP == 6 .OR. J == 6)THEN
+ CALL GSLWSC(XLWPH6)
+ ELSEIF(KLOOP == 7 .OR. J == 7)THEN
+ CALL GSLWSC(XLWPH7)
+ ELSEIF(KLOOP == 8 .OR. J == 8)THEN
+ CALL GSLWSC(XLWPH8)
+ ENDIF
+ ENDIF
+ CALL GQLWSC(IERR,ZLWSC)
+ if(nverbia > 0)then
+ print *,' ** traxy KLOOP XLWPH ',KLOOP,ZLWSC
+ endif
+! IF(CTYPE == 'RSPL')THEN
+! CALL GQCLIP(IER,ICLIP,ZCL)
+! IF(ICLIP == 0)THEN
+! CALL GSCLIP(1)
+! ENDIF
+! ENDIF
+ CALL EZXY(ZWT1(JD:JF),ZWT2(JD:JF),JF-JD+1,0)
+ CALL SFLUSH
+! IF(CTYPE == 'RSPL')THEN
+! CALL GSCLIP(ICLIP)
+! ENDIF
+ CALL GSLWSC(ZW)
+
+ ENDDO
+ DEALLOCATE(ZWT1,ZWT2)
+
+ENDDO ! Fin Do J=1,NSUPERDIA
+!!! Avril 2009 JD
+ IF(.NOT.LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ IF(LAXEXUSER)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,XAXEXUSERD,XAXEXUSERF,ZWB,ZWT,ID)
+ ENDIF
+ ENDIF
+!!! Avril 2009 JD
+
+CALL GSLWSC(1.)
+CALL GSPLCI(1)
+CALL GSTXCI(1)
+CALL GSLN(1)
+!G.TANGUY juin 2010
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
+ IF(LFACTAXEX)THEN
+ IF(LFACTAXEY)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,&
+ ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
+ ELSE
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,&
+ ZWBB,ZWTT,IDD)
+ ENDIF
+ ELSEIF(LFACTAXEY)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,&
+ ZWBB*XFACTAXEY,ZWTT*XFACTAXEY,IDD)
+ ENDIF
+!fin G.TANGUY juin 2010
+!!!PROVI
+!go to 10
+IF(.NOT.LXYWINCUR)THEN
+IF(.NOT.GOK)THEN
+ IF(NHISTORY(KLOOP) == 3)THEN
+ DO JA=1,MAX(1,KLOOP-1)
+ IF(NHISTORY(J) == 1)THEN
+!Avril 2002
+ IF(LNOLABELX .AND.LNOLABELY)THEN
+ CALL GRIDAL(NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN,0,0,5,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN,0,1,5,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN,-1,0,5,0.,0.)
+ ELSE
+ CALL GRIDAL(NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN,-1,1,5,0.,0.)
+ ENDIF
+!Avril 2002
+ EXIT
+ ELSE
+!Avril 2002
+ IF(LNOLABELX .AND.LNOLABELY)THEN
+ CALL GRIDAL(NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN,0,0,5,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN,0,1,5,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN,1,0,5,0.,0.)
+ ELSE
+ CALL GRIDAL(NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN,1,1,5,0.,0.)
+ ENDIF
+!Avril 2002
+ ENDIF
+ ENDDO
+ ELSE
+!Avril 2002
+ IF(LNOLABELX .AND.LNOLABELY)THEN
+ CALL GRIDAL(NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN,0,0,5,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN,0,1,5,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN,1,0,5,0.,0.)
+ ELSE
+ CALL GRIDAL(NXYITVXMJ,NXYITVXMN,NXYITVYMJ,NXYITVYMN,1,1,5,0.,0.)
+ ENDIF
+!Avril 2002
+ ENDIF
+! CALL GRIDAL(5,1,5,1,1,1,5,0.,0.)
+ENDIF
+ENDIF
+!G.TANGUY juin 2010
+
+IF(LFACTAXEX .OR. LFACTAXEY)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDD)
+ENDIF
+! fin G.TANGUY juin 2010
+!10 continue
+!!!PROVI
+! Titres
+!
+SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ YCAR(1:LEN(YCAR))=' '
+ CASE('SSOL')
+ CASE DEFAULT
+ YCAR(1:LEN(YCAR))=' '
+ YCAR(1:4)=CTYPE
+! YCAR(5:7)=' N.'
+! WRITE(YCAR(8:10),'(I3)')IST(1)
+! ISUIT=11
+! DO J=2,ICOMPT
+! DO JE=1,J-1
+! IF(IST(J) == IST(JE))THEN
+! EXIT
+! ELSE
+! WRITE(YCAR(ISUIT:ISUIT+4),'(I5)')IST(J)
+! ISUIT=ISUIT+5
+! ENDIF
+! ENDDO
+! ENDDO
+END SELECT
+
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+IF(LFACTIMP)THEN
+ CALL FACTIMP
+ENDIF
+! Titres en X
+YTEM(1:LEN(YTEM))=' '
+CALL RESOLV_TIT('CTITXL',YTEM)
+IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/2.,YTEM,.008,0.,-1.)
+ENDIF
+YTEM(1:LEN(YTEM))=' '
+CALL RESOLV_TIT('CTITXM',YTEM)
+IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+ENDIF
+YTEM(1:LEN(YTEM))=' '
+IF(.NOT.GOK)THEN
+YTEM=ADJUSTL(HTITX)
+ENDIF
+CALL RESOLV_TIT('CTITXR',YTEM)
+IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(NHISTORY(KLOOP) == 3)THEN
+ DO J=1,MAX(1,KLOOP-1)
+ IF(NHISTORY(J) == 1)THEN
+ EXIT
+ ENDIF
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+ ENDDO
+ ELSE
+ CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+ ENDIF
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ENDIF
+! Titres en Y
+YTEM(1:LEN(YTEM))=' '
+IF(.NOT.GOK)THEN
+YTEM=ADJUSTL(HTITY)
+ENDIF
+CALL RESOLV_TITY('CTITYT',ZVL,ZVR,ZVB,ZVT,YTEM)
+YTEM(1:LEN(YTEM))=' '
+CALL RESOLV_TITY('CTITYM',ZVL,ZVR,ZVB,ZVT,YTEM)
+YTEM(1:LEN(YTEM))=' '
+CALL RESOLV_TITY('CTITYB',ZVL,ZVR,ZVB,ZVT,YTEM)
+
+! TitresTOP
+YTEM(1:LEN(YTEM))=' '
+CALL RESOLV_TIT('CTITT3',YTEM)
+ZXPOSTITT3=.002
+ZXYPOSTITT3=.93
+IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ENDIF
+IF(XYPOSTITT3 /= 0.)THEN
+ZXYPOSTITT3=XYPOSTITT3
+ENDIF
+
+IF(CTITT3 /= ' ')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,XSZTITT3,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT3,ZXYPOSTITT3,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.93,YTEM,.008,0.,-1.)
+ ENDIF
+ENDIF
+YTEM(1:LEN(YTEM))=' '
+CALL RESOLV_TIT('CTITT2',YTEM)
+ZXPOSTITT2=.002
+ZXYPOSTITT2=.95
+IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ENDIF
+IF(XYPOSTITT2 /= 0.)THEN
+ZXYPOSTITT2=XYPOSTITT2
+ENDIF
+IF(CTITT2 /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,XSZTITT2,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT2,ZXYPOSTITT2,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
+ ENDIF
+ENDIF
+YTEM(1:LEN(YTEM))=' '
+YTEM=ADJUSTL(YCAR)
+CALL RESOLV_TIT('CTITT1',YTEM)
+ZXPOSTITT1=.002
+ZXYPOSTITT1=.98
+IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ENDIF
+IF(XYPOSTITT1 /= 0.)THEN
+ZXYPOSTITT1=XYPOSTITT1
+ENDIF
+!IF(CTITT1 /= ' ')THEN
+! 230498
+IF(YTEM /= ' ' .AND. CTITT1 /= 'DEFAULT')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YTEM,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YTEM,.012,0.,-1.)
+ ENDIF
+ELSE
+ IF(YTEM ==' ')THEN
+
+ IF(LCV .AND. LCH)THEN
+ ELSE IF(LCH)THEN
+ IF(NIINF /= 0 .AND. NJINF /=0 .AND. NJSUP /= 0 .AND. NISUP /= 0)THEN
+ YTEM(1:LEN(YTEM))=' '
+ WRITE(YTEM,'(''NIINF='',I4,2X,''NISUP='',I4,2X,''NJINF='',I4,2X,''NJSUP='',I4)')NIINF,NISUP,NJINF,NJSUP
+ YTEM=ADJUSTL(YTEM)
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM,XSZTITT1,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YTEM,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM,.012,0.,-1.)
+! CALL PLCHHQ(0.002,0.98,YTEM,.012,0.,-1.)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ENDIF
+ENDIF
+! TitresBOTTOM
+! Titre N3 BOTTOM
+YTEM(1:LEN(YTEM))=' '
+IF(PTIMED == PTIMEF)THEN
+ WRITE(YTEM,'(''Time'',F10.0)')PTIMED
+ELSE
+ WRITE(YTEM,'(''Time'',F10.0,'' - '',F10.0)')PTIMED,PTIMEF
+ENDIF
+CALL RESOLV_TIT('CTITB3',YTEM)
+ZXPOSTITB3=.002
+ZXYPOSTITB3=.05
+IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ENDIF
+IF(XYPOSTITB3 /= 0.)THEN
+ZXYPOSTITB3=XYPOSTITB3
+ENDIF
+!IF(CTITB3 /= ' ')THEN
+IF(YTEM /= ' ')THEN
+ IF(NHISTORY(KLOOP) == 3)THEN
+ DO J=1,MAX(1,KLOOP-1)
+ IF(NHISTORY(J) == 1)THEN
+ EXIT
+ ENDIF
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDDO
+ ELSE
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,XSZTITB3,0.,-1.)
+! CALL PLCHHQ(0.002,0.05,YTEM,XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.05,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ENDIF
+! Titre N2 BOTTOM
+YTEM(1:LEN(YTEM))=' '
+IF(LCH)THEN
+ YTEM=ADJUSTL(CLEGEND2)
+ENDIF
+CALL RESOLV_TIT('CTITB2',YTEM)
+ZXPOSTITB2=.002
+ZXYPOSTITB2=.025
+IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ENDIF
+IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ENDIF
+IF(YTEM/= ' ')THEN
+ IF(XSZTITB2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,YTEM,XSZTITB2,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,YTEM,XSZTITB2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,YTEM,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,YTEM,.007,0.,-1.)
+ ENDIF
+ENDIF
+! Titre N1 BOTTOM
+YTEM(1:LEN(YTEM))=' '
+IF(LCH)THEN
+ YTEM=ADJUSTL(CLEGEND)
+ENDIF
+CALL RESOLV_TIT('CTITB1',YTEM)
+ZXPOSTITB1=.002
+ZXYPOSTITB1=.005
+IF(XPOSTITB1 /= 0.)THEN
+ ZXPOSTITB1=XPOSTITB1
+ENDIF
+IF(XYPOSTITB1 /= 0.)THEN
+ ZXYPOSTITB1=XYPOSTITB1
+ENDIF
+IF(YTEM /= ' ')THEN
+ IF(XSZTITB1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,YTEM,XSZTITB1,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,YTEM,XSZTITB1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,YTEM,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,YTEM,.007,0.,-1.)
+ ENDIF
+ENDIF
+
+DEALLOCATE(ZTEMX2D,ZTEMY2D,ICOMPTSZ,IBRECOUV,IST,IRECOUV,ZTIMD,ZTIMF,YTITGAL)
+ICOMPT=0
+if(nverbia > 0)then
+print *,' Sortie TRAXY'
+endif
+RETURN
+!
+!----------------------------------------------------------------------------
+!
+!* 4. EXIT
+! ----
+!
+END SUBROUTINE TRAXY
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/tsound_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/tsound_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0b2e7f7ebd8139d45719671b30230d3106d3883d
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/tsound_fordiachro.f90
@@ -0,0 +1,1459 @@
+! ######spl
+SUBROUTINE TSOUND_FORDIACHRO(PPRES,PPTEMP,PPQV,PPU,PPV,KNN,HEADER,HTEXTE, &
+ OMXRAT, &
+ OMIXRAT,ODOFRAME,OSAMPLEUV)
+!##########################################################################
+!
+!!**** *TSOUND_FORDIACHRO* - Emagram plotting routine
+!!
+!! PURPOSE
+!! -------
+!
+! Plots soundings on a skew-T, log P Thermodynamic diagram
+! All units are in the international system.
+!
+!!** METHOD
+!! ------
+!! A standard sounding background is first drawn, and the current
+!! data are plotted on a skew-T, Log P diagram. Various functions
+!! are defined for scale conversion and moisture calculations.
+!!
+!! EXPLICIT ARGUMENTS
+!! ------------------
+!!
+!! PRES - Pressure array for thermodynamic data (Pascals)
+!! PTEMP - Temperature array (Kelvin)
+!! PQV - Water vapour mixing ratio (KG/KG)
+!! PU,PV - Wind (M/S)
+!! KNN - Number of data points
+!! HEADER - 40 Character Header (var. name and misc.)
+!! HTEXTE - Header with gridpoint location (grid indexes)
+!! OMXRAT - Logical to control dew point line drawing
+!! OMIXRAT - Logical for water vapour variable mode selection
+!! ODOFRAME - Logical for issuing a FRAME after plotting this emagram
+!! OSAMPLEUV - Logical for wind vector decimation
+!!
+!! EXTERNAL
+!! --------
+!! OS : computes the equivalent potential temperature
+!! TSA : computes the pseudo-moist adiabat
+!! DEWP : computes the dew point
+!!
+!! Notice: two statement functions, ZFY, ZFX are also defined to
+!! map the (T,P) points onto the user coordinates, and a
+!! third one, ZCNP, is converts wind directions to the
+!! meteorological standard.
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! For thermodynamical functions, see for instance:
+!! Bluestein H. B., 1992, "Synoptic-Dynamic Meteorology in mid-latitudes"
+!! Volume 1, Priciples of Kinematics and Dynamics, Section 4.3, p. 195,
+!! Oxford University Press.
+!!
+!!
+!! AUTHOR
+!! ------
+!! - Initial version Peridot TRACE Program, P.Bougeault *Meteo-France*,
+!! modified by R. Benoit (mc2, april 91) for the PYREX Oracle data base.
+!! - Present version J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 10/01/95
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_TITLE
+USE MODD_TIT
+USE MODD_PT_FOR_CH_FORDIACHRO
+USE MODD_RESOLVCAR
+USE MODD_TYPE_AND_LH
+USE MODN_NCAR
+USE MODD_DIM1
+USE MODD_RSISOCOL
+USE MODD_PARAMETERS
+USE MODI_FMREAD
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments and results
+!
+INTEGER :: KNN ! Number of data points
+REAL,DIMENSION(:) :: PPRES, PPTEMP, PPQV, PPU, PPV ! Sounding state variables
+REAL :: PP, PT, PY, PA ! Dummies for definitions
+CHARACTER(LEN=*) :: HEADER ! Header containing variable name
+CHARACTER(LEN=*) :: HTEXTE ! Header containing sounding location
+LOGICAL :: OMXRAT ! Logical keys pecifying whether moisture data
+LOGICAL :: OMIXRAT ! are present, and if the moisture variable qv
+ ! contains mixing ratio or dewpoint temperature
+LOGICAL :: ODOFRAME ! Logical for FRAME after plot control
+LOGICAL :: OSAMPLEUV ! Logical for wind plotting only
+
+!
+!* 0.2 Local variables
+!
+INTEGER,PARAMETER :: JPNWK=1000
+INTEGER :: J, JJ, IK, JJJ, II, ID
+INTEGER :: INUM, IRESP
+INTEGER :: INC, IANGU, IENCD, ILEN, INEG !,IPCK
+INTEGER :: ILENT, ILEN2, JLOOP2, JLOOPT
+INTEGER :: IKB, IKE, IKU
+INTEGER :: IB, IE, IN
+INTEGER :: IERR, ICOLI
+INTEGER,DIMENSION(13) :: IASF
+REAL,DIMENSION(8,2) :: ZRAT
+REAL,DIMENSION(15,2) :: ZTP
+REAL,DIMENSION(81) :: ZSX, ZSY
+REAL,DIMENSION(7) :: ZXB, ZYB
+REAL,DIMENSION(9,2) :: ZPLN
+REAL,DIMENSION(162) :: ZY45, ZDX, ZDY
+REAL,DIMENSION(10) :: ZPLV
+REAL :: ZINT, ZVL, ZVR, ZVB, ZVT, ZWL, ZWR, ZWB, ZWT
+REAL :: ZXPOSTITT1, ZXYPOSTITT1
+REAL :: ZXPOSTITB1, ZXYPOSTITB1
+REAL :: ZXPOSTITB2, ZXYPOSTITB2
+!
+! Work vectors ZWORKS1...5 dimensioned to JPNWK=1000
+! to receive high resolution souding as well.
+!
+!REAL,DIMENSION(JPNWK) :: ZWORKS1, ZWORKS2, ZWORKS3, ZWORKS4, ZWORKS5
+!
+REAL :: ZDTR, ZTS, ZTK, ZP, ZT, ZTD
+REAL :: ZAOS, ZATSA, ZX1, ZX2, ZY1, ZY2, ZYD, ZYPD, ZXPD
+REAL :: ZTX, ZX, ZY, ZDWPT, ZVSCALE, ZVVMAX, ZXM
+REAL :: ZDYSMPL, ZYSMPL
+REAL :: ZHA
+REAL :: ZFX, ZFY, ZCNP
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: PRES, PTEMP, PQV, PU, PV
+!
+CHARACTER(LEN=2),DIMENSION(8) :: YLRAT
+CHARACTER(LEN=4) :: YIT
+CHARACTER(LEN=1) :: YC1, Y1
+CHARACTER(LEN=2) :: YC2
+CHARACTER(LEN=16) :: YTEM
+CHARACTER(LEN=80) :: YTEM80
+CHARACTER(LEN=19) :: YGROUP
+!
+! Logical keys to activate wind, temperature plotting
+!
+LOGICAL :: GDOTEMP, GDOUV, GDOUVM
+!
+! To prevent arrows overcrowding when high resolution data are used,
+! a maximum number of arrows is set
+!
+INTEGER :: IMXSMPLUV=50
+!
+!* 0.3 Interface declarations
+!
+INTERFACE
+ FUNCTION OS(PT,PP)
+ REAL,INTENT(IN) :: PT, PP
+ REAL :: OS
+ END FUNCTION OS
+END INTERFACE
+INTERFACE
+ FUNCTION TSA(POS,PP)
+ REAL,INTENT(IN) :: POS, PP
+ REAL :: TSA
+ END FUNCTION TSA
+END INTERFACE
+INTERFACE
+ FUNCTION DEWP(PQ,PP)
+ REAL,INTENT(IN) :: PQ, PP
+ REAL :: DEWP
+ END FUNCTION DEWP
+END INTERFACE
+INTERFACE
+ SUBROUTINE WTSTR (PX,PY,CH,IS,IO,IC)
+ CHARACTER*(*) CH
+ REAL,INTENT(INOUT) :: PX,PY
+ INTEGER :: IS,IO,IC
+ END SUBROUTINE WTSTR
+END INTERFACE
+INTERFACE
+ SUBROUTINE ECHELLE(KLEN,PHA)
+ INTEGER, INTENT(OUT) :: KLEN
+ REAL, INTENT(OUT) :: PHA
+ END SUBROUTINE ECHELLE
+END INTERFACE
+INTERFACE
+ SUBROUTINE FLECHE(PX,PY,PU,PV,KLEN,PHA)
+ INTEGER :: KLEN
+ REAL :: PX, PY
+ REAL :: PU, PV
+ REAL :: PHA
+ END SUBROUTINE FLECHE
+END INTERFACE
+INTERFACE
+ SUBROUTINE RESOLV_TIT(HTIT,HOUT)
+ CHARACTER(LEN=*) :: HTIT, HOUT
+ END SUBROUTINE RESOLV_TIT
+END INTERFACE
+!
+!* 0.4 Statement function declarations
+!
+ZFY(PP) = 132.182-44.061*ALOG10(PP) ! Functions mapping the (T,P) values onto
+ZFX(PT,PY) = 0.54*PT+0.90692*PY ! the defined NCAR user coordinates
+ZCNP(PA) = AMOD((450.-PA),360.) ! Wind direction standardization
+!
+!------------------------------------------------------------------------------
+!
+!* 1. BACKGROUND DATA TABLES SET UP
+! -----------------------------
+!
+!* 1.1 Defines an emagram color table
+!
+
+IASF(:)=1
+CALL GSASF(IASF)
+IF(LINVWB)THEN
+CALL GSCR(1,1,0.,0.,0.)
+CALL GSCR(1,0,1.,1.,1.)
+ELSE
+CALL GSCR(1,0,0.,0.,0.)
+CALL GSCR(1,1,1.,1.,1.)
+ENDIF
+CALL GSCR(1,2,1.,0.,0.)
+CALL GSCR(1,3,0.,1.,0.)
+CALL GSCR(1,62,1.,.625,0.)
+
+IKB=1+JPVEXT
+IKU=NKMAX+2*JPVEXT
+IKE=IKU-JPVEXT
+YTEM80(1:LEN(YTEM80))=' '
+CALL PCGETC('FC',Y1)
+if(nverbia > 0)then
+print *,' **tsou Y1 ',Y1
+endif
+CALL PCSETC('FC','?')
+!
+!* 1.2 Parameter checking
+!
+IF(ALLOCATED(PRES))THEN
+ DEALLOCATE(PRES)
+ENDIF
+IF(ALLOCATED(PTEMP))THEN
+ DEALLOCATE(PTEMP)
+ENDIF
+IF(ALLOCATED(PQV))THEN
+ DEALLOCATE(PQV)
+ENDIF
+IF(ALLOCATED(PU))THEN
+ DEALLOCATE(PU)
+ENDIF
+IF(ALLOCATED(PV))THEN
+ DEALLOCATE(PV)
+ENDIF
+ALLOCATE(PRES(SIZE(PPRES)))
+ALLOCATE(PTEMP(SIZE(PPTEMP)))
+ALLOCATE(PQV(SIZE(PPQV)))
+ALLOCATE(PU(SIZE(PPU)))
+ALLOCATE(PV(SIZE(PPV)))
+PRES(:)=PPRES(:)
+PTEMP(:)=PPTEMP(:)
+PQV(:)=PPQV(:)
+PU(:)=PPU(:)
+PV(:)=PPV(:)
+PRINT *,' ********** TSOUND_FORDIACHRO'
+IF(nverbia > 0)then
+PRINT *,' PRES'
+PRINT *,PRES
+PRINT *,' PTEMP'
+PRINT *,PTEMP
+PRINT *,' PQV'
+PRINT *,PQV
+PRINT *,' PU'
+PRINT *,PU
+PRINT *,' PV'
+PRINT *,PV
+endif
+PRINT *,' HEADER',HEADER ,'LEN ',LEN(HEADER),' LEN_TRIM ',LEN_TRIM(HEADER)
+PRINT *,' HTEXTE',HTEXTE
+PRINT *,' OMIXRAT ',OMIXRAT
+PRINT *,' ODOFRAME ',ODOFRAME
+PRINT *,' OSAMPLEUV ',OSAMPLEUV
+IF(KNN.GT.JPNWK)THEN ! if 1
+ PRINT *,' Emagram TSOUND_FORDIACHRO... data overflows available arrays!'
+ PRINT *,' KNN=',KNN,' when maximum allowed size is ',JPNWK,', return'
+ RETURN
+ENDIF ! endif 1
+! ------nn <=> nwk -------
+INC=KNN
+ GDOTEMP=KNN.GT.0
+ GDOUV=GDOTEMP
+!! ESSAI
+ IF(LNOUVRS)THEN
+ GDOUV=.FALSE.
+ ENDIF
+!! ESSAI
+ GDOUVM=GDOUV
+!
+!* 1.3 Data for constant mixing ratio lines
+!
+ZRAT(1,1)=13.284
+ZRAT(2,1)=8.91
+ZRAT(3,1)=5.616
+ZRAT(4,1)=1.944
+ZRAT(5,1)=-1.782
+ZRAT(6,1)=-4.698
+ZRAT(7,1)=-9.234
+ZRAT(8,1)=-14.796
+ZRAT(1,2)=16.283
+ZRAT(2,2)=12.125
+ZRAT(3,2)=8.94
+ZRAT(4,2)=5.45
+ZRAT(5,2)=1.865
+ZRAT(6,2)=-.858
+ZRAT(7,2)=-5.313
+ZRAT(8,2)=-10.686
+!
+YLRAT(1)='20'
+YLRAT(2)='12'
+YLRAT(3)=' 8'
+YLRAT(4)=' 5'
+YLRAT(5)=' 3'
+YLRAT(6)=' 2'
+YLRAT(7)=' 1'
+YLRAT(8)='.4'
+!
+!* 1.4 Data for constant temperature lines
+!
+ZTP(1,1)=1000.
+ZTP(2,1)=1000.
+ZTP(3,1)=1000.
+ZTP(4,1)=1000.
+ZTP(5,1)=1000.
+ZTP(6,1)=1000.
+ZTP(7,1)=1000.
+ZTP(8,1)=1000.
+ZTP(9,1)=855.
+ZTP(10,1)=625.
+ZTP(11,1)=459.
+ZTP(12,1)=337.
+ZTP(13,1)=247.
+ZTP(14,1)=181.
+ZTP(15,1)=132.
+ZTP(1,2)=730.
+ZTP(2,2)=580.
+ZTP(3,2)=500.
+ZTP(4,2)=430.
+ZTP(5,2)=342.
+ZTP(6,2)=251.
+ZTP(7,2)=185.
+ZTP(8,2)=135.
+ZTP(9,2)=100.
+ZTP(10,2)=100.
+ZTP(11,2)=100.
+ZTP(12,2)=100.
+ZTP(13,2)=100.
+ZTP(14,2)=100.
+ZTP(15,2)=100.
+!
+!* 1.5 Data for constant pressure lines
+!
+ZPLV(1)=100.
+ZPLV(2)=200.
+ZPLV(3)=300.
+ZPLV(4)=400.
+ZPLV(5)=500.
+ZPLV(6)=600.
+ZPLV(7)=700.
+ZPLV(8)=800.
+ZPLV(9)=850.
+ZPLV(10)=1000.
+!
+!* 1.6 Frame of the emagram plot
+!
+ZXB(1)= -19.
+ZXB(2)=27.1
+ZXB(3)=27.1
+ZXB(4)=18.6
+ZXB(5)=18.6
+ZXB(6)=-19.
+ZXB(7)=-19.
+!
+ZYB(1)=0.
+ZYB(2)=0.
+ZYB(3)=9.
+ZYB(4)=17.53
+ZYB(5)=44.061
+ZYB(6)=44.061
+ZYB(7)=0.
+!
+!* 1.7 Initial and final points of the
+!* constant pressure lines
+!
+! IPCK = 0
+!
+ZPLN(1,1)=-19.
+ZPLN(2,1)=-19.
+ZPLN(3,1)=-19.
+ZPLN(4,1)=-19.
+ZPLN(5,1)=-19.
+ZPLN(6,1)=-19.
+ZPLN(7,1)=-19.
+ZPLN(8,1)=-19.
+ZPLN(9,1)=-19.
+ZPLN(1,2)=18.6
+ZPLN(2,2)=18.6
+ZPLN(3,2)=18.6
+ZPLN(4,2)=18.6
+ZPLN(5,2)=22.83
+ZPLN(6,2)=26.306
+ZPLN(7,2)=27.1
+ZPLN(8,2)=27.1
+ZPLN(9,2)=27.1
+!
+!* 1.8 Various constants
+!
+ZDTR = ATAN(1.)/45.
+IANGU = 359.
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. DRAWING THE BACKGROUND OF THE EMAGRAM PLOT
+! ------------------------------------------
+!
+!* 2.1 Draws outline of skew-T Log P diagram
+!
+CALL GSTXCI(62)
+CALL GSPLCI(62)
+CALL GSFACI(62) ! The NCAR user coordinate
+CALL SET(.05,.95,.05,.95,-19.0,27.1,0.0,44.061,1) ! system is here set in
+ ! accordance with ZFY, ZFX
+ ! statement functions defined
+ ! above.
+CALL CURVE(ZXB,ZYB,7)
+!
+!* 2.2 Draws satured adiabat. curves
+!
+CALL GSTXCI(2)
+CALL GSPLCI(3)
+CALL GSFACI(3)
+ZTS = 32.
+DO JJ = 1,7 ! do 1
+! CALL SETUSV ('IN',8000)
+ CALL DASHDB(990)
+ ZP = 1010.
+ ZTK = ZTS+273.16
+ ZAOS = OS(ZTK,1000.)
+ DO J = 1,81 ! do 2
+ ZP = ZP-10.
+ ZATSA = TSA(ZAOS,ZP)-273.16
+ ZSY(J) = ZFY(ZP)
+ ZSX(J) = ZFX(ZATSA,ZSY(J))
+ ENDDO ! enddo 2
+ CALL CURVED(ZSX,ZSY,81)
+ IENCD = IFIX(ZTS)
+ WRITE(YIT,100) IENCD
+ YIT=ADJUSTL(YIT)
+ 100 FORMAT(I2)
+ ZTS = ZTS-4.
+ ZSY(81) = ZSY(81)+0.6
+ CALL WTSTR(ZSX(81),ZSY(81),YIT(1:LEN_TRIM(YIT)),1,IANGU,0)
+! CALL WTSTR(ZSX(81),ZSY(81),YIT(1:2),1,IANGU,0)
+ENDDO ! enddo 1
+!
+!* 2.3 Draws constant mixing ratio lines
+!
+DO J = 1,8 ! do 1
+! CALL SETUSV ('IN',8000)
+ CALL DASHDB(29127)
+ CALL LINED(ZRAT(J,1),-0.1,ZRAT(J,2),6.824)
+ YIT(1:2) = YLRAT(J)
+ YIT=ADJUSTL(YIT)
+ ZY1=6.42
+ CALL WTSTR(ZRAT(J,2),ZY1,YIT(1:LEN_TRIM(YIT)),1,IANGU,0)
+! CALL WTSTR(ZRAT(J,2),1.42,YIT(1:2),1,IANGU,0)
+! print *,' Mixing ratio lines'
+ENDDO ! enddo 1
+!
+!* 2.4 Draws constant temperature lines
+!
+CALL GSTXCI(62)
+CALL GSPLCI(62)
+CALL GSFACI(62)
+ZT = 40.
+DO J = 1,15 ! do 1
+! CALL SETUSV('IN',8000)
+ ZY1 = ZFY(ZTP(J,1))
+ ZY2 = ZFY(ZTP(J,2))
+ ZX1 = ZFX(ZT,ZY1)
+ ZX2 = ZFX(ZT,ZY2)
+ CALL LINE(ZX1,ZY1,ZX2,ZY2)
+ IF(ZT.EQ.20.)GO TO 19
+ IF(ABS(ZT) > 90)THEN
+ ZX2 = ZX2+0.4
+ ZY2 = ZY2+.441
+ ELSEIF(ZT > -100 .AND. ZT < -30)THEN
+ ZX2 = ZX2+0.4
+ ZY2 = ZY2+.53
+ ELSEIF(ZT > -40 .AND. ZT < 0)THEN
+ ZX2 = ZX2+0.76
+ ZY2 = ZY2+.453
+ ELSE
+ ZX2 = ZX2+0.88
+! ZX2 = ZX2+0.4
+ ZY2 = ZY2+.451
+ ENDIF
+! ZY2 = ZY2+.441
+ IENCD = IFIX(ZT)
+ WRITE(YIT,101) IENCD
+ YIT=ADJUSTL(YIT)
+ 101 FORMAT(I4 )
+ CALL WTSTR (ZX2,ZY2,YIT(1:LEN_TRIM(YIT)),2,45,0)
+! CALL WTSTR (ZX2,ZY2,YIT(1:4),2,45,0)
+! print *,' Temperature lines'
+ 19 ZT = ZT-10.
+ENDDO ! enddo 1
+!
+!* 2.5 Draws constant dry adiabat. curves
+!
+CALL GSTXCI(3)
+CALL GSPLCI(3)
+CALL GSFACI(3)
+ZT = 51.
+DO J = 1,162 ! do 1
+ ZY45(J) = 66.67*(5.7625544-ALOG(ZT+273.16))
+ ZT = ZT-1.0
+ENDDO ! enddo 1
+ZT = 450.
+ZTD = 52.
+DO JJ = 1,20 ! do 1
+! CALL SETUSV('IN',8000)
+ CALL DASHDB(13107)
+ ZT = ZT-10.
+ IK = 0
+ ZYD = 66.67*(ALOG(ZT)-5.7625544)
+ DO J = 1,162 ! do 2
+ ZYPD = ZY45(J)+ZYD
+ ZTX = ZTD-J
+ IF(ZYPD.GT.44.061)EXIT
+ IF(ZYPD.LT.0.0)CYCLE
+ ZXPD = ZFX(ZTX,ZYPD)
+ IF(ZXPD.LT.-19.0)EXIT
+ IF(ZXPD.GT.27.1)CYCLE
+ IF(ZXPD.GT.18.6.AND.ZT.GT.350.0)CYCLE
+ IK = IK+1
+ ZDX(IK) = ZXPD
+ ZDY(IK) = ZYPD
+ ENDDO ! enddo 2
+ CALL CURVED(ZDX,ZDY,IK)
+ IENCD = IFIX(ZT)
+ WRITE(YIT,102) IENCD
+ 102 FORMAT(I3)
+ CALL WTSTR(ZDX(IK-3),ZDY(IK-3),YIT(1:3),1,IANGU,0)
+!print *,' constant dry adiabat. curves IK YIT ',IK,YIT
+ENDDO ! enddo 1
+!
+!* 2.6 Draws constant pressure lines
+!
+CALL GSTXCI(62)
+CALL GSPLCI(62)
+DO J = 1,10 ! do 1
+! CALL SETUSV('IN',8000)
+ ZY1 = ZFY(ZPLV(J))
+ IF(J.NE.1.AND.J.NE.10)CALL LINE(ZPLN(J,1),ZY1,ZPLN(J,2),ZY1)
+ IENCD = IFIX(ZPLV(J) )
+ WRITE(YIT,101) IENCD
+ YIT=ADJUSTL(YIT)
+ IF(J==10)THEN
+ ZX1 = -20.4
+ CALL WTSTR(ZX1,ZY1,YIT(1:LEN_TRIM(YIT)),2,IANGU,0)
+! CALL WTSTR(-20.4,ZY1,YIT(1:4),2,IANGU,0)
+ ELSE
+ ZX1 = -20.3
+ CALL WTSTR(ZX1,ZY1,YIT(1:LEN_TRIM(YIT)),2,IANGU,0)
+! CALL WTSTR(-20.7,ZY1,YIT(1:4),2,IANGU,0)
+ ENDIF
+! CALL WTSTR(-20.9,ZY1,YIT(1:4),1,IANGU,0)
+ENDDO ! enddo 1
+!
+!* 2.7 Draws ticks every 2 degrees at 500 MB
+!
+!CALL SETUSV('IN',8000)
+ZY1 = 13.2627
+ZY2 = 13.75
+ZT = -52.
+DO J = 1,31 ! do 1
+ ZT = ZT+2.
+ IF(AMOD(ZT,10.).EQ.0.)CYCLE
+ ZX1 = ZFX(ZT,ZY1)
+ ZX2 = ZFX(ZT,ZY2)
+ CALL LINE(ZX1,ZY1,ZX2,ZY2)
+ENDDO ! enddo 1
+! IPCK = 1
+!
+!----------------------------------------------------------------------------
+!
+!* 3. DRAWING THE SOUNDING DATA LINES ON THE SKEW-T-LOGP DIAGRAM
+! ----------------------------------------------------------
+!
+111 CONTINUE !------111-------
+!
+!* 3.1 Plot Temperature and dewpoint curves
+!
+IANGU = 0.
+!
+CALL GSTXCI(1)
+CALL GSPLCI(1)
+CALL GSFACI(1)
+!
+CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+!Mars 2000
+! Titre N1 BOTTOM
+ ZXPOSTITB1=.002
+ ZXYPOSTITB1=.005
+ IF(XPOSTITB1 /= 0.)THEN
+ ZXPOSTITB1=XPOSTITB1
+ ENDIF
+ IF(XYPOSTITB1 /= 0.)THEN
+ ZXYPOSTITB1=XYPOSTITB1
+ ENDIF
+ CALL RESOLV_TIT('CTITB1',HEADER(1:100))
+ IF(HEADER /= ' ')THEN
+ IF(XSZTITB1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,CLEGEND2(1:LEN_TRIM(CLEGEND2)),XSZTITB1,0.,-1.)
+ if(nverbia > 0)then
+ print *,' **tsound CLEGEND2 ',CLEGEND2(1:LEN_TRIM(CLEGEND2))
+ endif
+! CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,CLEGEND2,XSZTITB1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HEADER(1:LEN_TRIM(HEADER)),.007,0.,-1.)
+ if(nverbia > 0)then
+ print *,' **tsound HEADER ',HEADER(1:LEN_TRIM(HEADER))
+ endif
+! CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,HEADER,.007,0.,-1.)
+ ENDIF
+ ENDIF
+!CALL PLCHHQ(0.002,0.005,HEADER,.007,0.,-1.)
+!Mars 2000
+!CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
+CALL SET(.05,.95,.05,.95,-19.0,27.1,0.0,44.061,1)
+CALL GSCLIP(0)
+!print *,' ap GSCLIP'
+CALL PLCHHQ(22.8,-1.,HTEXTE(1:LEN_TRIM(HTEXTE)),.01,0.,1.)
+!CALL WTSTR(-19.,-1.,HEADER(1:60),1,IANGU,-1)
+!!!!CALL WTSTR(22.8,-1.,HTEXTE(1:LEN_TRIM(HTEXTE)),1,IANGU,1)
+!print *,' ap WTSTR '
+
+IF(LRS1 .AND. CTYPE == 'CART')THEN
+ ILENT=SIZE(XTRS,2)
+ ILEN2=2
+ELSE IF(LRS1 .AND. CTYPE == 'RSPL')THEN
+ ILENT=SIZE(XTRS,1)
+ ILEN2=2
+ELSE
+ ILENT=1
+ ILEN2=1
+ENDIF
+
+! Memorisation des tableaux passes en arguments pour les restaurer par la suite
+!DO JJJ=1,INC ! do 1
+! ZWORKS1(JJJ) = PRES(JJJ)
+! ZWORKS2(JJJ) = PTEMP(JJJ)
+! ZWORKS3(JJJ) = PQV(JJJ)
+! ZWORKS4(JJJ) = PU(JJJ)
+! ZWORKS5(JJJ) = PV(JJJ)
+!ENDDO
+
+DO JLOOP2=1,ILEN2
+
+ DO JLOOPT=1,ILENT
+!print *,' Boucle JLOOPT ',JLOOPT
+
+ IF(JLOOP2 == 2 .OR. (JLOOP2 == 1 .AND. LRS1 .AND. JLOOPT >1))THEN
+
+ IF(CTYPE == 'CART')THEN
+
+ CTIMEC(1:LEN(CTIMEC))=' '
+ WRITE(CTIMEC(1:8),'(F8.0)')XTIMRS(JLOOPT)
+ CTIMEC(LEN_TRIM(CTIMEC)+1:LEN_TRIM(CTIMEC)+1)='s'
+ CTIMEC=ADJUSTL(CTIMEC)
+ IF(JLOOP2 == 1)THEN
+ YTEM(1:LEN(YTEM))=' '
+ YTEM=CTIMEC
+ CTIMEC(1:LEN(CTIMEC))=' '
+ YTEM=ADJUSTL(YTEM)
+ IF(NVERBIA > 0)THEN
+ print *,' YTEM ',YTEM
+ ENDIF
+ WRITE(CTIMEC(1:1),'(I1)')JLOOPT
+ CTIMEC(2:2)=' '
+ CTIMEC(1+2:LEN_TRIM(YTEM)+2)=YTEM(1:LEN_TRIM(YTEM))
+ IF(NVERBIA > 0)THEN
+ print *,' CTIMEC ',CTIMEC
+ ENDIF
+ ENDIF
+
+ ELSE IF(CTYPE == 'RSPL')THEN
+
+ CTIMECS(1:LEN(CTIMECS))=' '
+ WRITE(CTIMECS(1:8),'(F8.0)')XTIMRS2(JLOOPT,1)
+ CTIMECS=ADJUSTL(CTIMECS)
+
+ IF(JLOOP2 == 1)THEN
+ YTEM(1:LEN(YTEM))=' '
+ YTEM=CTIMECS(1:LEN_TRIM(CTIMECS))
+ YTEM=ADJUSTL(YTEM)
+ CTIMECS(1:LEN(CTIMECS))=' '
+ IF(NNST(JLOOPT) < 10)THEN
+ IN=1
+ WRITE(CTIMECS(1:IN),'(I1)')NNST(JLOOPT)
+ ELSE IF(NNST(JLOOPT) >= 10 .AND. NNST(JLOOPT) < 100)THEN
+ IN=2
+ WRITE(CTIMECS(1:IN),'(I2)')NNST(JLOOPT)
+ ELSE
+ IN=3
+ WRITE(CTIMECS(1:IN),'(I3)')NNST(JLOOPT)
+ ENDIF
+ IN=IN+1
+ CTIMECS(IN:IN)=' '
+ IN=IN+1
+ II=LEN_TRIM(YTEM)
+ CTIMECS(IN:IN+II-1)=YTEM(1:II)
+ IN=IN+II
+ CTIMECS(IN:IN)='-'
+ IN=IN+1
+ YTEM(1:II)=' '
+ WRITE(YTEM(1:8),'(F8.0)')XTIMRS2(JLOOPT,NST(JLOOPT))
+ YTEM=ADJUSTL(YTEM)
+ II=LEN_TRIM(YTEM)
+ CTIMECS(IN:IN+II-1)=YTEM(1:II)
+ IN=IN+II
+ CTIMECS(IN:IN)='s'
+
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+
+ IF(JLOOP2 == 1 .AND. JLOOPT == 1)THEN
+ IF(LRS1)THEN
+! Cas LRS : CTIMEC est charge necessairement dans OPER_PROCESS
+
+ SELECT CASE(CTYPE)
+
+ CASE('CART')
+ CTIMEC(1:LEN(CTIMEC))=' '
+ CTIMEC(1:3)=' ('
+ WRITE(CTIMEC(4:11),'(F8.0)')XTIMRS(JLOOPT)
+ CTIMEC(LEN_TRIM(CTIMEC)+1:LEN_TRIM(CTIMEC)+2)='s)'
+ CASE('RSPL')
+ CTIMECS(1:LEN(CTIMECS))=' '
+ CTIMECS(1:3)=' ('
+ WRITE(CTIMECS(4:11),'(F8.0)')XTIMRS2(JLOOPT,1)
+ CTIMECS(LEN_TRIM(CTIMECS)+1:LEN_TRIM(CTIMECS)+1)='-'
+ IN=LEN_TRIM(CTIMECS)+1
+ YTEM(1:LEN(YTEM))=' '
+ WRITE(YTEM(1:8),'(F8.0)')XTIMRS2(JLOOPT,NST(JLOOPT))
+ YTEM=ADJUSTL(YTEM)
+ II=LEN_TRIM(YTEM)
+ CTIMECS(IN:IN+II-1)=YTEM(1:II)
+ IN=IN+II
+ CTIMECS(IN:IN+1)='s)'
+
+ END SELECT
+ ENDIF
+
+ II=LEN_TRIM(CLEGEND2)+1
+! print *,' **tsound II,len_trim(header) ',II,LEN_TRIM(HEADER)
+
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ CLEGEND2(II:II+LEN_TRIM(CTIMEC)-1)=CTIMEC(1:LEN_TRIM(CTIMEC))
+ CASE('RSPL')
+ CLEGEND2(II:II+LEN_TRIM(CTIMECS)-1)=CTIMECS(1:LEN_TRIM(CTIMECS))
+ END SELECT
+ if(nverbia > 0)then
+ print *,' **tsound len_trim(clegend2),len_trim(header) ',LEN_TRIM(CLEGEND2),LEN_TRIM(HEADER)
+ endif
+
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+
+! Mars 2000
+! Titre N2 BOTTOM
+ ZXPOSTITB2=.002
+ ZXYPOSTITB2=.025
+ IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ ENDIF
+ IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ ENDIF
+ CALL RESOLV_TIT('CTITB2',CLEGEND2)
+ IF(CLEGEND2 /= ' ')THEN
+ IF(XSZTITB2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2(1:LEN_TRIM(CLEGEND2)),XSZTITB2,0.,-1.)
+! CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,XSZTITB2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2(1:LEN_TRIM(CLEGEND2)),.007,0.,-1.)
+! CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,.007,0.,-1.)
+ ENDIF
+ ENDIF
+! CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
+! Mars 2000
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+!print *,' AP DATFILE2'
+ ENDIF
+
+IF (.NOT.GDOTEMP) GO TO 61
+
+IF(LRS1)THEN
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ IB=IKB ; IE=IKE
+ PRES(:)=XPRS(IB:IE,JLOOPT)
+ PTEMP(:)=XTRS(IB:IE,JLOOPT)
+ PQV(:)=XRVRS(IB:IE,JLOOPT)
+ PU(:)=XURS(IB:IE,JLOOPT)
+ PV(:)=XVRS(IB:IE,JLOOPT)
+ CASE('RSPL')
+ IB=1 ; IE=NST(JLOOPT)
+ IF(ALLOCATED(PRES))THEN
+ DEALLOCATE(PRES)
+ ENDIF
+ IF(ALLOCATED(PTEMP))THEN
+ DEALLOCATE(PTEMP)
+ ENDIF
+ IF(ALLOCATED(PQV))THEN
+ DEALLOCATE(PQV)
+ ENDIF
+ IF(ALLOCATED(PU))THEN
+ DEALLOCATE(PU)
+ ENDIF
+ IF(ALLOCATED(PV))THEN
+ DEALLOCATE(PV)
+ ENDIF
+ ALLOCATE(PRES(IE))
+ ALLOCATE(PTEMP(IE))
+ ALLOCATE(PQV(IE))
+ ALLOCATE(PU(IE))
+ ALLOCATE(PV(IE))
+ PRES(:)=XPRS(JLOOPT,IB:IE)
+ PTEMP(:)=XTRS(JLOOPT,IB:IE)
+ PQV(:)=XRVRS(JLOOPT,IB:IE)
+ PU(:)=XURS(JLOOPT,IB:IE)
+ PV(:)=XVRS(JLOOPT,IB:IE)
+ INC=SIZE(PRES)
+ END SELECT
+ENDIF
+!
+! Avril 99
+!
+IF(JLOOP2 == 1)THEN
+IF(LPRINT)THEN
+ CALL FMLOOK('FICVAL','FICVAL',INUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',INUM,IRESP)
+ OPEN(UNIT=INUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ IF(CGROUP == 'UM' .OR. CGROUP == 'VM' .OR. CGROUP == 'THM' .OR. &
+ CGROUP == 'PABSM' .OR. CGROUP == 'RVM')THEN
+ YGROUP='THM-PABSM-RVM-UM-VM'
+ ELSE
+ YGROUP='THT-PABST-RVT-UT-VT'
+ ENDIF
+ WRITE(INUM,'(''RS '',''G:'',A19,25X,'' T:'',F8.0,''s'','' (1-IKU)'')')YGROUP,&
+& XTIMRS(JLOOPT)
+
+ WRITE(INUM,'(A19,20X,A4,6X,''NBVAL '',I5)')YGROUP,CTYPE,SIZE(XTRS,1)
+ IF(XIRS /= -999.)THEN
+ WRITE(INUM,'(''xirs'',F10.5,'' xjrs'',F10.5)')XIRS,XJRS
+ ELSE
+ WRITE(INUM,'(''nirs'',I5,'' njrs'',I5,'' (grille 1)'')')NIRS,NJRS
+ ENDIF
+ WRITE(INUM,'(1X,78(1H*))')
+! JUin 2001 Ecriture des dates (Demande G.Jaubert ) si LPRDAT=T
+ IF(LPRDAT)THEN
+ IF(.NOT.ALLOCATED(XPRDAT))THEN
+ print *,'**TSOUND XPRDAT NON ALLOUE.Dates non ecrites ds FICVAL .Prevenir J.Duron'
+ ELSE
+ WRITE(INUM,'(1X,75(1H*))')
+ WRITE(INUM,'(1X,'' Dates courante * modele * experience * segment'')')
+ WRITE(INUM,'(1X,'' J An M J Sec. * An M J Sec. * An M J Sec. * An M J Sec.'')')
+ WRITE(INUM,'(1X,75(1H*))')
+ DO J=1,SIZE(XPRDAT,2)
+ WRITE(INUM,'(1X,I3,1X,3(I4,I3,I3,I6,'' *''),I4,I3,I3,I6)')J,INT(XPRDAT(:,J))
+ ENDDO
+ ENDIF
+ ENDIF
+! JUin 2001 Ecriture des dates
+ IF(CGROUP(LEN_TRIM(CGROUP):LEN_TRIM(CGROUP)) == 'M')THEN
+ WRITE(INUM,'(5X,''K'',4X,''* THM_RS * PABSM *'',7X,''RVM'',7X,&
+ &''* UM * VM'')')
+ ELSE
+ WRITE(INUM,'(5X,''K'',4X,''* THT_RS * PABST *'',7X,''RVT'',7X,&
+ &''* UT * VT'')')
+ ENDIF
+ WRITE(INUM,'(1X,78(1H*))')
+ DO J=SIZE(XTRS,1),1,-1
+ IF(J == SIZE(XTRS,1))THEN
+ WRITE(INUM,'(''(IKU)'',I4,'' * '',F7.2,'' * '',F7.0,'' * '',E15.8,'' * '', &
+& F7.2,'' * '',F7.2)')J,XTRS(J,JLOOPT),XPRS(J,JLOOPT), &
+ XRVRS(J,JLOOPT),XURS(J,JLOOPT),XVRS(J,JLOOPT)
+ ELSE
+ WRITE(INUM,'(5X,I4,'' * '',F7.2,'' * '',F7.0,'' * '',E15.8,'' * '',&
+ & F7.2,'' * '',F7.2)')J,XTRS(J,JLOOPT),XPRS(J,JLOOPT), &
+ XRVRS(J,JLOOPT),XURS(J,JLOOPT),XVRS(J,JLOOPT)
+ ENDIF
+ ENDDO
+ WRITE(INUM,'(1X,78(1H*))')
+ CASE('RSPL')
+ WRITE(INUM,'(''RS '',''G:'',A16,28X,'' T:'',F8.0,''s'','' (1-IK)'')')CGROUP, &
+ XTIMRS2(JLOOPT,1)
+ WRITE(INUM,'(''NBVAL '',I5)')SIZE(XTRS,2)
+ WRITE(INUM,'(1X,78(1H*))')
+ WRITE(INUM,'(5X,''K'',4X,''* THT_RS * PABST *'',7X,''RVT'',7X,&
+ & ''* UT * VT'')')
+ WRITE(INUM,'(1X,78(1H*))')
+ DO J=SIZE(XTRS,2),1,-1
+ IF(J == SIZE(XTRS,2))THEN
+ WRITE(INUM,'(''(IK) '',I4,'' * '',F7.2,'' * '',F7.0,'' * '',E15.8,'' * '',&
+ & F7.2,'' * '',F7.2)')XTRS(JLOOPT,J),XPRS(JLOOPT,J), &
+ XRVRS(JLOOPT,J),XURS(JLOOPT,J),XVRS(JLOOPT,J)
+ ELSE
+ WRITE(INUM,'(5X,I4,'' * '',F7.2,'' * '',F7.0,'' * '',E15.8,'' * '',&
+ & F7.2,'' * '',F7.2)')XTRS(JLOOPT,J),XPRS(JLOOPT,J), &
+ XRVRS(JLOOPT,J),XURS(JLOOPT,J),XVRS(JLOOPT,J)
+ ENDIF
+ ENDDO
+ WRITE(INUM,'(1X,78(1H*))')
+ END SELECT
+ENDIF
+ENDIF
+!
+! Avril 99
+!
+!
+!* 3.1.1 Data conversion in mb and g/kg
+!
+DO JJJ=1,INC ! do 1
+ PRES(JJJ) = PRES(JJJ) * 1.E-2
+ PTEMP(JJJ) = PTEMP(JJJ)-273.16
+ IF (OMIXRAT) THEN ! if 1
+ PQV(JJJ) = PQV(JJJ) * 1.E3 ! Mixing ratio used
+ ELSE ! else 1
+ PQV(JJJ) = PQV(JJJ)-273.16 ! Dew point used
+ ENDIF ! endif 1
+ENDDO ! enddo 1
+
+IF(JLOOP2 == 1)THEN !00000000000000
+
+!
+!* 3.1.2 Draws the temperature of state line
+!
+IF(LCOLINE)THEN
+ ! 45. = 44.061/.95*.97
+!Mars 2000
+ IF(ILENT == 1)THEN
+
+ IF(LCOLRSONE)THEN
+ CALL GSPLCI(NCOLRSONE)
+ CALL GSTXCI(NCOLRSONE)
+ CALL GSPMCI(NCOLRSONE)
+ CALL GSFACI(NCOLRSONE)
+ ENDIF
+
+ ELSE
+
+ IF(LCOLRS1ONE)THEN
+ IF(JLOOPT == 1)THEN
+ CALL GSPLCI(NCOLRS1ONE1)
+ CALL GSTXCI(NCOLRS1ONE1)
+ CALL GSPMCI(NCOLRS1ONE1)
+ CALL GSFACI(NCOLRS1ONE1)
+ ELSEIF(JLOOPT == 2)THEN
+ CALL GSPLCI(NCOLRS1ONE2)
+ CALL GSTXCI(NCOLRS1ONE2)
+ CALL GSPMCI(NCOLRS1ONE2)
+ CALL GSFACI(NCOLRS1ONE2)
+ ELSEIF(JLOOPT == 3)THEN
+ CALL GSPLCI(NCOLRS1ONE3)
+ CALL GSTXCI(NCOLRS1ONE3)
+ CALL GSPMCI(NCOLRS1ONE3)
+ CALL GSFACI(NCOLRS1ONE3)
+ ELSEIF(JLOOPT == 4)THEN
+ CALL GSPLCI(NCOLRS1ONE4)
+ CALL GSTXCI(NCOLRS1ONE4)
+ CALL GSPMCI(NCOLRS1ONE4)
+ CALL GSFACI(NCOLRS1ONE4)
+ ELSEIF(JLOOPT == 5)THEN
+ CALL GSPLCI(NCOLRS1ONE5)
+ CALL GSTXCI(NCOLRS1ONE5)
+ CALL GSPMCI(NCOLRS1ONE5)
+ CALL GSFACI(NCOLRS1ONE5)
+ ELSE
+ ENDIF
+
+ ELSE
+!Mars 2000
+ IF(JLOOPT == 2)THEN
+ CALL GSPLCI(2)
+ CALL GSTXCI(2)
+ CALL GSPMCI(2)
+ CALL GSFACI(2)
+ ELSE IF(JLOOPT == 3)THEN
+ CALL GSPLCI(7)
+ CALL GSTXCI(7)
+ CALL GSPMCI(7)
+ CALL GSFACI(7)
+ ELSE IF(JLOOPT == 4)THEN
+ CALL GSPLCI(5)
+ CALL GSTXCI(5)
+ CALL GSPMCI(5)
+ CALL GSFACI(5)
+ ELSE IF(JLOOPT == 5)THEN
+ CALL GSPLCI(4)
+ CALL GSTXCI(4)
+ CALL GSPMCI(4)
+ CALL GSFACI(4)
+ ELSE IF(JLOOPT == 6)THEN
+ CALL GSPLCI(6)
+ CALL GSTXCI(6)
+ CALL GSPMCI(6)
+ CALL GSFACI(6)
+ ELSE
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ CALL GSPMCI(1)
+ CALL GSFACI(1)
+ ENDIF
+!Mars 2000
+ ENDIF
+ ENDIF
+!Mars 2000
+ENDIF
+
+IF(JLOOPT >1)THEN
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ ZX = .05 +(JLOOPT-2)*(.73/6.)
+ CASE('RSPL')
+ ZX = .05 +(JLOOPT-2)*(.73/3.)
+ END SELECT
+ ZY = .985
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ if(nverbia > 0)then
+ PRINT *,'CTIMEC ',CTIMEC(1:LEN_TRIM(CTIMEC)),' JLOOPT ',JLOOPT,ZX,ZY
+ endif
+ CALL PLCHHQ(ZX,ZY,CTIMEC(1:LEN_TRIM(CTIMEC)),.008,0.,-1.)
+ CASE('RSPL')
+ if(nverbia > 0)then
+ PRINT *,'CTIMECS ',CTIMECS(1:LEN_TRIM(CTIMECS)),' JLOOPT ',JLOOPT,ZX,ZY
+ endif
+ CALL PLCHHQ(ZX,ZY,CTIMECS(1:LEN_TRIM(CTIMECS)),.008,0.,-1.)
+ END SELECT
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+! Mars 2000
+ELSE
+! IF(LRS)THEN
+ CALL GQTXCI(IERR,ICOLI)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ CALL RESOLV_TIT('CTITT1',YTEM80)
+ IF(YTEM80 /= ' ' .AND. YTEM80 /= 'DEFAULT')THEN
+ ZXPOSTITT1=.005; ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80(1:LEN_TRIM(YTEM80)),XSZTITT1,0.,-1.)
+! CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80(1:LEN_TRIM(YTEM80)),.012,0.,-1.)
+! CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80,.012,0.,-1.)
+ ENDIF
+
+ ENDIF
+ CALL GSPLCI(ICOLI)
+ CALL GSTXCI(ICOLI)
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+! ENDIF
+! Mars 2000
+ENDIF
+
+CALL SETUSV ('LW',2000) ! Heavy line used for the
+!CALL SETUSV ('IN',10000) ! sounding data
+!
+
+DO J = 1,INC ! do 1
+ IF( PRES(J).LT.100. )EXIT
+ ZY = ZFY(PRES(J))
+ ZX = ZFX(PTEMP(J),ZY)
+ IF(J.EQ.1)CALL FRSTPT(ZX,ZY)
+ CALL VECTOR(ZX,ZY)
+ENDDO ! enddo 1
+
+CALL SFLUSH
+!print *,' AP CALL SFLUSH'
+IF(JLOOPT > 1 .AND. .NOT. LCOLINE)THEN
+ CALL GSLWSC(1.)
+ CALL GSLN(3) ! Sets dotted line mode
+ CALL VECTOR(ZX,ZY+.5*JLOOPT)
+ CALL SFLUSH
+ CALL GSLN(1)
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ IF(JLOOPT <10)THEN
+ WRITE(YC1,'(I1)')JLOOPT
+ IN=1
+ ELSE
+ WRITE(YC2,'(I2)')JLOOPT
+ IN=2
+ ENDIF
+ CASE('RSPL')
+ IF(NNST(JLOOPT) <10)THEN
+ WRITE(YC1,'(I1)')NNST(JLOOPT)
+ IN=1
+ ELSE
+ WRITE(YC2,'(I2)')NNST(JLOOPT)
+ IN=2
+ ENDIF
+ END SELECT
+
+ IF(IN == 1)THEN
+ CALL PLCHHQ(ZX,ZY+.7*JLOOPT,YC1,.008,0.,0.)
+ ELSE
+ CALL PLCHHQ(ZX,ZY+.7*JLOOPT,YC2,.008,0.,0.)
+ ENDIF
+
+ CALL GSLWSC(2.)
+
+ENDIF
+!
+!* 3.1.3 Draws dewpoint as function of pressure
+!
+!CALL GSLN(3) ! Sets dotted line mode
+!
+IF(OMXRAT)THEN
+!
+ DO J = 1,INC ! do 1
+ IF(PTEMP(J).LE.-40.)EXIT
+ ZY = ZFY(PRES(J))
+ IF (OMIXRAT) THEN ! Converts mixing ratio to
+ ZDWPT = DEWP( PQV(J),PRES(J) ) ! dewpoint temperature
+ ELSE
+ ZDWPT = PQV(J) ! No conversion necessary here
+ END IF
+ ZX = ZFX(ZDWPT,ZY)
+! IF(J.EQ.1)CALL FRSTPT(ZX,ZY)
+! CALL VECTOR(ZX,ZY)
+ IF(J == 1)THEN
+ INEG=0
+ CALL FRSTPT(ZX,ZY)
+ IF(PQV(J) <= 0.)INEG=1
+ IF(PQV(J) > 0.)CALL VECTOR(ZX,ZY)
+ ELSE
+ IF(PQV(J) <= 0.)THEN
+ INEG=1
+ CALL FRSTPT(ZX,ZY)
+ ELSE
+ SELECT CASE(INEG)
+ CASE(0)
+ CALL VECTOR(ZX,ZY)
+ CASE(1)
+ CALL FRSTPT(ZX,ZY)
+ CALL VECTOR(ZX,ZY)
+ INEG=0
+ END SELECT
+ IF(MOD(J,4) == 0)THEN
+ CALL GSMK(2)
+ CALL GPM(1,ZX,ZY)
+ ENDIF
+ END IF
+ END IF
+ ENDDO ! enddo 1
+!
+IF(JLOOPT > 1 .AND. .NOT. LCOLINE)THEN
+ CALL GSLWSC(1.)
+ CALL GSLN(3)
+ CALL VECTOR(ZX+1.5,ZY+.7*JLOOPT)
+ CALL SFLUSH
+ WRITE(YC1,'(I1)')JLOOPT
+ CALL GSLN(1)
+ CALL PLCHHQ(ZX,ZY+.5*JLOOPT,YC1,.008,0.,0.)
+ CALL GSLWSC(2.)
+ENDIF
+END IF
+!
+CALL SFLUSH
+!print *,' AP CALL SFLUSH2'
+IF(LCOLINE)THEN
+ IF(JLOOPT == 2)THEN
+ ELSE IF(JLOOPT == 3)THEN
+ ELSE IF(JLOOPT == 4)THEN
+ ELSE IF(JLOOPT == 5)THEN
+ ELSE IF(JLOOPT == 6)THEN
+ ELSE
+ ENDIF
+ CALL GSPLCI(1)
+ CALL GSPMCI(1)
+ CALL GSTXCI(1)
+ CALL GSFACI(1)
+ENDIF
+
+CALL GSLN(1) ! Restores solid line
+
+
+ENDIF !00000000000000
+!
+ 61 CONTINUE
+!
+IF(LRS1 .AND. JLOOP2 == 1 .AND. JLOOPT >1)THEN
+ GDOUV=.FALSE.
+ELSE
+ GDOUV=GDOUVM
+ENDIF
+!
+!
+!* 3.2 Plots wind vectors
+!
+IF(.NOT.GDOUV)GO TO 66
+!
+!* 3.2.1 Sets arrow scale
+!
+ZVSCALE=SQRT(PU(1)*PU(1)+PV(1)*PV(1))
+! print *,' ZVSCALE ',ZVSCALE
+DO JJJ=1,INC ! do 1
+! ZWORKS1(JJJ) = PRES(JJJ)
+! ZWORKS2(JJJ) = PTEMP(JJJ)
+! ZWORKS3(JJJ) = PQV(JJJ)
+! ZWORKS4(JJJ) = PU(JJJ)
+! ZWORKS5(JJJ) = PV(JJJ)
+ ZVVMAX=SQRT(PU(JJJ)*PU(JJJ)+PV(JJJ)*PV(JJJ))
+ IF (ZVVMAX.GT.ZVSCALE) ZVSCALE=ZVVMAX
+! print *,' JJJ ZVSCALE ',JJJ,ZVSCALE
+! PRES(JJJ) = PRES(JJJ) * 1.E-2
+ENDDO ! enddo 1
+!
+if(nverbia >0)then
+print *,' AV CALL ECHELLE'
+endif
+CALL PCSETC('FC',':')
+CALL ECHELLE(ILEN,ZHA) ! Sets arrow size
+CALL PCSETC('FC','/')
+!
+if(nverbia >0)then
+print *,' AP CALL ECHELLE'
+endif
+IF(JLOOP2 == 2)THEN
+ IF(JLOOPT == 1)THEN
+! print *,' ILENT ',ILENT
+ ZINT=(22.5 - (-14.4))/(ILENT-1)
+ ENDIF
+ ZXM=-14.4+(JLOOPT-1)*ZINT
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ CALL PLCHHQ(ZXM-1.8,43.,CTIMEC(1:LEN_TRIM(CTIMEC)),.009,0.,-1.)
+ CASE('RSPL')
+ IF(MOD(JLOOPT,2) /= 0)THEN
+ CALL PLCHHQ(ZXM-1.8,43.,CTIMECS(1:LEN_TRIM(CTIMECS)),.009,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXM-1.8,42.,CTIMECS(1:LEN_TRIM(CTIMECS)),.009,0.,-1.)
+ ENDIF
+ END SELECT
+ELSE
+ ZXM=22.5
+ ZINT=1.
+ENDIF
+if(nverbia >0)then
+print *,' ZXM ZINT ',ZXM,ZINT
+endif
+CALL LINE(ZXM,0.0,ZXM,44.061) ! Draws a vertical line for wind display
+CALL SFLUSH
+!
+!!!!!CALL SETUSV('LW',1000)
+!
+!* 3.2.2 Optional arrow sampling
+!
+! Only when winds are displayed, computes the distance between
+! two adjacent arrows if the arrow number is limited to IMXSMPLUV
+!
+IF (OSAMPLEUV) THEN ! if 1
+ ZDYSMPL=44.061/FLOAT(IMXSMPLUV-1)
+ELSE ! else 1
+ ZDYSMPL=0.
+ENDIF ! endif 1
+ZYSMPL=-ZFY(PRES(1))
+!
+!* 3.3.3 Plots the vectors
+!
+CALL GSLWSC(2.) ! Sets heavy line
+!
+#ifdef O2000
+CALL VVSETI('CPM',2 )
+!CALL VVSETR('AMX',.05 )
+!CALL VVSETR('AMN',.005 )
+#endif
+DO J = 1,INC ! do 1
+!DO J = 1,KNN ! do 1
+ IF( PRES(J).LT.100. )GO TO 66
+ ZY1 = ZFY(PRES(J)) ! Locates arrow at the relevant pressure level
+ IF(J.GT.1.AND.(OSAMPLEUV.AND.(ZY1-ZYSMPL.LT.ZDYSMPL)))CYCLE
+! print *,' ZY1 ',ZY1
+! print *,' AVV FLECHE'
+ CALL FLECHE(ZXM,ZY1,PU(J),PV(J),ILEN,ZHA)
+! print *,' AP FLECHE ZXM,ZY1 ',ZXM,ZY1
+ ZYSMPL=ZY1
+ENDDO ! enddo 1
+!
+ 66 CONTINUE
+if(nverbia >0)then
+print *,' AP 66'
+endif
+!
+CALL GSLWSC(1.) !Restores initial line width
+!
+!
+!-----------------------------------------------------------------------------
+!
+!* 4. NORMAL EXIT
+! -----------
+!
+IF (ODOFRAME) CALL FRAME ! FRAME issued if required
+
+ ENDDO ! Fin DO JLOOPT
+
+ IF(LRS1 .AND. JLOOP2 == 1)THEN
+ CALL FRAME
+ CALL SET(.05,.95,.05,.95,-19.0,27.1,0.0,44.061,1)
+ CALL FRSTPT(-19.,0.)
+ CALL VECTOR(-19.,44.061)
+ CALL VECTOR(27.1,44.061)
+ CALL VECTOR(27.1,0.)
+ CALL VECTOR(-19.,0.)
+ CALL GSCLIP(0)
+ CALL PLCHHQ(-19.,-1.,HTEXTE(1:LEN_TRIM(HTEXTE)),.010,0.,-1.)
+!! CALL GSCLIP(1)
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+!Mars 2000 Altitudes IKB IKE grille de masse
+ IF(CTYPE == 'CART')THEN
+ ENDIF
+!Mars 2000
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+if(nverbia >0)then
+print *,' AP DATFILE'
+endif
+!Mars 2000
+ CALL RESOLV_TIT('CTITT1',YTEM80)
+ IF(YTEM80 /= ' ' .AND. YTEM80 /= 'DEFAULT')THEN
+
+ ZXPOSTITT1=.005; ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80(1:LEN_TRIM(YTEM80)),XSZTITT1,0.,-1.)
+! CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80(1:LEN_TRIM(YTEM80)),.012,0.,-1.)
+! CALL PLCHHQ(ZXPOSTITT1,ZXYPOSTITT1,YTEM80,.012,0.,-1.)
+ ENDIF
+
+ ENDIF
+!Mars 2000
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,ID)
+ ENDIF
+! DO JJJ=1,INC ! do 1
+! PRES(JJJ) = ZWORKS1(JJJ)
+! PTEMP(JJJ) = ZWORKS2(JJJ)
+! PQV(JJJ) = ZWORKS3(JJJ)
+! PU(JJJ) = ZWORKS4(JJJ)
+! PV(JJJ) = ZWORKS5(JJJ)
+! ENDDO ! enddo 1
+
+ENDDO ! Fin DO JLOOP2
+!
+if(nverbia >0)then
+print *,' AV RETURN '
+endif
+!
+CALL PCSETC('FC',Y1)
+RETURN
+!
+!-----------------------------------------------------------------------------
+!
+!* 5. ARRAY OVERFLOW CONTROL
+! ----------------------
+! Notice:
+! This section has been implemented to conform to
+! the former TRACE implentation. It is not called
+! in the present TRACE implementation.
+!
+!* 5.1 Test on T and moisture array sizes
+!
+ ENTRY TSOUNDTD (PPRES,PPTEMP,PPQV,PPU,PPV,KNN,HEADER, OMIXRAT, ODOFRAME)
+!
+INC=KNN !00000000 nn <=> nwk 0000000000
+!
+IF(KNN.GT.JPNWK)THEN
+ PRINT *,' Emagram TSOUNDTD: too much data points requested'
+ PRINT *,' NN=',KNN,' when maximum allowed is ',JPNWK,', return.'
+RETURN
+ENDIF
+!
+GDOTEMP=.TRUE.
+GDOUV=.FALSE.
+GO TO 111
+!
+!* 5.2 Test on wind array sizes
+!
+ ENTRY TSOUNDUV (PPRES,PPTEMP,PPQV,PPU,PPV,KNN,HEADER, OMIXRAT, ODOFRAME)
+!
+INC=KNN !00000000 nn <=> nwk 0000000000
+!
+IF(KNN.GT.JPNWK)THEN
+ PRINT *,' Emagram TSOUNDUV: too much data points requested'
+ PRINT *,' NN=',KNN,' when maximum allowed is ',JPNWK,', return.'
+RETURN
+ENDIF
+!
+GDOTEMP=.FALSE.
+GDOUV=.TRUE.
+GO TO 111
+!
+!----------------------------------------------------------------------------
+!
+!* 6. EXIT
+! ----
+!
+END SUBROUTINE TSOUND_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/varfct.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/varfct.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8e79923771cf4aae4abc776ce25524e4569ab40c
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/varfct.f90
@@ -0,0 +1,4328 @@
+! ######spl
+ MODULE MODI_VARFCT
+! ##################
+!
+INTERFACE
+!
+SUBROUTINE VARFCT(PWORKT,PWORK1D,K)
+REAL,DIMENSION(:) :: PWORKT,PWORK1D
+INTEGER :: K
+END SUBROUTINE VARFCT
+!
+END INTERFACE
+END MODULE MODI_VARFCT
+! ######spl
+ SUBROUTINE VARFCT(PWORKT,PWORK1D,K)
+! ###################################
+!
+!!**** *VARFCT* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 24/11/95
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+#ifdef NAGf95
+USE F90_UNIX ! for FLUSH and GETENV
+#endif
+USE MODD_RESOLVCAR
+USE MODD_TYPE_AND_LH
+USE MODD_ALLOC_FORDIACHRO
+USE MODN_NCAR
+USE MODN_PARA
+USE MODD_TIT
+USE MODD_DEFCV
+USE MODD_TITLE
+USE MODD_CTL_AXES_AND_STYL
+USE MODI_READMNMX_FT_PVKT
+USE MODI_READCOL_FT_PVKT
+USE MODI_LOADMNMX_FT_PVKT
+!
+USE MODI_WRITEDIR
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+REAL,DIMENSION(:) :: PWORKT
+REAL,DIMENSION(:) :: PWORK1D
+INTEGER :: K
+!
+!* 0.1 Local variables
+! ---------------
+
+INTEGER :: J,JJ, JI, JD, JF, JE, JJE, J2
+INTEGER :: JA, JAF,IDA, JH
+INTEGER :: JGP, JGPA
+INTEGER :: JB, JC, ISUIT, ISUI
+INTEGER :: IC, ID, ILR
+INTEGER :: INDISTM, ISTOK, ILN
+INTEGER,SAVE :: INDN, ITOT, IND, INB
+INTEGER :: INUM, IPAGE, IREST, ICOMPT=0
+INTEGER :: IER, ITYP, ILGRP, ILYGRP, ICOL
+INTEGER,SAVE :: ICOL1, ICOL2
+INTEGER,SAVE :: ISUPERDIA
+INTEGER,SAVE :: IINUM, IRESP
+INTEGER :: IBPM, ISLN, ISLNFT1=0, ISLNFT2=0
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: ICOMPTSZ, ITEM, IST, ISTM
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: IBRECOUV
+INTEGER,DIMENSION(:,:),ALLOCATABLE,SAVE :: IRECOUV
+INTEGER,DIMENSION(:,:),ALLOCATABLE,SAVE :: IWORK
+INTEGER,SAVE :: IBC, IBCP, INCR !3 courbes par diagramme (bornes identiques)
+#ifdef RHODES
+INTEGER :: ISTAF
+#endif
+
+REAL,SAVE :: ZBOT, ZTOP, ZDEBY, ZDEBYB, ZDEBYT,ZBOTB
+REAL :: ZMIN, ZMAX
+REAL,SAVE :: ZVL, ZVR, ZVB, ZVT
+REAL,SAVE :: ZWL, ZWR, ZWB, ZWT
+REAL,SAVE :: ZWLL, ZWRR, ZWBB, ZWTT
+REAL :: ZX, ZY, ZINT, ZWIDTH
+REAL :: ZW1, ZW2, ZW3, ZW4
+REAL,SAVE :: EPAIS
+REAL,SAVE :: ZE36
+REAL :: ZLW
+REAL :: ZXPOSTITT3, ZXYPOSTITT3
+REAL :: ZXPOSTITT2, ZXYPOSTITT2
+REAL :: ZXPOSTITT1, ZXYPOSTITT1
+REAL :: ZXPOSTITB3, ZXYPOSTITB3
+REAL :: ZXPOSTITB2, ZXYPOSTITB2
+REAL :: ZXPOSTITB1, ZXYPOSTITB1
+REAL :: ZCONSTIM
+REAL,DIMENSION(2):: ZX2, ZY2
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZWORK1D, ZWORKT
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZWORK, ZPVMNMX
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZWT1, ZWT2
+
+CHARACTER(LEN=10) :: FORMAX, FORMAY
+CHARACTER(LEN=8) :: YCAR8
+CHARACTER(LEN=30),DIMENSION(:),ALLOCATABLE,SAVE :: YGROUP, YGTEM
+CHARACTER(LEN=68) :: YCARCOU, YTEM, YCAR
+CHARACTER(LEN=20),SAVE :: YCAR20
+CHARACTER(LEN=80) :: YCAR80
+CHARACTER(LEN=30) :: YCAR30
+CHARACTER(LEN=100),SAVE :: YDIFF=' '
+!CHARACTER(LEN=3),SAVE :: YREP, YREPO
+CHARACTER(LEN=5) :: YC5
+CHARACTER(LEN=2),DIMENSION(:),ALLOCATABLE,SAVE :: YK, YKTEM
+CHARACTER(LEN=30) :: YGP
+
+!
+!------------------------------------------------------------------------------
+ZE36=1.E36
+YCARCOU(1:LEN(YCARCOU))=' '
+YCAR(1:LEN(YCAR))=' '
+
+IF(LPBREAD)THEN
+ IF(ALLOCATED(ZWORK1D))THEN
+ DEALLOCATE(ZWORK1D)
+ ENDIF
+ IF(ALLOCATED(ZWORKT))THEN
+ DEALLOCATE(ZWORKT)
+ ENDIF
+ IF(ALLOCATED(YGROUP))THEN
+ DEALLOCATE(YGROUP)
+ ENDIF
+ IF(ALLOCATED(ICOMPTSZ))THEN
+ DEALLOCATE(ICOMPTSZ)
+ ENDIF
+ IF(ALLOCATED(IST))THEN
+ DEALLOCATE(IST)
+ ENDIF
+ IF(ALLOCATED(IBRECOUV))THEN
+ DEALLOCATE(IBRECOUV)
+ ENDIF
+ IF(ALLOCATED(IRECOUV))THEN
+ DEALLOCATE(IRECOUV)
+ ENDIF
+ ICOMPT=0
+ RETURN
+ENDIF
+IF(LCOLINE)CALL TABCOL_FORDIACHRO
+
+
+IF(LPRINT)THEN
+ CALL FMLOOK('FICVAL','FICVAL',IINUM,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMATTR('FICVAL','FICVAL',IINUM,IRESP)
+ OPEN(UNIT=IINUM,FILE='FICVAL',FORM='FORMATTED')
+ PRINT '('' LPRINT=T --> Les valeurs seront mises dans le fichier FICVAL '')'
+ ENDIF
+ YC5=' '
+ IF(LFT1)THEN
+ YC5=' FT1 '
+ ELSE IF(LFT)THEN
+ YC5=' FT '
+ ELSE IF(LPVKT)THEN
+ YC5='PVKT '
+ ELSE IF(LPVKT1)THEN
+ YC5='PVKT1'
+ ENDIF
+ IF(LFT .OR. LFT1)THEN
+ WRITE(IINUM,'(''VARFCT '',A5,'' G:'',A16,'' P:'',A30,'' NBVAL:'',I7&
+& )')YC5,CGROUP,CTITGAL(1:30),SIZE(PWORK1D)
+ ELSE
+ WRITE(IINUM,'(''VARFCT '',A5,'' G:'',A16,'' P:'',A30,'' K:'',I4&
+& )')YC5,CGROUP,CTITGAL(1:30),K
+ ENDIF
+ IF(LPLUS .OR.LMINUS)THEN
+ IF(LFT .OR. LFT1)THEN
+ WRITE(IINUM,'(A60,A4)')CTITB3(1:60),CTYPE
+ ELSE
+ WRITE(IINUM,'(A60,A4,'' NBVAL:'',I7)')CTITB3(1:60),CTYPE,SIZE(PWORK1D)
+ ENDIF
+ ELSE
+ IF(LFT .OR. LFT1)THEN
+ WRITE(IINUM,'(A40,A4)')CTITGAL,CTYPE
+ ELSE
+ WRITE(IINUM,'(A40,A4,'' NBVAL:'',I7)')CTITGAL,CTYPE,SIZE(PWORK1D)
+ ENDIF
+ ENDIF
+ IF(CTYPE == 'CART' .AND. .NOT.L1DT .AND. .NOT.LFT .AND. .NOT.LFT1)THEN
+ WRITE(IINUM,'(''nidebcou'',i4,'' njdebcou'',i4,'' nlmax'',i5,'' nlangle'',i4,&
+& '' profile'',i4)')NIDEBCOU,NJDEBCOU,NLMAX,NLANGLE,NPROFILE
+ ENDIF
+! JUin 2001 Ecriture des dates (Demande G.Jaubert ) si LPRDAT=T
+ IF(LPRDAT)THEN
+ IF(.NOT.ALLOCATED(XPRDAT))THEN
+ print *,'**VARFCT XPRDAT NON ALLOUE.Dates non ecrites ds FICVAL .Prevenir J.Duron'
+ ELSE
+ WRITE(IINUM,'(1X,75(1H*))')
+ WRITE(IINUM,'(1X,'' Dates courante * modele * experience * segment'')')
+ WRITE(IINUM,'(1X,'' J An M J Sec. * An M J Sec. * An M J Sec. * An M J Sec.'')')
+ WRITE(IINUM,'(1X,75(1H*))')
+ DO J=1,SIZE(XPRDAT,2)
+ WRITE(IINUM,'(1X,I3,1X,3(I4,I3,I3,I6,'' *''),I4,I3,I3,I6)')J,iNT(XPRDAT(:,J))
+ ENDDO
+ ENDIF
+ ENDIF
+! JUin 2001 Ecriture des dates
+ WRITE(IINUM,'(1X,45(1H*))')
+ WRITE(IINUM,'('' '',10X,''TIME'',18X,''VAL'')')
+ WRITE(IINUM,'(1X,45(1H*))')
+ DO J=1,SIZE(PWORK1D)
+ WRITE(IINUM,'(I5,4X,E15.8,4X,E15.8)')J,PWORKT(J),PWORK1D(J)
+ ENDDO
+ WRITE(IINUM,'(1X,45(1H*))')
+ENDIF
+
+!*****************************************************************************
+!****************** Debut LFT1 ***********************************************
+!*****************************************************************************
+
+IF(LFT1)THEN
+
+ ICOMPT=ICOMPT+1
+ IF(ICOMPT == 1)THEN
+! On suppose meme longueur temps
+!24052000
+! IF(LMINUS .OR. LPLUS)THEN
+!24052000
+!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!!!
+ IBPM=0
+ DO J=1,NBPM
+ IF(NUMPM(J) == 1 .OR. NUMPM(J) == 2)THEN
+ IBPM=IBPM+1
+ ENDIF
+ ENDDO
+!24052000
+ IF(IBPM /= 0)THEN
+!24052000
+ ISUPERDIA=NSUPERDIA-(IBPM)
+! ISUPERDIA=NSUPERDIA-(NBPM-1)
+!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!!!
+! ISUPERDIA=NSUPERDIA-1
+ ELSE
+ ISUPERDIA=NSUPERDIA
+ ENDIF
+ ALLOCATE(ZWORK1D(SIZE(PWORK1D),ISUPERDIA))
+ ALLOCATE(ZWORKT(SIZE(PWORKT),ISUPERDIA))
+ ALLOCATE(YGROUP(ISUPERDIA))
+ ALLOCATE(ICOMPTSZ(ISUPERDIA))
+ ALLOCATE(IST(ISUPERDIA))
+ ALLOCATE(IBRECOUV(ISUPERDIA))
+ ALLOCATE(IRECOUV(NBRECOUV*2,ISUPERDIA))
+ ICOMPTSZ(ICOMPT)=SIZE(PWORKT)
+ IST(ICOMPT)=NLOOPN
+ IBRECOUV(ICOMPT)=NBRECOUV
+ DO J=1,NBRECOUV
+ IRECOUV(J*2-1,ICOMPT)=NRECOUV(J*2-1)
+ IRECOUV(J*2,ICOMPT)=NRECOUV(J*2)
+ ENDDO
+ ZWORKT(:,ICOMPT)=PWORKT(:)
+ ZWORK1D(:,ICOMPT)=PWORK1D(:)
+ YGROUP(ICOMPT)=CTITGAL
+ IF(LMINUS .OR. LPLUS)THEN
+ print *,' ** varfct LMINUS or LPLUS=T , CTITGAL , CTITB3 ',CTITGAL(1:LEN_TRIM(CTITGAL))
+ print *,CTITB3(1:LEN_TRIM(CTITB3))
+ print *,' Le titre est mis a DIFF '
+ YGROUP(ICOMPT)=' '
+ YGROUP(ICOMPT)='DIFF '
+ YDIFF(1:LEN(YDIFF))=' '
+ IF(CTITB3 /= ' ')THEN
+ YDIFF=ADJUSTL(CTITB3(1:LEN_TRIM(CTITB3)))
+ YDIFF=ADJUSTL(YDIFF)
+ ENDIF
+ print *,'YDIFF ** ',YDIFF
+ ENDIF
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+ ELSE
+
+ IBRECOUV(ICOMPT)=NBRECOUV
+ ILR=NBRECOUV*2
+ IF(ILR <= MAXVAL(IBRECOUV(1:ICOMPT-1))*2)THEN
+ DO J=1,ILR
+ IRECOUV(J,ICOMPT)=NRECOUV(J)
+ ENDDO
+ ELSE
+ ALLOCATE(IWORK(ILR,ISUPERDIA))
+ DO J=1,ICOMPT-1
+ IWORK(1:IBRECOUV(J)*2,J)=IRECOUV(1:IBRECOUV(J)*2,J)
+ ENDDO
+ IWORK(1:ILR,ICOMPT)=NRECOUV(1:ILR)
+ DEALLOCATE(IRECOUV)
+ ALLOCATE(IRECOUV(ILR,ISUPERDIA))
+ IRECOUV(:,:)=IWORK(:,:)
+ DEALLOCATE(IWORK)
+ ENDIF
+ ICOMPTSZ(ICOMPT)=SIZE(PWORKT)
+ IST(ICOMPT)=NLOOPN
+ IC=ICOMPTSZ(ICOMPT)
+ if(nverbia > 0)then
+ print *,' varfct ICOMPT,IC,ICOMPTSZ(ICOMPT) ',ICOMPT,IC,ICOMPTSZ(ICOMPT)
+ endif
+ IF(IC <= MAXVAL(ICOMPTSZ(1:ICOMPT-1)))THEN
+ ZWORK1D(1:IC,ICOMPT)=PWORK1D(:)
+ ZWORKT(1:IC,ICOMPT)=PWORKT(:)
+ ELSE
+ ALLOCATE(ZWORK(IC,ISUPERDIA))
+ DO J=1,ICOMPT-1
+ ZWORK(1:ICOMPTSZ(J),J)=ZWORK1D(1:ICOMPTSZ(J),J)
+ ENDDO
+ ZWORK(1:IC,ICOMPT)=PWORK1D(:)
+ DEALLOCATE(ZWORK1D)
+ ALLOCATE(ZWORK1D(IC,ISUPERDIA))
+ ZWORK1D(:,:)=ZWORK(:,:)
+ DO J=1,ICOMPT-1
+ ZWORK(1:ICOMPTSZ(J),J)=ZWORKT(1:ICOMPTSZ(J),J)
+ ENDDO
+ ZWORK(1:IC,ICOMPT)=PWORKT(:)
+ DEALLOCATE(ZWORKT)
+ ALLOCATE(ZWORKT(IC,ISUPERDIA))
+ ZWORKT(:,:)=ZWORK(:,:)
+ DEALLOCATE(ZWORK)
+ ENDIF
+ YGROUP(ICOMPT)=CTITGAL
+ IF(LMINUS .OR. LPLUS)THEN
+ print *,' ** varfct LMINUS or LPLUS=T , CTITGAL , CTITB3 ',CTITGAL(1:LEN_TRIM(CTITGAL))
+ print *,CTITB3(1:LEN_TRIM(CTITB3))
+ print *,' Le titre est mis a DIFF '
+ YGROUP(ICOMPT)=' '
+ YGROUP(ICOMPT)='DIFF '
+ YDIFF(1:LEN(YDIFF))=' '
+ IF(CTITB3 /= ' ')THEN
+ YDIFF=ADJUSTL(CTITB3(1:LEN_TRIM(CTITB3)))
+ YDIFF=ADJUSTL(YDIFF)
+ ENDIF
+ print *,'YDIFF ** ',YDIFF
+ ENDIF
+! YGROUP(ICOMPT)=CGROUP
+ ENDIF
+ !
+ IF(ICOMPT < ISUPERDIA)THEN
+ RETURN
+ ELSE
+
+ ITOT=0
+ DO J=1,ICOMPT
+ ITOT=ITOT+ICOMPTSZ(J)
+ ENDDO
+ ALLOCATE(ZWT1(ITOT))
+ ID=0
+ DO J=1,ICOMPT
+ IC=ICOMPTSZ(J)
+ ZWT1(ID+1:ID+IC)=ZWORK1D(1:IC,J)
+ ID=IC+ID
+ ENDDO
+! mai 2000
+ IF(LSPVALT)THEN
+ WHERE(ZWT1 == XSPVALT)
+ ZWT1=ZE36
+ ENDWHERE
+ ENDIF
+! mai 2000
+
+! Mai 2000
+ IF(LSPVALT)THEN
+ DO JH=1,SIZE(ZWT1)
+ IF(ZWT1(JH) /= ZE36)THEN
+ ZMIN=ZWT1(JH)
+ ZMAX=ZWT1(JH)
+ EXIT
+ ENDIF
+ ENDDO
+ DO JH=1,SIZE(ZWT1)
+ IF(ZWT1(JH) /= ZE36)THEN
+ ZMIN=MIN(ZMIN,ZWT1(JH))
+ ZMAX=MAX(ZMAX,ZWT1(JH))
+ ENDIF
+ ENDDO
+ ELSE
+! Mai 2000
+
+ ZMIN=MINVAL(ZWT1)
+ ZMAX=MAXVAL(ZWT1)
+! Mai 2000
+ ENDIF
+! Mai 2000
+ print *,' FT1 ZMIN,ZMAX TROUVES : ',ZMIN,ZMAX
+! ZMIN=MINVAL(ZWORK1D)
+! ZMAX=MAXVAL(ZWORK1D)
+ IF(LMNMXUSER)THEN
+ IF(ISUPERDIA == 1)THEN
+ CALL READMNMX_FT_PVKT(CTITGAL(1:LEN_TRIM(CTITGAL)),ZMIN,ZMAX)
+ IF(LOK)THEN
+ LOK=.FALSE.
+ ELSE
+! Mai 2000
+ IF(LSPVALT)THEN
+ DO JH=1,SIZE(ZWT1)
+ IF(ZWT1(JH) /= ZE36)THEN
+ ZMIN=ZWT1(JH)
+ ZMAX=ZWT1(JH)
+ EXIT
+ ENDIF
+ ENDDO
+ DO JH=1,SIZE(ZWT1)
+ IF(ZWT1(JH) /= ZE36)THEN
+ ZMIN=MIN(ZMIN,ZWT1(JH))
+ ZMAX=MAX(ZMAX,ZWT1(JH))
+ ENDIF
+ ENDDO
+ ELSE
+! Mai 2000
+ ZMIN=MINVAL(ZWT1)
+ ZMAX=MAXVAL(ZWT1)
+! Mai 2000
+ ENDIF
+! Mai 2000
+ IF(.NOT.LFT1BAUTO)THEN
+ CALL VALMNMX(ZMIN,ZMAX)
+ IF(ABS(ZMAX-ZMIN) <= 1.E-3)THEN
+ ZMIN=ZMIN-1.
+ ZMAX=ZMAX+1.
+ ENDIF
+ ELSE
+ IF(ABS(ZMAX-ZMIN) == 0.)THEN
+ ZMIN=ZMIN-2.5*TINY(1.)
+ ZMAX=ZMAX+2.5*TINY(1.)
+ ENDIF
+ ENDIF
+ ENDIF
+
+ ELSE
+ IF(XFT1MAX - XFT1MIN /= 0.)THEN
+ ZMIN=XFT1MIN; ZMAX=XFT1MAX
+ ELSE
+ IF(.NOT.LFT1BAUTO)THEN
+ CALL VALMNMX(ZMIN,ZMAX)
+ IF(ABS(ZMAX-ZMIN) <= 1.E-3)THEN
+ ZMIN=ZMIN-1.
+ ZMAX=ZMAX+1.
+ ENDIF
+ ELSE
+ IF(ABS(ZMAX-ZMIN) == 0.)THEN
+ ZMIN=ZMIN-2.5*TINY(1.)
+ ZMAX=ZMAX+2.5*TINY(1.)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE
+ IF(.NOT.LFT1BAUTO)THEN
+ CALL VALMNMX(ZMIN,ZMAX)
+ IF(ABS(ZMAX-ZMIN) <= 1.E-3)THEN
+ ZMIN=ZMIN-1.
+ ZMAX=ZMAX+1.
+ ENDIF
+ ELSE
+ IF(ABS(ZMAX-ZMIN) == 0.)THEN
+ ZMIN=ZMIN-2.5*TINY(1.)
+ ZMAX=ZMAX+2.5*TINY(1.)
+ ENDIF
+ ENDIF
+
+ ENDIF
+ print *,' FT1 BORNES EFFECTIVEMENT UTILISEES ',ZMIN,ZMAX
+
+ ZVL=.13
+ ZVR=.9
+ ZVB=.1
+ ZVT=.9
+!!!!!!!!!!!!!!!
+ IF(LVPTFT1USER)THEN
+ ZVL=XVPTFT1L
+ ZVR=XVPTFT1R
+ ZVB=XVPTFT1B
+ ZVT=XVPTFT1T
+ ENDIF
+!!!!!!!!!!!!!!!
+ ZWT1(:)=0.
+ ID=0
+ DO J=1,ICOMPT
+ ZCONSTIM=0
+ IF(MOD(J,8) == 1)THEN
+ ZCONSTIM=XFT_ADTIM1
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.1 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM1 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 2)THEN
+ ZCONSTIM=XFT_ADTIM2
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.2 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM2 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 3)THEN
+ ZCONSTIM=XFT_ADTIM3
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.3 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM3 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 4)THEN
+ ZCONSTIM=XFT_ADTIM4
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.4 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM4 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 5)THEN
+ ZCONSTIM=XFT_ADTIM5
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.5 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM5 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 6)THEN
+ ZCONSTIM=XFT_ADTIM6
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.6 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM6 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 7)THEN
+ ZCONSTIM=XFT_ADTIM7
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.7 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM7 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 0)THEN
+ ZCONSTIM=XFT_ADTIM8
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.8 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM8 a zero'
+ ENDIF
+ ENDIF
+
+ IC=ICOMPTSZ(J)
+ ZWORKT(1:IC,J)=ZWORKT(1:IC,J)+ZCONSTIM
+ ZWT1(ID+1:ID+IC)=ZWORKT(1:IC,J)
+ ID=IC+ID
+ ENDDO
+ ZWL=MINVAL(ZWT1)
+ ZWR=MAXVAL(ZWT1)
+! Mai 2000
+ IF(LTIMEUSER)THEN
+ ZWL=XTIMEMIN
+ ZWR=XTIMEMAX
+ ENDIF
+! Mai 2000
+ DEALLOCATE(ZWT1)
+! ZWL=PWORKT(1)
+! ZWR=PWORKT(SIZE(PWORKT))
+ ZWB=ZMIN
+ ZWT=ZMAX
+
+! print *,' PWORKT PWORK1D ',PWORKT,PWORK1D
+! ******************************************************************
+
+ CALL FORMATXY(ZWL,ZWR,ZWB,ZWT)
+
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+
+ CALL AGSETF('SET.',4.)
+ CALL AGSETF('BAC.',4.)
+ CALL AGSETF('FRA.',2.)
+
+ ZX=ZWR+(ZWR-ZWL)/50.
+ ZX2(1)=ZX
+ ZX2(2)=ZX+(ZWR-ZWL)/16.
+ ZINT=(ZWT-ZWB)/ISUPERDIA
+!+++++++++++++++++++++++++++++++++++++++++++
+ DO J=1,ISUPERDIA
+! print *,' 1 J ISUPERDIA YGROUP(J) ',J,ISUPERDIA,YGROUP(J)
+ IF(LCOLINE)THEN
+!
+!!!!!!
+ CALL GSLN(1)
+ ITYP=1
+ IF(LFT1LUSER)THEN
+!!!!!!
+ IF(J == 1)THEN
+ CALL GSLN(NFT1STY1)
+ ITYP=NFT1STY1
+ CALL GSLWSC(XFT1LW1)
+ IF(NFT1COL1 /= 0)THEN
+ CALL GSPLCI(NFT1COL1)
+ CALL GSTXCI(NFT1COL1)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 2)THEN
+ CALL GSLN(NFT1STY2)
+ ITYP=NFT1STY2
+ CALL GSLWSC(XFT1LW2)
+ IF(NFT1COL2 /= 0)THEN
+ CALL GSPLCI(NFT1COL2)
+ CALL GSTXCI(NFT1COL2)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 3)THEN
+ CALL GSLN(NFT1STY3)
+ ITYP=NFT1STY3
+ CALL GSLWSC(XFT1LW3)
+ IF(NFT1COL3 /= 0)THEN
+ CALL GSPLCI(NFT1COL3)
+ CALL GSTXCI(NFT1COL3)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 4)THEN
+ CALL GSLN(NFT1STY4)
+ ITYP=NFT1STY4
+ CALL GSLWSC(XFT1LW4)
+ IF(NFT1COL4 /= 0)THEN
+ CALL GSPLCI(NFT1COL4)
+ CALL GSTXCI(NFT1COL4)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 5)THEN
+ CALL GSLN(NFT1STY5)
+ ITYP=NFT1STY5
+ CALL GSLWSC(XFT1LW5)
+ IF(NFT1COL5 /= 0)THEN
+ CALL GSPLCI(NFT1COL5)
+ CALL GSTXCI(NFT1COL5)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 6)THEN
+ CALL GSLN(NFT1STY6)
+ ITYP=NFT1STY6
+ CALL GSLWSC(XFT1LW6)
+ IF(NFT1COL6 /= 0)THEN
+ CALL GSPLCI(NFT1COL6)
+ CALL GSTXCI(NFT1COL6)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 7)THEN
+ CALL GSLN(NFT1STY7)
+ ITYP=NFT1STY7
+ CALL GSLWSC(XFT1LW7)
+ IF(NFT1COL7 /= 0)THEN
+ CALL GSPLCI(NFT1COL7)
+ CALL GSTXCI(NFT1COL7)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 8)THEN
+ CALL GSLN(NFT1STY8)
+ ITYP=NFT1STY8
+ CALL GSLWSC(XFT1LW8)
+ IF(NFT1COL8 /= 0)THEN
+ CALL GSPLCI(NFT1COL8)
+ CALL GSTXCI(NFT1COL8)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 9)THEN
+ CALL GSLN(NFT1STY9)
+ ITYP=NFT1STY9
+ CALL GSLWSC(XFT1LW9)
+ IF(NFT1COL9 /= 0)THEN
+ CALL GSPLCI(NFT1COL9)
+ CALL GSTXCI(NFT1COL9)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 10)THEN
+ CALL GSLN(NFT1STY10)
+ ITYP=NFT1STY10
+ CALL GSLWSC(XFT1LW10)
+ IF(NFT1COL10 /= 0)THEN
+ CALL GSPLCI(NFT1COL10)
+ CALL GSTXCI(NFT1COL10)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 11)THEN
+ CALL GSLN(NFT1STY11)
+ ITYP=NFT1STY11
+ CALL GSLWSC(XFT1LW11)
+ IF(NFT1COL11 /= 0)THEN
+ CALL GSPLCI(NFT1COL11)
+ CALL GSTXCI(NFT1COL11)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 12)THEN
+ CALL GSLN(NFT1STY12)
+ ITYP=NFT1STY12
+ CALL GSLWSC(XFT1LW12)
+ IF(NFT1COL12 /= 0)THEN
+ CALL GSPLCI(NFT1COL12)
+ CALL GSTXCI(NFT1COL12)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 13)THEN
+ CALL GSLN(NFT1STY13)
+ ITYP=NFT1STY13
+ CALL GSLWSC(XFT1LW13)
+ IF(NFT1COL13 /= 0)THEN
+ CALL GSPLCI(NFT1COL13)
+ CALL GSTXCI(NFT1COL13)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 14)THEN
+ CALL GSLN(NFT1STY14)
+ ITYP=NFT1STY14
+ CALL GSLWSC(XFT1LW14)
+ IF(NFT1COL14 /= 0)THEN
+ CALL GSPLCI(NFT1COL14)
+ CALL GSTXCI(NFT1COL14)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ELSEIF(J == 15)THEN
+ CALL GSLN(NFT1STY15)
+ ITYP=NFT1STY15
+ CALL GSLWSC(XFT1LW15)
+ IF(NFT1COL15 /= 0)THEN
+ CALL GSPLCI(NFT1COL15)
+ CALL GSTXCI(NFT1COL15)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+ ENDIF
+ IF(ITYP == 1)CALL AGSETR('DAS/PA/1.',65535.)
+ IF(ITYP == 2)CALL AGSETR('DAS/PA/1.',30583.)
+ IF(ITYP == 3)CALL AGSETR('DAS/PA/1.',21845.)
+ IF(ITYP == 4)CALL AGSETR('DAS/PA/1.',10023.)
+ CALL GSLN(ITYP)
+!!!!!!
+ ELSE
+!!!!!!
+ IF(LCOLUSER)THEN
+ YGP(1:LEN(YGP))=' '
+ DO JGP=1,LEN_TRIM(YGROUP(J))
+ IF(YGROUP(J)(JGP:JGP) == ' ')THEN
+ YGP=YGROUP(J)(1:JGP-1)
+ YGP=ADJUSTL(YGP)
+ EXIT
+ ENDIF
+ ENDDO
+ IF(YGP(1:LEN(YGP)) == ' ')THEN
+ YGP=YGROUP(J)
+ YGP=ADJUSTL(YGP)
+ ENDIF
+ if(nverbia >0)then
+ print *,' YGP ',YGP,' YGROUP ',YGROUP(J)
+ endif
+ ICOL=0
+ CALL READCOL_FT_PVKT(YGP(1:LEN_TRIM(YGP)),ICOL)
+ if(nverbia >0)then
+ print *,' ICOL ',ICOL
+ endif
+ IF(ICOL == 0)THEN
+ print *,' INDICE DE COULEUR POUR ',ADJUSTL(YGROUP(J)(1:LEN_TRIM &
+ (YGROUP(J)))),' ? '
+ READ(5,*,END=12)ICOL
+ GO TO 22
+ 12 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ READ(5,*)ICOL
+ 22 CONTINUE
+ !WRITE(YCAR80,*)ICOL
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ICOL)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ CALL LOADMNMX_FT_PVKT('XPVKTCOL_'//YGP(1:LEN_TRIM(YGP))//'=',1,FLOAT(ICOL),7)
+ ENDIF
+ CALL GSPLCI(ICOL)
+ CALL GSTXCI(ICOL)
+ ELSE
+ CALL GSPLCI(J+1)
+ CALL GSTXCI(J+1)
+ ENDIF
+!!!!!!
+ ENDIF
+!!!!!!
+ ELSE !!!!!!!!!!!!!!!!!!!! Noir et blanc
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ SELECT CASE(J)
+ CASE(:4)
+ CALL GSLWSC(1.)
+ CASE(5:8)
+ CALL GSLWSC(2.)
+ CASE(9:12)
+ CALL GSLWSC(3.)
+ CASE(13:16)
+ CALL GSLWSC(4.)
+ CASE DEFAULT
+ CALL GSLWSC(1.)
+ END SELECT
+ !
+ IF(LFT1STYLUSER)THEN
+ print *,' Rentrez le type de trait voulu :'
+ print *,' Trait plein : 1, Tiretes : 2, Pointilles : 3, Tiretes longs-courts : 4'
+ read(5,*,END=10)ISLN
+ GO TO 20
+ 10 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)ISLN
+ 20 CONTINUE
+ !WRITE(YCAR80,*)ISLN
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ISLN)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ print *,' Epaisseur des traits ? (valeur de base 1) '
+ read(5,*,END=11)EPAIS
+ GO TO 21
+ 11 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)EPAIS
+ 21 CONTINUE
+ !WRITE(YCAR80,*)EPAIS
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,EPAIS)
+ CALL GSLWSC(EPAIS)
+!Mai 2000
+! CALL GSLN(ISLN)
+ CALL GSLN(1)
+ IF(ISLN == 1)CALL AGSETR('DAS/PA/1.',65535.)
+ IF(ISLN == 2)CALL AGSETR('DAS/PA/1.',30583.)
+ IF(ISLN == 3)CALL AGSETR('DAS/PA/1.',21845.)
+ IF(ISLN == 4)CALL AGSETR('DAS/PA/1.',10023.)
+ ITYP=ISLN
+ ELSE
+ ITYP=MOD(J,4)
+ IF(ITYP == 0)ITYP=4
+! CALL GSLN(MOD(J,4))
+! IF(MOD(J,4) == 0)CALL GSLN(4)
+ CALL GSLN(1)
+ IF(ITYP == 1)CALL AGSETR('DAS/PA/1.',65535.)
+ IF(ITYP == 2)CALL AGSETR('DAS/PA/1.',30583.)
+ IF(ITYP == 3)CALL AGSETR('DAS/PA/1.',21845.)
+ IF(ITYP == 4)CALL AGSETR('DAS/PA/1.',10023.)
+ ENDIF
+ ENDIF !!!!!!!!!!!!!!!!!!!! Noir et blanc
+ ZY=ZWB+ZINT*(J-1)
+ ZY2(1)=ZY; ZY2(2)=ZY
+ CALL GSCLIP(0)
+! print *,' ZX ZY ',ZX2,ZY2
+ CALL GSLN(ITYP)
+ ! trace du trait sous le proc
+!!!!!!!
+ IF(.NOT.LCOLINE)THEN
+!!!!!!!
+ IF(.NOT.LBLFT1SUP)THEN
+ CALL GPL(2,ZX2,ZY2)
+ ENDIF
+!!!!!!!
+ ENDIF
+!!!!!!!
+ ZY=ZY+(ZWT-ZWB)/60.
+ CALL GQLWSC(IER,ZWIDTH)
+! CALL GQLN(IER,ITYP)
+ CALL GSLN(1)
+ CALL GSLWSC(1.)
+ YCAR30(1:LEN(YCAR30))=' '
+!!!!!!!
+ print *,' LFT1LUSER ****',LFT1LUSER,J
+ IF(LFT1LUSER)THEN
+ print *,' LFT1LUSER ****',LFT1LUSER,J
+ IF(J == 1)THEN
+ YCAR30=ADJUSTL(CFT1TIT1)
+ print*,'YCAR30=',YCAR30
+ print*,'CFT1TIT1 ',CFT1TIT1
+ ELSEIF(J == 2)THEN
+ YCAR30=ADJUSTL(CFT1TIT2)
+ print*,'YCAR30=',YCAR30
+ ELSEIF(J == 3)THEN
+ YCAR30=ADJUSTL(CFT1TIT3)
+ ELSEIF(J == 4)THEN
+ YCAR30=ADJUSTL(CFT1TIT4)
+ ELSEIF(J == 5)THEN
+ YCAR30=ADJUSTL(CFT1TIT5)
+ ELSEIF(J == 6)THEN
+ YCAR30=ADJUSTL(CFT1TIT6)
+ ELSEIF(J == 7)THEN
+ YCAR30=ADJUSTL(CFT1TIT7)
+ ELSEIF(J == 8)THEN
+ YCAR30=ADJUSTL(CFT1TIT8)
+ ELSEIF(J == 9)THEN
+ YCAR30=ADJUSTL(CFT1TIT9)
+ ELSEIF(J == 10)THEN
+ YCAR30=ADJUSTL(CFT1TIT10)
+ ELSEIF(J == 11)THEN
+ YCAR30=ADJUSTL(CFT1TIT11)
+ ELSEIF(J == 11)THEN
+ YCAR30=ADJUSTL(CFT1TIT12)
+ ELSEIF(J == 13)THEN
+ YCAR30=ADJUSTL(CFT1TIT13)
+ ELSEIF(J == 14)THEN
+ YCAR30=ADJUSTL(CFT1TIT14)
+ ELSEIF(J == 15)THEN
+ YCAR30=ADJUSTL(CFT1TIT15)
+ ENDIF
+ YCAR30=ADJUSTL(YCAR30)
+ IF(YCAR30 == 'white' .OR. YCAR30 == 'WHITE')THEN
+ YCAR30(1:LEN(YCAR30))=' '
+ ELSEIF(YCAR30 == ' ')THEN
+ YCAR30=ADJUSTL(YGROUP(J)(1:LEN_TRIM(YGROUP(J))))
+ ENDIF
+ ELSE
+!!!!!!!
+ YCAR30=ADJUSTL(YGROUP(J)(1:LEN_TRIM(YGROUP(J))))
+!!!!!!!
+ ENDIF
+!!!!!!!
+ print*,'YCAR30=',YCAR30
+ ! ecriture du nom du proc
+ IF(.NOT.LBLFT1SUP)THEN
+ CALL PLCHHQ(ZX,ZY,YCAR30,.010,0.,-1.)
+ ENDIF
+!JDCALL PLCHHQ(ZX,ZY,YCAR30,.011,0.,-1.)
+! CALL PLCHHQ(ZX,ZY,ADJUSTL(YGROUP(J)(1:LEN_TRIM(YGROUP(J)))),.011,0.,-1.)
+ CALL GSCLIP(1)
+! CALL GSLN(ITYP)
+ IF(ITYP == 1)CALL AGSETR('DAS/PA/1.',65535.)
+ IF(ITYP == 2)CALL AGSETR('DAS/PA/1.',30583.)
+ IF(ITYP == 3)CALL AGSETR('DAS/PA/1.',21845.)
+ IF(ITYP == 4)CALL AGSETR('DAS/PA/1.',10023.)
+ CALL GSLWSC(ZWIDTH)
+
+ IC=ICOMPTSZ(J)
+ ALLOCATE(ZWT1(IC),ZWT2(IC))
+ ZWT1(:)=ZWORKT(1:IC,J)
+ ZWT2(:)=ZWORK1D(:,J)
+ IF(LSPVALT)THEN
+ WHERE(ZWT2 == XSPVALT)
+ ZWT2=ZE36
+ ENDWHERE
+ ENDIF
+ DO JI=1,IBRECOUV(J)
+ JD=IRECOUV(JI*2-1,J)
+ JF=IRECOUV(JI*2,J)
+! print *,' JD JF AVANT ',JD,JF
+! 270896 !!!!!!!!!!!!!!!
+ SELECT CASE(CTYPE)
+ CASE('DRST','RSPL','RAPL')
+! J2=NLOOPN
+ J2=IST(J)
+ CASE DEFAULT
+ J2=1
+ END SELECT
+ IF(.NOT. LTINCRDIA(J,J2))THEN
+ DO JE=1,NBTIMEDIA(J,J2)
+ IF(NTIMEDIA(JE,J,J2) >= JD)THEN
+ JD=JE
+ EXIT
+ ENDIF
+ ENDDO
+ DO JE=1,NBTIMEDIA(J,J2)
+ IF(NTIMEDIA(JE,J,J2) == JF)THEN
+ JF=JE
+ EXIT
+ ELSE IF(NTIMEDIA(JE,J,J2) > JF)THEN
+ JF=JE-1
+ EXIT
+ ENDIF
+ ENDDO
+ JF=MIN(JF,NBTIMEDIA(J,J2))
+! print *,' JD JF APRES ',JD,JF
+! print *,' ZWT2 ',ZWT2(JD:JF)
+
+ ELSE
+
+ JJE=0
+ DO JE=NTIMEDIA(1,J,J2),NTIMEDIA(2,J,J2),NTIMEDIA(3,J,J2)
+ JJE=JJE+1
+ IF(JE >= JD)THEN
+ JD=JJE
+ EXIT
+ ENDIF
+ ENDDO
+ JJE=0
+ DO JE=NTIMEDIA(1,J,J2),NTIMEDIA(2,J,J2),NTIMEDIA(3,J,J2)
+ JJE=JJE+1
+ IF(JE == JF)THEN
+ JF=JJE
+ EXIT
+ ELSE IF(JE > JF)THEN
+ JF=MIN(JF,JJE-1)
+ EXIT
+ ENDIF
+ ENDDO
+ JJE=0
+ DO JE=NTIMEDIA(1,J,J2),NTIMEDIA(2,J,J2),NTIMEDIA(3,J,J2)
+ JJE=JJE+1
+ ENDDO
+! JF=MIN(JF,NTIMEDIA(2,J,J2))
+ JF=MIN(JF,JJE)
+ print *,' JD JF APRES ',JD,JF
+! print *,' ZWT2 ',ZWT2(JD:JF)
+ ENDIF
+! 270896 !!!!!!!!!!!!!!!
+! CALL EZXY(PWORKT,ZWORK1D(:,J),SIZE(PWORKT),0)
+! PROVISOIRE ***************
+! IF(JI > 1)THEN
+! CALL GSPLCI(JI*5)
+! CALL GSTXCI(JI*5)
+! ENDIF
+ IF(JF >= JD)THEN
+ ! trace de la courbe
+ CALL GSLN(ITYP)
+ CALL AGSETR('DAS/SE.',1.)
+ CALL EZXY(ZWT1(JD:JF),ZWT2(JD:JF),JF-JD+1,0)
+ CALL SFLUSH
+ CALL AGSETR('DAS/PA/1.',65535.)
+ ELSE
+ if(nverbia >0)then
+ print *,' ** varfct 1 JD,JF JD > JF .Suppression appel EZXY',&
+ JD,JF
+ endif
+ ENDIF
+
+! CALL EZXY(PWORKT(JD:JF),ZWORK1D(JD:JF,J),JF-JD+1,0)
+ ENDDO
+ DEALLOCATE(ZWT1,ZWT2)
+ ENDDO
+
+! print *,' FORMAX,FORMAY ',FORMAX,' ',FORMAY
+ !CALL GASETI('LTY',1)
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ CALL GSLN(1)
+ CALL GSLWSC(1.)
+! CALL GRIDAL(5,1,5,1,1,1,5,0,0)
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NFT1ITVXMJ,NFT1ITVXMN,NFT1ITVYMJ,NFT1ITVYMN,0,0,5,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NFT1ITVXMJ,NFT1ITVXMN,NFT1ITVYMJ,NFT1ITVYMN,0,1,5,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+!!!!!!!Avril 2002
+ IF(LHEURX)THEN
+ IF(LMYHEURX)THEN
+ CALL MYHEURX(NFT1ITVXMJ,NFT1ITVXMN,NFT1ITVYMJ,NFT1ITVYMN,1,0,5,0.,0.)
+ ELSE
+ CALL MYHEURX(NFT1ITVXMJ,NFT1ITVXMN,NFT1ITVYMJ,NFT1ITVYMN,1,0,5,0.,0.)
+ ENDIF
+ ELSE
+ CALL GRIDAL(NFT1ITVXMJ,NFT1ITVXMN,NFT1ITVYMJ,NFT1ITVYMN,1,0,5,0.,0.)
+ ENDIF
+ ELSE
+!!!!!!!Avril 2002
+ IF(LHEURX)THEN
+ IF(LMYHEURX)THEN
+ CALL MYHEURX(NFT1ITVXMJ,NFT1ITVXMN,NFT1ITVYMJ,NFT1ITVYMN,1,1,5,0.,0.)
+ ELSE
+ CALL MYHEURX(NFT1ITVXMJ,NFT1ITVXMN,NFT1ITVYMJ,NFT1ITVYMN,1,1,5,0.,0.)
+ ENDIF
+ ELSE
+ CALL GRIDAL(NFT1ITVXMJ,NFT1ITVXMN,NFT1ITVYMJ,NFT1ITVYMN,1,1,5,0.,0.)
+ ENDIF
+ ENDIF
+!Avril 2002
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ IF(LFACTIMP)THEN
+ CALL FACTIMP
+ ENDIF
+! Titres en X
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(LFT .OR. LPVKT)THEN
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/3.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/3.,YTEM,.008,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/2.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(LFT .OR. LPVKT)THEN
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/3.,.05),YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/3.,YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/2.,ZVB/3.,YTEM,.008,0.,-1.)
+ ELSE
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ IF(LHEURX)THEN
+ YTEM='(H.)'
+ ELSE
+ YTEM='(Sec.)'
+ ENDIF
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(LFT .OR. LPVKT)THEN
+ if(nverbia > 0)then
+ print *,' **Passage LFT LPVKT 1'
+ endif
+ CALL PLCHHQ(ZVR+.03 ,ZVB-MIN(ZVB/3.,.05),YTEM(1:LEN_TRIM(YTEM)),.008,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/3.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/3.,YTEM,.008,0.,-1.)
+ ELSE
+ if(nverbia > 0)then
+ print *,' **Passage PAS LFT LPVKT 1'
+ endif
+ CALL PLCHHQ((ZVR+.03),ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),.008,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+! Titres en Y
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYT',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ IF(LCNSUM)THEN
+ YTEM='SUM(.TRUE.=1)'
+ ENDIF
+ CALL RESOLV_TITY('CTITYM',ZVL,ZVR,ZVB,ZVT,YTEM)
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYB',ZVL,ZVR,ZVB,ZVT,YTEM)
+! Titres TOP
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT3',YTEM)
+ ZXPOSTITT3=.002
+ ZXYPOSTITT3=.93
+ IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ ENDIF
+ IF(XYPOSTITT3 /= 0.)THEN
+ ZXYPOSTITT3=XYPOSTITT3
+ ENDIF
+ IF(CTITT3 /= ' ')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(0.002,0.93,YTEM,XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.002,0.93,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.95
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+ IF(CTITT2 /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(0.002,0.95,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT1',YTEM)
+ ZXPOSTITT1=.002
+ ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+ IF(CTITT1 /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(0.002,0.98,YTEM,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.002,0.98,YTEM,.012,0.,-1.)
+ ENDIF
+ ENDIF
+! Titres BOTTOM
+ ZXPOSTITB1=.002
+ ZXYPOSTITB1=.005
+ IF(XPOSTITB1 /= 0.)THEN
+ ZXPOSTITB1=XPOSTITB1
+ ENDIF
+ IF(XYPOSTITB1 /= 0.)THEN
+ ZXYPOSTITB1=XYPOSTITB1
+ ENDIF
+
+ ZXPOSTITB2=.002
+ ZXYPOSTITB2=.025
+ IF(XPOSTITB2 /= 0.)THEN
+ ZXPOSTITB2=XPOSTITB2
+ ENDIF
+ IF(XYPOSTITB2 /= 0.)THEN
+ ZXYPOSTITB2=XYPOSTITB2
+ ENDIF
+
+ ZXPOSTITB3=.002
+ ZXYPOSTITB3=.05
+ IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ ENDIF
+ IF(XYPOSTITB3 /= 0.)THEN
+ ZXYPOSTITB3=XYPOSTITB3
+ ENDIF
+IF(LCNSUM)THEN
+! Titre N1 BOTTOM
+ CALL RESOLV_TIT('CTITB1',CLEGEND)
+ IF(XSZTITB1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,CLEGEND,XSZTITB1,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,CLEGEND,XSZTITB1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,CLEGEND,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,CLEGEND,.007,0.,-1.)
+ ENDIF
+! Titre N3 BOTTOM
+ CALL RESOLV_TIT('CTITB3',CTIMECS)
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTIMECS,XSZTITB3,0.,-1.)
+! CALL PLCHHQ(0.002,0.050,CTIMECS,XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,CTIMECS,.009,0.,-1.)
+! CALL PLCHHQ(0.002,0.050,CTIMECS,.009,0.,-1.)
+ ENDIF
+! Titre N2 BOTTOM
+ CALL RESOLV_TIT('CTITB2',CLEGEND2)
+ IF(CLEGEND2 /= ' ')THEN
+ IF(XSZTITB2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,XSZTITB2,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,CLEGEND2,XSZTITB2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,CLEGEND2,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,CLEGEND2,.007,0.,-1.)
+ ENDIF
+ ENDIF
+ELSE
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITB3',YTEM)
+ IF(CTITB3 /= ' ')THEN
+ IF(XSZTITB3 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,XSZTITB3,0.,-1.)
+! CALL PLCHHQ(0.002,0.05,YTEM,XSZTITB3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB3,ZXYPOSTITB3,YTEM,.008,0.,-1.)
+! CALL PLCHHQ(0.002,0.05,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITB2',YTEM)
+ IF(CTITB2 /= ' ')THEN
+ IF(XSZTITB2 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,YTEM,XSZTITB2,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,YTEM,XSZTITB2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB2,ZXYPOSTITB2,YTEM,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.025,YTEM,.007,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITB1',YTEM)
+ IF(CTITB1 /= ' ')THEN
+ IF(XSZTITB1 /= 0.)THEN
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,YTEM,XSZTITB1,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,YTEM,XSZTITB1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(ZXPOSTITB1,ZXYPOSTITB1,YTEM,.007,0.,-1.)
+! CALL PLCHHQ(0.002,0.005,YTEM,.007,0.,-1.)
+ ENDIF
+ ENDIF
+ENDIF
+ DEALLOCATE(ZWORK1D)
+ DEALLOCATE(ZWORKT)
+ DEALLOCATE(YGROUP)
+ DEALLOCATE(ICOMPTSZ)
+ DEALLOCATE(IST)
+ DEALLOCATE(IBRECOUV)
+ DEALLOCATE(IRECOUV)
+ ICOMPT=0
+
+ ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FIN IF(ICOMPT < ISUPERDIA) ?
+ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FIN LFT1
+
+!*****************************************************************************
+!******* Fin LFT1 Debut LFT LPVKT LPVKT1 **********************************
+!*****************************************************************************
+
+IF(LFT .OR. LPVKT .OR. LPVKT1)THEN
+
+ ICOMPT=ICOMPT+1
+ IF(ICOMPT == 1)THEN
+! On suppose meme longueur temps
+! Non pas necessairement
+
+ SELECT CASE(CTYPE)
+ CASE('CART','MASK','SPXY')
+ INDN=1
+ CASE DEFAULT
+ INDN=NLOOPN
+ END SELECT
+
+!24052000
+! IF(LMINUS .OR. LPLUS)THEN
+!24052000
+!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!!!
+ IBPM=0
+ DO J=1,NBPM
+ IF(NUMPM(J) == 1 .OR. NUMPM(J) == 2)THEN
+ IBPM=IBPM+1
+ ENDIF
+ ENDDO
+!24052000
+ IF(IBPM /= 0)THEN
+!24052000
+ ISUPERDIA=NSUPERDIA-(IBPM)
+ if(nverbia > 0)then
+ print *,' isuperdia ',isuperdia
+ endif
+! ISUPERDIA=NSUPERDIA-(NBPM-1)
+!!!!!!!!!!!!!!!!!!!!!020398!!!!!!!!!!!!!!!!!!!!!
+! ISUPERDIA=NSUPERDIA-1
+ ELSE
+ IF(.NOT.LPVKT1)THEN
+ ISUPERDIA=NSUPERDIA
+ ELSE IF(LPVKT1)THEN
+!!! MARS 2001 modif NON en definitive
+ ISUPERDIA=NBLVLKDIA(NLOOPSUPER,INDN)
+!!! MARS 2001 modif
+ ALLOCATE(ZPVMNMX(ISUPERDIA,2))
+ ALLOCATE(YK(ISUPERDIA))
+ ZPVMNMX(ICOMPT,1)=XPVMIN
+ ZPVMNMX(ICOMPT,2)=XPVMAX
+ YK(ICOMPT)=' '
+ WRITE(YK(ICOMPT),'(I2)')K
+ ENDIF
+ ENDIF
+ if(nverbia > 0)then
+ print *,' ** VARFCT ICOMPT ISUPERDIA LMINUS LPLUS NBPM ',ICOMPT,ISUPERDIA,LMINUS,LPLUS,NBPM
+ endif
+
+ ALLOCATE(ZWORK1D(SIZE(PWORK1D),ISUPERDIA))
+ ALLOCATE(ZWORKT(SIZE(PWORKT),ISUPERDIA))
+ ALLOCATE(YGROUP(ISUPERDIA))
+ ALLOCATE(ICOMPTSZ(ISUPERDIA))
+ ALLOCATE(IST(ISUPERDIA))
+ ALLOCATE(IBRECOUV(ISUPERDIA))
+ ALLOCATE(IRECOUV(NBRECOUV*2,ISUPERDIA))
+
+ ICOMPTSZ(ICOMPT)=SIZE(PWORKT)
+ IST(ICOMPT)=NLOOPN
+
+ IBRECOUV(ICOMPT)=NBRECOUV
+ DO J=1,NBRECOUV
+ IRECOUV(J*2-1,ICOMPT)=NRECOUV(J*2-1)
+ IRECOUV(J*2,ICOMPT)=NRECOUV(J*2)
+ ENDDO
+
+ ZWORKT(:,ICOMPT)=PWORKT(:)
+ ZWORK1D(:,ICOMPT)=PWORK1D(:)
+
+ CTITGAL=ADJUSTL(CTITGAL)
+ YGROUP(ICOMPT)=CTITGAL
+ IF(LMINUS .OR. LPLUS)THEN
+ print *,' ** varfct LMINUS or LPLUS=T , CTITGAL , CTITB3 ',CTITGAL(1:LEN_TRIM(CTITGAL))
+ print *,CTITB3(1:LEN_TRIM(CTITB3))
+ print *,' Le titre est mis a DIFF '
+ YGROUP(ICOMPT)=' '
+ YGROUP(ICOMPT)='DIFF '
+! LTITDEF=.FALSE.
+! CALL RESOLV_TIT('CTITB3',CTITB3)
+ YDIFF(1:LEN(YDIFF))=' '
+ IF(CTITB3 /= ' ')THEN
+ YDIFF='DIFF = '//ADJUSTL(CTITB3(1:LEN_TRIM(CTITB3)))
+ YDIFF=ADJUSTL(YDIFF)
+ ENDIF
+ print *,'YDIFF 1** ',YDIFF
+ ENDIF
+
+ ELSE
+
+ IF(ICOMPT > ISUPERDIA .AND. LPVKT1)THEN
+
+ if(nverbia > 0)then
+ print *,' ISUPERDIA AV NLOOPSUPER NSUPERDIA NBLVLKDIA(NLOOPSUPER,INDN) ',&
+ ISUPERDIA,NLOOPSUPER,NSUPERDIA,NBLVLKDIA(NLOOPSUPER,INDN)
+ print *,' NLOOPN NBLVLKDIA(NLOOPSUPER,NLOOPN) ',NLOOPN,NBLVLKDIA(NLOOPSUPER,NLOOPN)
+ endif
+!!! MARS 2001
+ ISUPERDIA=ISUPERDIA+NBLVLKDIA(NLOOPSUPER,INDN)
+! ISUPERDIA=ISUPERDIA+NBLVLKDIA(NLOOPSUPER,NLOOPN)
+!!! MARS 2001
+ if(nverbia > 0)then
+ print *,' ISUPERDIA AP ICOMPT ',ISUPERDIA,ICOMPT
+ endif
+
+ ALLOCATE(ZWORK(SIZE(ZWORK1D,1),SIZE(ZWORK1D,2)))
+ ZWORK(:,:)=ZWORK1D(:,:)
+ DEALLOCATE(ZWORK1D)
+ ALLOCATE(ZWORK1D(SIZE(ZWORK,1),ISUPERDIA))
+ ZWORK1D(:,1:ICOMPT-1)=ZWORK(:,:)
+ DEALLOCATE(ZWORK)
+
+ ALLOCATE(ZWORK(SIZE(ZWORKT,1),SIZE(ZWORKT,2)))
+ ZWORK(:,:)=ZWORKT(:,:)
+ DEALLOCATE(ZWORKT)
+ ALLOCATE(ZWORKT(SIZE(ZWORK,1),ISUPERDIA))
+ ZWORKT(:,1:ICOMPT-1)=ZWORK(:,:)
+ DEALLOCATE(ZWORK)
+
+ ALLOCATE(ZWORK(SIZE(ZPVMNMX,1),SIZE(ZPVMNMX,2)))
+ ZWORK(:,:)=ZPVMNMX(:,:)
+ DEALLOCATE(ZPVMNMX)
+ ALLOCATE(ZPVMNMX(ISUPERDIA,SIZE(ZWORK,1)))
+ ZPVMNMX(1:ICOMPT-1,:)=ZWORK(:,:)
+ DEALLOCATE(ZWORK)
+
+ ALLOCATE(IWORK(SIZE(IRECOUV,1),SIZE(IRECOUV,2)))
+ IWORK(:,:)=IRECOUV(:,:)
+ DEALLOCATE(IRECOUV)
+ ALLOCATE(IRECOUV(SIZE(IWORK,1),ISUPERDIA))
+ IRECOUV(:,1:ICOMPT-1)=IWORK(:,:)
+ DEALLOCATE(IWORK)
+
+ ALLOCATE(ITEM(SIZE(IBRECOUV)))
+ ITEM(:)=IBRECOUV(:)
+ DEALLOCATE(IBRECOUV)
+ ALLOCATE(IBRECOUV(ISUPERDIA))
+ IBRECOUV(1:ICOMPT-1)=ITEM(:)
+ DEALLOCATE(ITEM)
+
+ ALLOCATE(ITEM(SIZE(ICOMPTSZ)))
+ ITEM(:)=ICOMPTSZ(:)
+ DEALLOCATE(ICOMPTSZ)
+ ALLOCATE(ICOMPTSZ(ISUPERDIA))
+ ICOMPTSZ(1:ICOMPT-1)=ITEM(:)
+ DEALLOCATE(ITEM)
+
+ ALLOCATE(ITEM(SIZE(IST)))
+ ITEM(:)=IST(:)
+ DEALLOCATE(IST)
+ ALLOCATE(IST(ISUPERDIA))
+ IST(1:ICOMPT-1)=ITEM(:)
+ DEALLOCATE(ITEM)
+
+ ALLOCATE(YGTEM(SIZE(YGROUP)))
+ YGTEM(:)=YGROUP(:)
+ DEALLOCATE(YGROUP)
+ ALLOCATE(YGROUP(ISUPERDIA))
+ YGROUP(1:ICOMPT-1)=YGTEM(:)
+ DEALLOCATE(YGTEM)
+
+ ALLOCATE(YKTEM(SIZE(YK)))
+ YKTEM(:)=YK(:)
+ DEALLOCATE(YK)
+ ALLOCATE(YK(ISUPERDIA))
+ YK(1:ICOMPT-1)=YKTEM(:)
+ DEALLOCATE(YKTEM)
+ ENDIF !!!!!!!!!!!!!!!!!!!!!!!! FIN IF(ICOMPT > ISUPERDIA .AND. LPVKT1)
+
+ IF(LPVKT1)THEN
+ ZPVMNMX(ICOMPT,1)=XPVMIN
+ ZPVMNMX(ICOMPT,2)=XPVMAX
+ YK(ICOMPT)=' '
+ WRITE(YK(ICOMPT),'(I2)')K
+! print *,' XPVMIN,XPVMAX ',XPVMIN,XPVMAX
+ ENDIF
+
+ IBRECOUV(ICOMPT)=NBRECOUV
+ ILR=NBRECOUV*2
+ IF(ILR <= MAXVAL(IBRECOUV(1:ICOMPT-1))*2)THEN
+ DO J=1,ILR
+ IRECOUV(J,ICOMPT)=NRECOUV(J)
+ ENDDO
+ ELSE
+ ALLOCATE(IWORK(ILR,ISUPERDIA))
+ DO J=1,ICOMPT-1
+ IWORK(1:IBRECOUV(J)*2,J)=IRECOUV(1:IBRECOUV(J)*2,J)
+ ENDDO
+ IWORK(1:ILR,ICOMPT)=NRECOUV(1:ILR)
+ DEALLOCATE(IRECOUV)
+ ALLOCATE(IRECOUV(ILR,ISUPERDIA))
+ IRECOUV(:,:)=IWORK(:,:)
+ DEALLOCATE(IWORK)
+ ENDIF
+
+ CTITGAL=ADJUSTL(CTITGAL)
+ YGROUP(ICOMPT)=CTITGAL
+
+ IF(LMINUS .OR. LPLUS)THEN
+ print *,' ** varfct LMINUS or LPLUS=T , CTITGAL , CTITB3 ',CTITGAL(1:LEN_TRIM(CTITGAL))
+ print *,CTITB3(1:LEN_TRIM(CTITB3))
+ print *,' Le titre est mis a DIFF '
+ YGROUP(ICOMPT)=' '
+ YGROUP(ICOMPT)='DIFF '
+! LTITDEF=.FALSE.
+! CALL RESOLV_TIT('CTITB3',CTITB3)
+ YDIFF(1:LEN(YDIFF))=' '
+ IF(CTITB3 /= ' ')THEN
+ YDIFF=' DIFF '//(CTITB3(1:LEN_TRIM(CTITB3)))
+ YDIFF=ADJUSTL(YDIFF)
+ ENDIF
+ print *,'YDIFF ** ',YDIFF
+ ENDIF
+
+ ICOMPTSZ(ICOMPT)=SIZE(PWORKT)
+ IST(ICOMPT)=NLOOPN
+ if(nverbia > 0)then
+ print *,' ICOMPT,IST(ICOMPT) ',ICOMPT,IST(ICOMPT)
+ endif
+
+ IC=ICOMPTSZ(ICOMPT)
+ IF(IC <= MAXVAL(ICOMPTSZ(1:ICOMPT-1)))THEN
+ ZWORK1D(1:IC,ICOMPT)=PWORK1D(:)
+ ZWORKT(1:IC,ICOMPT)=PWORKT(:)
+ ELSE
+ ALLOCATE(ZWORK(IC,ISUPERDIA))
+ ZWORK=0.
+ DO J=1,ICOMPT-1
+ ZWORK(1:ICOMPTSZ(J),J)=ZWORK1D(1:ICOMPTSZ(J),J)
+ ENDDO
+ ZWORK(1:IC,ICOMPT)=PWORK1D(:)
+ DEALLOCATE(ZWORK1D)
+ ALLOCATE(ZWORK1D(IC,ISUPERDIA))
+ ZWORK1D(:,:)=ZWORK(:,:)
+ ZWORK=0.
+ DO J=1,ICOMPT-1
+ ZWORK(1:ICOMPTSZ(J),J)=ZWORKT(1:ICOMPTSZ(J),J)
+ ENDDO
+ ZWORK(1:IC,ICOMPT)=PWORKT(:)
+ DEALLOCATE(ZWORKT)
+ ALLOCATE(ZWORKT(IC,ISUPERDIA))
+ ZWORKT(:,:)=ZWORK(:,:)
+ DEALLOCATE(ZWORK)
+ ENDIF
+ ENDIF !!!!!!!!!!!!!!!!!!!!!! FIN IF(ICOMPT == 1)
+
+ CGROUP=ADJUSTL(CGROUP)
+! YGROUP(ICOMPT)=CGROUP
+ IF(LPVKT)THEN
+ ILYGRP=LEN(YGROUP)
+ ILGRP=LEN_TRIM(CTITGAL)
+! ILGRP=LEN_TRIM(CGROUP)
+ WRITE(YGROUP(ICOMPT)(ILGRP+2:ILYGRP),'(''K='',I2)')K
+ ENDIF
+! print *,' ICOMPT ZWORK1D ',ICOMPT,ZWORK1D
+
+ IF(ICOMPT < ISUPERDIA)THEN
+! print *,' ICOMPT,ISUPERDIA ',ICOMPT,ISUPERDIA
+ RETURN
+
+ ELSE
+!!!!!!!!!!!! A REVOIR ... REVU MAIS ... a VERIFIER!!!!!!!!!!!!!!!!!!
+ IF(LPVKT1)THEN
+ ITOT=0
+! print *,' NSUPERDIA ',NSUPERDIA
+ IF(NLOOPSUPER < NSUPERDIA)THEN
+ RETURN
+ ENDIF
+ DO JA=1,NSUPERDIA
+ ITOT=ITOT+ NBLVLKDIA(JA,NNDIA(1,JA))
+ if(nverbia > 0)then
+ print *,'JA NBLVLKDIA(JA,NNDIA(1,JA)) ITOT ',JA,NBLVLKDIA(JA,NNDIA(1,JA)),ITOT
+ endif
+ ENDDO
+! IF(ISUPERDIA < ITOT)THEN
+ IF(ICOMPT < ITOT)THEN
+ RETURN
+ ENDIF
+ ENDIF
+ if(nverbia >0)then
+ print *,' ITOT ',ITOT
+ endif
+!!!!!!!!!!!! A REVOIR ... REVU MAIS ... A VERIFIER !!!!!!!!!!!!!!!!!!
+
+ INUM=0
+ INB=0
+ IND=1
+
+ ZVL=.12; ZVR=.88
+ CALL AGSETR('SET.',4.)
+ CALL AGSETR('BAC.',4.)
+ CALL AGSETR('FRA.',2.)
+
+ IF(LPVKT1)THEN
+ IPAGE=1
+ ELSE
+ ! 3 courbes par diagramme !!!!
+ IBC=2
+ IF(LFT3C)THEN
+ IBC=3
+ ELSEIF(LFT4C)THEN
+ IBC=4
+ ENDIF
+ IBCP=IBC*4
+ IPAGE=0
+ !IPAGE=ISUPERDIA/8
+ IPAGE=ISUPERDIA/IBCP
+ !IREST=MOD(ISUPERDIA,8)
+ IREST=MOD(ISUPERDIA,IBCP)
+ IF(IREST /=0)THEN
+ IPAGE=IPAGE+1
+ ENDIF
+ ENDIF
+
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+! Determination du min et du max du temps
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+ ITOT=0
+ DO J=1,ICOMPT
+ ITOT=ITOT+ICOMPTSZ(J)
+ ENDDO
+ if(nverbia >0)then
+ print *,' ITOT AP Determin.. ICOMPT ',ITOT,ICOMPT
+ endif
+ ALLOCATE(ZWT1(ITOT))
+ ID=0
+ DO J=1,ICOMPT
+ ZCONSTIM=0
+ IF(MOD(J,8) == 1)THEN
+ ZCONSTIM=XFT_ADTIM1
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.1 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM1 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 2)THEN
+ ZCONSTIM=XFT_ADTIM2
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.2 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM2 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 3)THEN
+ ZCONSTIM=XFT_ADTIM3
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.3 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM3 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 4)THEN
+ ZCONSTIM=XFT_ADTIM4
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.3 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM4 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 5)THEN
+ ZCONSTIM=XFT_ADTIM5
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.4 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM5 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 6)THEN
+ ZCONSTIM=XFT_ADTIM6
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.5 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM6 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 7)THEN
+ ZCONSTIM=XFT_ADTIM7
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.6 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM7 a zero'
+ ENDIF
+ ELSEIF(MOD(J,8) == 0)THEN
+ ZCONSTIM=XFT_ADTIM8
+ IF(ZCONSTIM /= 0.)THEN
+ print *,' ****ATTENTION Ajout pour la courbe N.7 d''une constante de temps de : ',&
+ ZCONSTIM,'sec.'
+ print *,' S''il s''agit d''une erreur, remettez XFT_ADTIM8 a zero'
+ ENDIF
+ ENDIF
+ IC=ICOMPTSZ(J)
+ IF(LSPVALT)THEN ! Cas ou le temps est mis a une valeur speciale (Ex avion)
+ DO JH=1,IC
+ IF(ZWORKT(JH,J) /= XSPVALT)THEN
+ ZWORKT(JH,J)=ZWORKT(JH,J)+ZCONSTIM
+ ENDIF
+ ENDDO
+ ELSE
+ ZWORKT(1:IC,J)=ZWORKT(1:IC,J)+ZCONSTIM
+ ENDIF
+ ZWT1(ID+1:ID+IC)=ZWORKT(1:IC,J)
+ ID=IC+ID
+ ENDDO
+ IF(LSPVALT)THEN ! Cas ou le temps est mis a une valeur speciale (Ex avion)
+ WHERE(ZWT1 == XSPVALT)
+ ZWT1=ZE36
+ ENDWHERE
+ DO JH=1,SIZE(ZWT1)
+ IF(ZWT1(JH) /= ZE36)THEN
+ ZMIN=ZWT1(JH)
+ ZMAX=ZWT1(JH)
+ EXIT
+ ENDIF
+ ENDDO
+ DO JH=1,SIZE(ZWT1)
+ IF(ZWT1(JH) /= ZE36)THEN
+ ZMIN=MIN(ZMIN,ZWT1(JH))
+ ZMAX=MAX(ZMAX,ZWT1(JH))
+ ENDIF
+ ENDDO
+ ZWL=ZMIN
+ ZWR=ZMAX
+ ELSE
+ ZWL=MINVAL(ZWT1)
+ ZWR=MAXVAL(ZWT1)
+ ENDIF
+! Mai 2000
+ IF(LTIMEUSER)THEN
+ ZWL=XTIMEMIN
+ ZWR=XTIMEMAX
+ ENDIF
+! Mai 2000
+ DEALLOCATE(ZWT1)
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+! Fin Determination du min et du max du temps
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+!
+!
+!************ Debut Boucle DO J=1,IPAGE *************************************
+!
+!
+ DO J=1,IPAGE
+ if(nverbia >0)then
+ print *,' IPAGE ',IPAGE
+ endif
+
+ IF(LPVKT1)THEN
+ JAF=NSUPERDIA
+ ELSE
+ JAF=1
+ ENDIF
+ if(nverbia >0)then
+ print *,' IPAGE JAF ',IPAGE,JAF
+ endif
+
+ DO JA=1,JAF
+
+ IF(LPVKT1)THEN
+
+ if(nverbia >0)then
+ print *,' IND INB JA AV LPVKT1 NBLVLKDIA(JA,IST(IND) ',IND,INB,JA ,LPVKT1,NBLVLKDIA(JA,IST(IND))
+ endif
+ IF(JA /= 1)THEN
+ IND=IND+NBLVLKDIA(JA-1,NNDIA(1,JA-1))
+ ENDIF
+ INB=INB+NBLVLKDIA(JA,IST(IND))
+ if(nverbia > 0)then
+ print *,' IND INB AP JA IST(IND) NBLVLKDIA(JA,IST(IND)) ',IND,INB, &
+ JA,IST(IND),NBLVLKDIA(JA,IST(IND))
+ endif
+! INB=NBLVLKDIA(JA,IST(IND))
+
+
+ ELSE
+
+ IF(J == IPAGE)THEN
+ IF(IREST == 0)THEN
+ INB=IBCP ! 3 courbes par diagramme !!!!
+ !INB=8
+ ELSE
+ INB=IREST
+ ENDIF
+ ELSE
+ INB=IBCP ! 3 courbes par diagramme !!!!
+ !INB=8
+ ENDIF
+
+ ENDIF
+!
+!************ Debut Boucle DO JJ=1,INB **************************************
+!
+ if(nverbia > 0)then
+ print *,' LPVT LPVKT LPVKT1 NSUPERDIA IND INB ',LPVT,LPVKT,LPVKT1, &
+ NSUPERDIA,IND,INB
+ endif
+ DO JJ=IND,INB
+! DO JJ=1,INB
+ INUM=INUM+1
+ IC=ICOMPTSZ(INUM)
+ ALLOCATE(ZWT1(IC),ZWT2(IC))
+ ZWT1(:)=ZWORK1D(1:IC,INUM)
+ ZWT2(:)=ZWORKT(1:IC,INUM)
+! mai 2000
+ IF(LSPVALT)THEN
+ WHERE(ZWT1 == XSPVALT)
+ ZWT1=ZE36
+ ENDWHERE
+ ENDIF
+
+ IF(.NOT.LPVKT1)THEN
+ ZBOT=.1; ZTOP=.85
+! ZWL=PWORKT(1); ZWR=PWORKT(SIZE(PWORKT,1))
+!
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+! Determination des viewports
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+!
+ IF(JJ == 1)THEN
+ ! 3 courbes par diagramme !!!!
+ !ZDEBY=((ZTOP-ZBOT) - (.15*((INB+1)/2) + .05*((INB+1)/2-1)))/2 +ZBOT
+ ZDEBY=((ZTOP-ZBOT) - (.15*((INB+1)/IBC) + .05*((INB+1)/2-1)))/2 +ZBOT
+ ZDEBYB=ZDEBY-.03
+ ZBOTB=ZDEBY
+ ENDIF
+
+ !IF(MOD(JJ,2) /=0)THEN
+ IF(MOD(JJ,IBC) /=0)THEN
+ INCR=IBC-MOD(JJ,IBC)
+ !ZDEBY=ZBOTB+(.15+.05)*((JJ+1)/2-1)
+ ZDEBY=ZBOTB+(.15+.05)*((JJ+INCR)/2-1)
+ ENDIF
+
+! print *,' JJ ZDEBY ',JJ,ZDEBY
+
+ IF(JJ == INB)THEN
+ ZDEBYT=ZDEBY+.15+.05
+ ENDIF
+
+ ZVB=ZDEBY; ZVT=ZVB+.15
+
+ ELSE
+
+ IF(JA == 1)THEN
+ ZVB=.1; ZVT=.9
+ ZVL=.1; ZVR=.9
+ ELSE
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZW1,ZW2,ZW3,ZW4,IDA)
+ XCURVPTL=ZVL;XCURVPTR=ZVR;XCURVPTB=ZVB;XCURVPTT=ZVT
+ ENDIF
+
+ ENDIF
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+! Fin Determination des viewports
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+!
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+! Determination des min et des max des variables
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+!
+ IF(LPVKT1 .AND. .NOT.LZT)THEN
+! IF(JJ == 1)THEN
+ IF(JJ == IND)THEN
+
+ IF(LMNMXUSER)THEN
+
+ CALL READMNMX_FT_PVKT(YGROUP(INUM),ZMIN,ZMAX)
+ IF(LOK)THEN
+ LOK=.FALSE.
+ ELSE
+ ZMIN=ZPVMNMX(INUM,1); ZMAX=ZPVMNMX(INUM,2)
+! ZMIN=XPVMIN; ZMAX=XPVMAX
+ ENDIF
+ ELSE
+ ZMIN=ZPVMNMX(INUM,1); ZMAX=ZPVMNMX(INUM,2)
+! ZMIN=XPVMIN; ZMAX=XPVMAX
+
+ ENDIF
+
+ ENDIF
+
+ ELSE IF(LZT)THEN
+
+ IF(JA == 1)THEN
+ IF(LMNMXUSER)THEN
+ IF(XZTMAX > XZTMIN)THEN
+ ZMIN=XZTMIN
+ ZMAX=XZTMAX
+ ELSE
+ print *,' Vous pouvez fournir les bornes en Z dans XZTMIN et XZTMAX et LMNMXUSER=T '
+ ZMIN=MINVAL(ZPVMNMX(:,1))
+ ZMAX=MAXVAL(ZPVMNMX(:,2))
+ ENDIF
+ ELSE
+ ZMIN=MINVAL(ZPVMNMX(:,1))
+ ZMAX=MAXVAL(ZPVMNMX(:,2))
+ ENDIF
+
+ ENDIF
+
+ ELSE
+
+ IF(LMNMXUSER)THEN
+
+ CALL READMNMX_FT_PVKT(YGROUP(INUM),ZMIN,ZMAX)
+
+ IF(LOK)THEN
+ LOK=.FALSE.
+ ELSE
+
+ IF(.NOT.LPVKT .OR. (LPVKT .AND.L1K))THEN
+! Mai 2000
+ IF(LSPVALT)THEN
+ DO JH=1,SIZE(ZWT1)
+ IF(ZWT1(JH) /= ZE36)THEN
+ ZMIN=ZWT1(JH)
+ ZMAX=ZWT1(JH)
+ EXIT
+ ENDIF
+ ENDDO
+ DO JH=1,SIZE(ZWT1)
+ IF(ZWT1(JH) /= ZE36)THEN
+ ZMIN=MIN(ZMIN,ZWT1(JH))
+ ZMAX=MAX(ZMAX,ZWT1(JH))
+ ENDIF
+ ENDDO
+ ELSE
+ ZMIN=MINVAL(ZWT1)
+ ZMAX=MAXVAL(ZWT1)
+ ENDIF
+ print *,' TROUVES :ZMIN,ZMAX,LSPVALT ',ZMIN,ZMAX,LSPVALT
+ IF(.NOT.LFTBAUTO)THEN
+ CALL VALMNMX(ZMIN,ZMAX)
+ IF(ABS(ZMAX-ZMIN) <= 1.E-3)THEN
+ ZMIN=ZMIN-1.
+ ZMAX=ZMAX+1.
+ ENDIF
+ ELSE
+ IF(ABS(ZMAX-ZMIN) == 0.)THEN
+ ZMIN=ZMIN-2.5*TINY(1.)
+ ZMAX=ZMAX+2.5*TINY(1.)
+ ENDIF
+ ENDIF
+ print *,' RETENUS :ZMIN,ZMAX,LSPVALT ',ZMIN,ZMAX,LSPVALT
+ ELSE
+ ZMIN=XPVMIN; ZMAX=XPVMAX
+ ENDIF
+
+ ENDIF
+
+ ELSE
+
+ IF(.NOT.LPVKT .OR. (LPVKT .AND.L1K))THEN
+! Mai 2000
+ IF(LSPVALT)THEN
+ DO JH=1,SIZE(ZWT1)
+ IF(ZWT1(JH) /= ZE36)THEN
+ ZMIN=ZWT1(JH)
+ ZMAX=ZWT1(JH)
+ EXIT
+ ENDIF
+ ENDDO
+ DO JH=1,SIZE(ZWT1)
+ IF(ZWT1(JH) /= ZE36)THEN
+ ZMIN=MIN(ZMIN,ZWT1(JH))
+ ZMAX=MAX(ZMAX,ZWT1(JH))
+ ENDIF
+ ENDDO
+ ELSE
+ ZMIN=MINVAL(ZWT1)
+ ZMAX=MAXVAL(ZWT1)
+ ENDIF
+ print *,' TROUVES :ZMIN,ZMAX,LSPVALT ',ZMIN,ZMAX,LSPVALT
+ IF(.NOT.LFTBAUTO)THEN
+ CALL VALMNMX(ZMIN,ZMAX)
+ IF(ABS(ZMAX-ZMIN) <= 1.E-3)THEN
+ ZMIN=ZMIN-1.
+ ZMAX=ZMAX+1.
+ ENDIF
+ ELSE
+ IF(ABS(ZMAX-ZMIN) == 0.)THEN
+ ZMIN=ZMIN-2.5*TINY(1.)
+ ZMAX=ZMAX+2.5*TINY(1.)
+ ENDIF
+ ENDIF
+ print *,' RETENUS :ZMIN,ZMAX,LSPVALT ',ZMIN,ZMAX,LSPVALT
+ ELSE
+ ZMIN=XPVMIN; ZMAX=XPVMAX
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+ print *,' ZMIN,ZMAX ',ZMIN,ZMAX
+ ZWB=ZMIN; ZWT=ZMAX
+
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+! Fin Determination des min et des max des variables
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+!
+! -----------------------------------------------------------------------
+! Debut Format Labels axes
+! -----------------------------------------------------------------------
+ IF(.NOT.LPVKT1 .OR. (LPVKT1 .AND. JJ == IND))THEN
+! IF(.NOT.LPVKT1 .OR. (LPVKT1 .AND. JJ == 1))THEN
+
+ IF(ZWR /= 0.)THEN ! test sur ZWR
+ IF(LOG10(ABS(ZWR)) >= 6. .OR. LOG10(ABS(ZWR)) <= -1.)THEN !***********
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(E8.2)'
+ ENDIF
+
+! -----------------------------------------------------------------------
+! ZWT /= 0.
+ IF(ZWT /= 0.)THEN
+ IF(LOG10(ABS(ZWT)) >= 6. .OR. LOG10(ABS(ZWT)) <= -1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(E8.2)','(E8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ IF(ABS(ZWT-ZWB) < 1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(E8.2)','(F8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(F8.1)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(E8.2)','(F8.1)',0,0,10,10,1,0,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE
+! ZWT == 0.
+ IF(LOG10(ABS(ZWB)) >= 6. .OR. LOG10(ABS(ZWB)) <= -1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(E8.2)','(E8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ IF(ABS(ZWT-ZWB) < 1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(E8.2)','(F8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(F8.1)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(E8.2)','(F8.1)',0,0,10,10,1,0,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+
+! -----------------------------------------------------------------------
+ ELSE !************
+
+ IF(ABS(ZWR-ZWL) < 1.)THEN !++++++++++++
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F8.2)'
+ ENDIF
+! -----------------------------------------------------------------------
+! ZWT /= 0.
+ IF(ZWT /= 0.)THEN
+ IF(LOG10(ABS(ZWT)) >= 6. .OR. LOG10(ABS(ZWT)) <= -1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.2)','(E8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ IF(ABS(ZWT-ZWB) < 1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.2)','(F8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(F8.1)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.2)','(F8.1)',0,0,10,10,1,0,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE
+! ZWT == 0.
+ IF(LOG10(ABS(ZWB)) >= 6. .OR. LOG10(ABS(ZWB)) <= -1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.2)','(E8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ IF(ABS(ZWT-ZWB) < 1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.2)','(F8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(F8.1)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.2)','(F8.1)',0,0,10,10,1,0,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+! -----------------------------------------------------------------------
+
+ ELSE !++++++++++++
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F8.1)'
+ ENDIF
+
+!! INTRODUIRE INSTRUCTIONS DE GESTION ZWT=0. ou ZWT <0
+! -----------------------------------------------------------------------
+! ZWT /= 0.
+ IF(ZWT /= 0.)THEN
+ IF(LOG10(ABS(ZWT)) >= 6. .OR. LOG10(ABS(ZWT)) <= -1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.1)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.1)','(E8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ IF(ABS(ZWT-ZWB) < 1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.1)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.1)','(F8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.1)','(F8.1)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.1)','(F8.1)',0,0,10,10,1,0,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ ELSE
+! ZWT == 0.
+ IF(LOG10(ABS(ZWB)) >= 6. .OR. LOG10(ABS(ZWB)) <= -1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.1)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.1)','(E8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ IF(ABS(ZWT-ZWB) < 1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.1)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.1)','(F8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.1)','(F8.1)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.1)','(F8.1)',0,0,10,10,1,0,0)
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+! -----------------------------------------------------------------------
+
+ ENDIF !++++++++++++
+
+ ENDIF !************
+
+ ELSE ! test sur ZWR
+
+! ZWR = 0
+ IF(LOG10(ABS(ZWR-ZWL)) >= 6. .OR. LOG10(ABS(ZWR-ZWL)) <= -1.)THEN
+
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(E8.2)'
+ ENDIF
+ IF(LOG10(ABS(ZWT-ZWB)) >= 6. .OR. LOG10(ABS(ZWT-ZWB)) <= -1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(E8.2)','(E8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE IF(ABS(ZWT-ZWB) <1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(E8.2)','(F8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(E8.2)','(F8.1)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(E8.2)','(F8.1)',0,0,10,10,1,0,0)
+ ENDIF
+ ENDIF
+
+ ELSE IF(ABS(ZWR-ZWL) < 1.)THEN
+
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F8.2)'
+ ENDIF
+ IF(LOG10(ABS(ZWT-ZWB)) >= 6. .OR. LOG10(ABS(ZWT-ZWB)) <= -1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.2)','(E8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE IF(ABS(ZWT-ZWB) <1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.2)','(F8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.2)','(F8.1)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.2)','(F8.1)',0,0,10,10,1,0,0)
+ ENDIF
+ ENDIF
+
+ ELSE
+
+ FORMAX=' '
+ IF(LFMTAXEX)THEN
+ FORMAX="("//CFMTAXEX(1:LEN_TRIM(CFMTAXEX))//")"
+ ELSE
+ FORMAX='(F8.1)'
+ ENDIF
+ IF(LOG10(ABS(ZWT-ZWB)) >= 6. .OR. LOG10(ABS(ZWT-ZWB)) <= -1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(E8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.1)','(E8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.1)','(E8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE IF(ABS(ZWT-ZWB) <1.)THEN
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.2)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.1)','(F8.2)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.1)','(F8.2)',0,0,10,10,1,0,0)
+ ENDIF
+ ELSE
+ FORMAY=' '
+ IF(LFMTAXEY)THEN
+ FORMAY="("//CFMTAXEY(1:LEN_TRIM(CFMTAXEY))//")"
+ ELSE
+ FORMAY='(F8.1)'
+ ENDIF
+ IF(MOD(JJ,2) /=0)THEN
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,0,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,0,0,0)
+! CALL LABMOD('(F8.1)','(F8.1)',0,0,10,10,0,0,0)
+ ELSE
+ CALL LABMOD(FORMAX,FORMAY,0,0,NSZLBX,NSZLBY,1,0,0)
+! CALL LABMOD(FORMAX,FORMAY,0,0,10,10,1,0,0)
+! CALL LABMOD('(F8.1)','(F8.1)',0,0,10,10,1,0,0)
+ ENDIF
+ ENDIF
+
+ ENDIF
+
+ ENDIF ! Fin test sur ZWR
+
+ ENDIF
+
+! -----------------------------------------------------------------------
+! Fin Format Labels axes
+! -----------------------------------------------------------------------
+
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+! print *,' ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT ',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+ IF(LPVKT1)THEN
+ IF(MOD(JA,2) == 0)THEN
+ ZY=ZWT+(ZWT-ZWB)/18.
+ ELSE
+ ZY=ZWT+(ZWT-ZWB)/35
+ ENDIF
+ ELSE
+ ZY=ZWT-(ZWT-ZWB)/10.
+ ENDIF
+!
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+! Determination de la couleur
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+!
+
+! Mai 2000
+ CALL GSLWSC(XLWFTALL)
+ IF(LCOLINE)THEN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!=====================================
+! Couleur Cas LFT ou (LPVKT .AND.L1K)
+!=====================================
+!
+ IF(.NOT.LPVKT .AND..NOT.LPVKT1 .OR. (LPVKT .AND.L1K))THEN !*********************
+
+ IF(LCOLUSER)THEN !+++++++++++++++++++++++++++++++++++++++++++
+
+ YGP(1:LEN(YGP))=' '
+ DO JGP=1,LEN_TRIM(YGROUP(INUM))
+ IF(YGROUP(INUM)(JGP:JGP) == ' ')THEN
+ YGP=YGROUP(INUM)(1:JGP-1)
+ YGP=ADJUSTL(YGP)
+ EXIT
+ ENDIF
+ ENDDO
+! Septembre 2001
+ IF(YGP(1:4) == 'MASK')THEN
+ YGP(1:LEN(YGP))=' '
+ YGP=YGROUP(INUM)(JGP:LEN_TRIM(YGROUP(INUM)))
+ YGP=ADJUSTL(YGP)
+ JGPA=MIN(INDEX(YGP,' '),LEN_TRIM(YGROUP(INUM)))
+ IF (JGPA < LEN_TRIM(YGROUP(INUM)))THEN
+ YGP(JGPA:LEN_TRIM(YGROUP(INUM)))=' '
+ ENDIF
+ ENDIF
+! Septembre 2001
+ if(nverbia >0)then
+ print *,' ** VARFCT YGP 1a ',YGP
+ endif
+ IF(YGP(1:LEN(YGP)) == ' ')THEN
+ YGP=YGROUP(INUM)
+ YGP=ADJUSTL(YGP)
+ ENDIF
+ if(nverbia >0)then
+ print *,' ** VARFCT YGP 1b ',YGP
+ endif
+ ICOL=0
+ CALL READCOL_FT_PVKT(YGP(1:LEN_TRIM(YGP)),ICOL)
+ if(nverbia >0)then
+ print *,' ** VARFCT ICOL ',ICOL
+ endif
+
+ IF(ICOL == 0)THEN
+ print *,' INDICE DE COULEUR POUR ',ADJUSTL(YGROUP(INUM)(1:LEN_TRIM &
+ (YGROUP(INUM)))),' ? '
+ READ(5,*,END=15)ICOL
+ GO TO 25
+ 15 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ READ(5,*)ICOL
+ 25 CONTINUE
+ !WRITE(YCAR80,*)ICOL
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ICOL)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ CALL LOADMNMX_FT_PVKT('XPVKTCOL_'//YGP(1:LEN_TRIM(YGP))//'=',1,FLOAT(ICOL),7)
+ ENDIF
+
+! CALL GSLN(1)
+!******************************************************************************
+!******************************************************************************
+ IF(MOD(JJ,2) == 1)THEN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ IF(LFTSTYLUSER )THEN
+ print *,' Rentrez le type de trait voulu :'
+ print *,' Trait plein : 1, Tiretes : 2, Pointilles : 3, Tiretes longs-courts : 4'
+ read(5,*,END=80)ISLNFT1
+ GO TO 70
+ 80 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)ISLNFT1
+ 70 CONTINUE
+ !WRITE(YCAR80,*)ISLNFT1
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ISLNFT1)
+
+ print *,' Epaisseur des traits ? (valeur de base 1) '
+ read(5,*,END=82)EPAIS
+ GO TO 72
+ 82 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)EPAIS
+ 72 CONTINUE
+ !WRITE(YCAR80,*)EPAIS
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,EPAIS)
+ CALL GSLWSC(EPAIS)
+! CALL GSLN(ISLNFT1)
+ CALL GSLN(1)
+ IF(ISLNFT1 == 1)CALL AGSETR('DAS/PA/1.',65535.)
+ IF(ISLNFT1 == 2)CALL AGSETR('DAS/PA/1.',30583.)
+ IF(ISLNFT1 == 3)CALL AGSETR('DAS/PA/1.',21845.)
+ IF(ISLNFT1 == 4)CALL AGSETR('DAS/PA/1.',10023.)
+ ELSE
+ CALL GSLN(1)
+ ENDIF
+
+ ELSE IF(MOD(JJ,2) == 0)THEN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Modif pour JMartial
+
+ IF(LFTSTYLUSER )THEN
+ print *,' Rentrez le type de trait voulu :'
+ print *,' Trait plein : 1, Tiretes : 2, Pointilles : 3, Tiretes longs-courts : 4'
+ read(5,*,END=81)ISLNFT2
+ GO TO 71
+ 81 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)ISLNFT2
+ 71 CONTINUE
+ !WRITE(YCAR80,*)ISLNFT2
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ISLNFT2)
+! CALL GSLN(ISLNFT2)
+ CALL GSLN(1)
+ IF(ISLNFT2 == 1)CALL AGSETR('DAS/PA/1.',65535.)
+ IF(ISLNFT2 == 2)CALL AGSETR('DAS/PA/1.',30583.)
+ IF(ISLNFT2 == 3)CALL AGSETR('DAS/PA/1.',21845.)
+ IF(ISLNFT2 == 4)CALL AGSETR('DAS/PA/1.',10023.)
+ print *,' Epaisseur des traits ? (valeur de base 1) '
+ read(5,*,END=83)EPAIS
+ GO TO 73
+ 83 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)EPAIS
+ 73 CONTINUE
+ !WRITE(YCAR80,*)EPAIS
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,EPAIS)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ CALL GSLWSC(EPAIS)
+ ELSE
+ CALL GSLN(1)
+ ENDIF
+
+ ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!******************************************************************************
+!******************************************************************************
+ CALL GSPLCI(ICOL)
+ CALL GSTXCI(ICOL)
+
+ ELSE !+++++++++++++++++++++++++++++++++++++++++++
+
+!******************************************************************************
+!******************************************************************************
+
+ IF(MOD(JJ,2) == 1)THEN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ IF(LFTSTYLUSER )THEN
+ print *,' Rentrez le type de trait voulu :'
+ print *,' Trait plein : 1, Tiretes : 2, Pointilles : 3, Tiretes longs-courts : 4'
+ read(5,*,END=84)ISLNFT1
+ GO TO 74
+ 84 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)ISLNFT1
+ 74 CONTINUE
+ !WRITE(YCAR80,*)ISLNFT1
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ISLNFT1)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+
+ print *,' Epaisseur des traits ? (valeur de base 1) '
+ read(5,*,END=86)EPAIS
+ GO TO 76
+ 86 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)EPAIS
+ 76 CONTINUE
+ !WRITE(YCAR80,*)EPAIS
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,EPAIS)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ CALL GSLWSC(EPAIS)
+! CALL GSLN(ISLNFT1)
+ CALL GSLN(1)
+ IF(ISLNFT1 == 1)CALL AGSETR('DAS/PA/1.',65535.)
+ IF(ISLNFT1 == 2)CALL AGSETR('DAS/PA/1.',30583.)
+ IF(ISLNFT1 == 3)CALL AGSETR('DAS/PA/1.',21845.)
+ IF(ISLNFT1 == 4)CALL AGSETR('DAS/PA/1.',10023.)
+ ELSE
+ CALL GSLN(1)
+ ENDIF
+
+ ELSE IF(MOD(JJ,2) == 0)THEN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Modif pour JMartial
+ IF(LFTSTYLUSER )THEN
+ print *,' Rentrez le type de trait voulu :'
+ print *,' Trait plein : 1, Tiretes : 2, Pointilles : 3, Tiretes longs-courts : 4'
+ read(5,*,END=85)ISLNFT2
+ GO TO 75
+ 85 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)ISLNFT2
+ 75 CONTINUE
+ !WRITE(YCAR80,*)ISLNFT2
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ISLNFT2)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+! CALL GSLN(ISLNFT2)
+ CALL GSLN(1)
+ IF(ISLNFT2 == 1)CALL AGSETR('DAS/PA/1.',65535.)
+ IF(ISLNFT2 == 2)CALL AGSETR('DAS/PA/1.',30583.)
+ IF(ISLNFT2 == 3)CALL AGSETR('DAS/PA/1.',21845.)
+ IF(ISLNFT2 == 4)CALL AGSETR('DAS/PA/1.',10023.)
+ print *,' Epaisseur des traits ? (valeur de base 1) '
+ read(5,*,END=87)EPAIS
+ GO TO 77
+ 87 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)EPAIS
+ 77 CONTINUE
+ !WRITE(YCAR80,*)EPAIS
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,EPAIS)
+ CALL GSLWSC(EPAIS)
+ ELSE
+ CALL GSLN(1)
+ ENDIF
+
+ ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!******************************************************************************
+!******************************************************************************
+ CALL GSTXCI(JJ+1)
+ CALL GSPLCI(JJ+1)
+ ENDIF !+++++++++++++++++++++++++++++++++++++++++++
+
+!
+!====================================
+! Couleur dans le cas LPVKT et LPVKT1
+!====================================
+!
+
+ ELSE !*********************
+
+ IF(LCOLUSER)THEN !==============================
+
+ IF(INUM == 1 .OR. ( LPVKT1 .AND. JJ == IND))THEN
+ IF(LPVKT1 .AND. JJ == IND)THEN
+ print *,' INDICE DE COULEUR ', &
+ ' POUR ',ADJUSTL(YGROUP(INUM)(1:LEN_TRIM(YGROUP(INUM)))), &
+ ' (1 entier) ? '
+ READ(5,*,END=17)ICOL1
+ ELSE
+ print *,' INDICES DE COULEUR ', &
+ ' POUR LES NIVEAUX DEMANDES DE RANG IMPAIR PUIS DE RANG', &
+ ' PAIR (2 entiers separes par un blanc) ? '
+ READ(5,*,END=17)ICOL1,ICOL2
+ ENDIF
+ GO TO 27
+ 17 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ IF(LPVKT1 .AND. JJ == IND)THEN
+ READ(5,*)ICOL1
+ ELSE
+ READ(5,*)ICOL1,ICOL2
+ ENDIF
+ 27 CONTINUE
+ IF(LPVKT1 .AND. JJ == IND)THEN
+ !WRITE(YCAR80,*)ICOL1
+ CALL WRITEDIR(NDIR,ICOL1)
+ ELSE
+ !WRITE(YCAR80,*)ICOL1,ICOL2
+ CALL WRITEDIR(NDIR,(/ICOL1,ICOL2/))
+ ENDIF
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ !CALL WRITEDIR(NDIR,YCAR80)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ CALL GSLN(1)
+ IF(LPVKT1 .AND. JJ == IND)THEN
+ CALL GSPLCI(ICOL1)
+ CALL GSTXCI(ICOL1)
+ ELSE
+ SELECT CASE(MOD(JJ,2))
+ CASE(0)
+ CALL GSPLCI(ICOL2)
+ CALL GSTXCI(ICOL2)
+ CASE DEFAULT
+ CALL GSPLCI(ICOL1)
+ CALL GSTXCI(ICOL1)
+ END SELECT
+ ENDIF
+
+ ELSE ! INUM > 1
+
+ CALL GSLN(1)
+ IF(LPVKT1)THEN
+ CALL GSPLCI(ICOL1)
+ CALL GSTXCI(ICOL1)
+ ELSE
+ SELECT CASE(MOD(JJ,2))
+ CASE(0)
+ CALL GSPLCI(ICOL2)
+ CALL GSTXCI(ICOL2)
+ CASE DEFAULT
+ CALL GSPLCI(ICOL1)
+ CALL GSTXCI(ICOL1)
+ END SELECT
+ ENDIF
+
+ ENDIF
+
+ ELSE !==============================(.NOT.LCOLUSER)
+
+ CALL GSLN(1)
+ IF(LPVKT1)THEN
+ CALL GSPLCI(JA+1)
+ CALL GSTXCI(JA+1)
+ ELSE
+ SELECT CASE(MOD(JJ,2))
+ CASE(0)
+ CALL GSPLCI(2)
+ CALL GSTXCI(2)
+ CASE DEFAULT
+ CALL GSPLCI(3)
+ CALL GSTXCI(3)
+ END SELECT
+ ENDIF
+
+ ENDIF !===============================
+
+
+!
+!============
+! Fin couleur
+!============
+
+ ENDIF !*********************
+!
+! Noir et blanc
+!
+ ELSE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ CALL GSTXCI(1)
+ CALL GSPLCI(1)
+ ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+! Fin Determination de la couleur
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+!
+!
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+! Ecriture titres sur chaque courbe
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+!
+ SELECT CASE(CTYPE)
+ CASE('SSOL','DRST','RSPL','RAPL')
+ YGROUP(INUM)(1+5:LEN_TRIM(YGROUP(INUM))+5)=YGROUP(INUM)(1:LEN_TRIM(YGROUP(INUM)))
+ YGROUP(INUM)(1:5)=' '
+ WRITE(YGROUP(INUM)(1:4),'(I4)')IST(INUM)
+ YGROUP(INUM)=ADJUSTL(ADJUSTR(YGROUP(INUM)))
+ END SELECT
+
+ IF(LPVKT1 .AND. JJ == IND)THEN
+!**************** A FAIRE *****************************************
+
+ IF(.NOT.LZT)THEN
+ CALL GSCLIP(0)
+ ZX=ZWL-(ZWR-ZWL)/70.+(JA-1)*(ZWR-ZWL)/5.
+ YCAR30(1:LEN(YCAR30))=' '
+ YCAR30=ADJUSTL(YGROUP(INUM)(1:LEN_TRIM(YGROUP(INUM))))
+ CALL PLCHHQ(ZX,ZY,YCAR30,.011,0.,-1.)
+! CALL PLCHHQ(ZX,ZY,ADJUSTL(YGROUP(INUM)(1:LEN_TRIM(YGROUP(INUM)))),.011,0.,-1.)
+ CALL GSCLIP(1)
+ ENDIF
+
+ ELSE IF(.NOT.LPVKT1)THEN
+
+ CALL GQLWSC(IER,ZLW)
+ CALL GQLN(IER,ILN)
+ CALL GSLWSC(1.)
+ CALL GSLN(1)
+
+ IF(MOD(JJ,2) /= 0)THEN
+ ZX=ZWL+(ZWR-ZWL)/100.
+
+ IF(LTITFTUSER)THEN
+ YCAR30(1:LEN(YCAR30))=' '
+ print *,' Titre courant : ',ADJUSTL(YGROUP(INUM)(1:LEN_TRIM(YGROUP(INUM))))
+ print *,' Rentrez le nouveau titre (30 car. Max et entre quotes)'
+ read(5,*,END=54)YCAR30
+ GO TO 64
+ 54 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)YCAR30
+ 64 CONTINUE
+ YCAR30=ADJUSTL(YCAR30)
+ YCAR80(1:1)="'"
+ YCAR80(LEN_TRIM(YCAR30)+2:LEN_TRIM(YCAR30)+2)="'"
+ YCAR80(2:LEN_TRIM(YCAR30)+1)=YCAR30(1:LEN_TRIM(YCAR30))
+! WRITE(YCAR80,*)YCAR30
+ YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,YCAR80)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ CALL PLCHHQ(ZX,ZY,YCAR30,.011,0.,-1.)
+
+ ELSE
+
+ YCAR30(1:LEN(YCAR30))=' '
+ YCAR30=ADJUSTL(YGROUP(INUM)(1:LEN_TRIM(YGROUP(INUM))))
+ CALL PLCHHQ(ZX,ZY,YCAR30,.011,0.,-1.)
+! CALL PLCHHQ(ZX,ZY,ADJUSTL(YGROUP(INUM)(1:LEN_TRIM(YGROUP(INUM)))),.011,0.,-1.)
+ ENDIF
+
+ ELSE
+
+ ZX=ZWR-(ZWR-ZWL)/100.
+
+ IF(LTITFTUSER)THEN
+ YCAR30(1:LEN(YCAR30))=' '
+ print *,' Titre courant : ',ADJUSTL(YGROUP(INUM)(1:LEN_TRIM(YGROUP(INUM))))
+ print *,' Rentrez le nouveau titre (30 car. Max et entre quotes)'
+ read(5,*,END=55)YCAR30
+ GO TO 65
+ 55 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)YCAR30
+ 65 CONTINUE
+ YCAR30=ADJUSTL(YCAR30)
+ YCAR80(1:1)="'"
+ YCAR80(LEN_TRIM(YCAR30)+2:LEN_TRIM(YCAR30)+2)="'"
+ YCAR80(2:LEN_TRIM(YCAR30)+1)=YCAR30(1:LEN_TRIM(YCAR30))
+! WRITE(YCAR80,*)YCAR30
+ YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,YCAR80)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+ YCAR30=ADJUSTR(YCAR30)
+ CALL PLCHHQ(ZX,ZY,YCAR30,.011,0.,1.)
+ ELSE
+ YCAR30(1:LEN(YCAR30))=' '
+ YCAR30=ADJUSTL(YGROUP(INUM)(1:LEN_TRIM(YGROUP(INUM))))
+ YCAR30=ADJUSTR(YCAR30)
+ CALL PLCHHQ(ZX,ZY,YCAR30,.011,0.,+1.)
+! CALL PLCHHQ(ZX,ZY,ADJUSTL(YGROUP(INUM)(1:LEN_TRIM(YGROUP(INUM)))),.011,0.,1.)
+ ENDIF
+
+ ENDIF
+
+ CALL GSLN(ILN)
+ CALL GSLWSC(ZLW)
+
+ ENDIF
+!**************** A FAIRE *****************************************
+!
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+! Trace des courbes en couleur
+!½½½½½½½½½½½½½½½½½½½½½½½½½½½½½
+!
+ IF(LCOLINE)THEN
+
+ DO JI=1,IBRECOUV(INUM)
+
+ JD=IRECOUV(JI*2-1,INUM)
+ JF=IRECOUV(JI*2,INUM)
+! print *,' JD JF AVANT ',JD,JF
+! 270896 !!!!!!!!!!!!!!!
+ SELECT CASE(CTYPE)
+ CASE('DRST','RSPL','RAPL')
+ J2=IST(INUM)
+! J2=NLOOPN
+ CASE DEFAULT
+ J2=1
+ END SELECT
+
+ IF(LFT .OR. (LPVKT .AND. L1K))THEN
+
+ IF(.NOT. LTINCRDIA(INUM,J2))THEN !.......
+
+ DO JE=1,NBTIMEDIA(INUM,J2)
+ IF(NTIMEDIA(JE,INUM,J2) >= JD)THEN
+ JD=JE
+ EXIT
+ ENDIF
+ ENDDO
+
+ DO JE=1,NBTIMEDIA(INUM,J2)
+ IF(NTIMEDIA(JE,INUM,J2) == JF)THEN
+ JF=JE
+ EXIT
+ ELSE IF(NTIMEDIA(JE,INUM,J2) > JF)THEN
+ JF=JE-1
+ EXIT
+ ENDIF
+ ENDDO
+ JF=MIN(JF,NBTIMEDIA(INUM,J2))
+
+ ELSE !.......
+
+ JJE=0
+
+ DO JE=NTIMEDIA(1,INUM,J2),NTIMEDIA(2,INUM,J2),NTIMEDIA(3,INUM,J2)
+ JJE=JJE+1
+ IF(JE >= JD)THEN
+ JD=JJE
+ EXIT
+ ENDIF
+ ENDDO
+
+ JJE=0
+
+ DO JE=NTIMEDIA(1,INUM,J2),NTIMEDIA(2,INUM,J2),NTIMEDIA(3,INUM,J2)
+ JJE=JJE+1
+ IF(JE == JF)THEN
+ JF=JJE
+ EXIT
+ ELSE IF(JE > JF)THEN
+ JF=MIN(JF,JJE-1)
+ EXIT
+ ENDIF
+ ENDDO
+
+ JJE=0
+
+ DO JE=NTIMEDIA(1,INUM,J2),NTIMEDIA(2,INUM,J2),NTIMEDIA(3,INUM,J2)
+ JJE=JJE+1
+ ENDDO
+
+! JF=MIN(JF,NTIMEDIA(2,INUM,J2))
+ JF=MIN(JF,JJE)
+
+ ENDIF !.......
+
+ ELSE IF((LPVKT .AND. .NOT.L1K) .OR. LPVKT1)THEN
+
+ IF(.NOT. LTINCRDIA(JA,J2))THEN !.......
+
+ DO JE=1,NBTIMEDIA(JA,J2)
+ IF(NTIMEDIA(JE,JA,J2) >= JD)THEN
+ JD=JE
+ EXIT
+ ENDIF
+ ENDDO
+
+ DO JE=1,NBTIMEDIA(JA,J2)
+ IF(NTIMEDIA(JE,JA,J2) == JF)THEN
+ JF=JE
+ EXIT
+ ELSE IF(NTIMEDIA(JE,JA,J2) > JF)THEN
+ JF=JE-1
+ EXIT
+ ENDIF
+ ENDDO
+
+ JF=MIN(JF,NBTIMEDIA(JA,J2))
+! print *,' JD JF APRES ',JD,JF
+! print *,' ZWT2 ',ZWT2(JD:JF)
+
+ ELSE !.......
+
+ JJE=0
+
+ DO JE=NTIMEDIA(1,JA,J2),NTIMEDIA(2,JA,J2),NTIMEDIA(3,JA,J2)
+ JJE=JJE+1
+ IF(JE >= JD)THEN
+ JD=JJE
+ EXIT
+ ENDIF
+ ENDDO
+
+ JJE=0
+
+ DO JE=NTIMEDIA(1,JA,J2),NTIMEDIA(2,JA,J2),NTIMEDIA(3,JA,J2)
+ JJE=JJE+1
+ IF(JE == JF)THEN
+ JF=JJE
+ EXIT
+ ELSE IF(JE > JF)THEN
+ JF=MIN(JF,JJE-1)
+ EXIT
+ ENDIF
+ ENDDO
+
+ JJE=0
+
+ DO JE=NTIMEDIA(1,JA,J2),NTIMEDIA(2,JA,J2),NTIMEDIA(3,JA,J2)
+ JJE=JJE+1
+ ENDDO
+
+ JF=MIN(JF,JJE)
+! JF=MIN(JF,NTIMEDIA(2,JA,J2))
+! print *,' JD JF APRES ',JD,JF
+! print *,' ZWT2 ',ZWT2(JD:JF)
+
+ ENDIF !.......
+
+ ENDIF
+
+! 270896 !!!!!!!!!!!!!!!
+! PROVISOIRE *****************
+! IF(JI == 1)THEN
+! CALL GQTXCI(IER,ICOL)
+! ELSE
+! CALL GSPLCI(ICOL+JI*5)
+! CALL GSTXCI(ICOL+JI*5)
+! ENDIF
+! *****************************
+
+ CALL GSLN(1)
+ IF( JF >= JD)THEN
+ CALL AGSETR('DAS/SE.',1.)
+ WHERE(ZWT1(JD:JF) /= XSPVAL)
+ WHERE(ZWT1(JD:JF) == ZWB)
+ ZWT1(JD:JF)=ZWT1(JD:JF)+(ZWT-ZWB)/100.
+ ENDWHERE
+ WHERE(ZWT1(JD:JF) == ZWT)
+ ZWT1(JD:JF)=ZWT1(JD:JF)-(ZWT-ZWB)/100.
+ ENDWHERE
+ ENDWHERE
+ CALL EZXY(ZWT2(JD:JF),ZWT1(JD:JF),JF-JD+1,0)
+ CALL SFLUSH
+ CALL AGSETR('DAS/PA/1.',65535.)
+ ELSE
+ if(nverbia >0)then
+ print *,' ** varfct 2 JD,JF JD > JF .Suppression appel EZXY',&
+ JD,JF
+ endif
+ ENDIF
+
+ ENDDO
+ CALL GSPLCI(1)
+ CALL GQTXCI(IER,ICOL)
+!**************************************************************************
+!**************************************************************************
+ CALL GSLWSC(1.)
+ CALL GSLN(1)
+!**************************************************************************
+!**************************************************************************
+
+ IF(LPVKT1)THEN
+!***************** A FAIRE *****************************************
+! Distinguer le cas JA=1 et INUM=1 des cas JA>1 et JJ=1
+ IF(JA == 1 .AND. INUM == 1)THEN
+ CALL GACOLR(1,1,1,1)
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(5,2,4,0,0,0,5,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(5,2,4,0,0,1,5,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+!!!!!!!Avril 2002
+ IF(LHEURX)THEN
+ IF(LMYHEURX)THEN
+ CALL MYHEURX(5,2,4,0,1,0,5,0.,0.)
+ ELSE
+ CALL MYHEURX(5,2,4,0,1,0,5,0.,0.)
+ ENDIF
+ ELSE
+ CALL GRIDAL(5,2,4,0,1,0,5,0.,0.)
+ ENDIF
+ ELSE
+!!!!!!!Avril 2002
+ IF(LHEURX)THEN
+ IF(LMYHEURX)THEN
+ CALL MYHEURX(5,2,4,0,1,1,5,0.,0.)
+ ELSE
+ CALL MYHEURX(5,2,4,0,1,1,5,0.,0.)
+ ENDIF
+ ELSE
+ CALL GRIDAL(5,2,4,0,1,1,5,0.,0.)
+ ENDIF
+ ENDIF
+!Avril 2002
+ ELSE IF(JA > 1 .AND. JJ == IND .AND. .NOT.LZT)THEN
+! ELSE IF(JA > 1 .AND. JJ == 1)THEN
+ WRITE(YCAR8,FORMAY)ZWT
+ CALL PLCHHQ(ZWL+(ZWR-ZWL)/100.+(JA-1)*(ZWR-ZWL)/5., &
+ ZWT-(ZWT-ZWB)/50.,YCAR8,.009,0.,-1.)
+ WRITE(YCAR8,FORMAY)ZWB
+ CALL PLCHHQ(ZWL+(ZWR-ZWL)/100.+(JA-1)*(ZWR-ZWL)/5., &
+ ZWB+(ZWT-ZWB)/50.,YCAR8,.009,0.,-1.)
+ ENDIF
+
+ ELSE
+ CALL GACOLR(1,ICOL,1,1)
+! CALL GRIDAL(5,2,4,2,-1,1,9,0.,0.)
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,0,9,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,1,9,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+!!!!!!!Avril 2002
+ IF(LHEURX)THEN
+ IF(LMYHEURX)THEN
+ CALL MYHEURX(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,0,9,0.,0.)
+ ELSE
+ CALL MYHEURX(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,0,9,0.,0.)
+ ENDIF
+ ELSE
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,0,9,0.,0.)
+ ENDIF
+ ELSE
+!!!!!!!Avril 2002
+ IF(LHEURX)THEN
+ IF(LMYHEURX)THEN
+ CALL MYHEURX(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,1,9,0.,0.)
+ ELSE
+ CALL MYHEURX(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,1,9,0.,0.)
+ ENDIF
+ ELSE
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,1,9,0.,0.)
+ ENDIF
+ ENDIF
+!Avril 2002
+ ENDIF
+
+ CALL GACOLR(1,1,1,1)
+ CALL GSTXCI(1)
+!
+! Trace des courbes en noir et blanc
+!
+ ELSE
+
+ CALL GSPLCI(1)
+ CALL GSTXCI(1)
+ CALL GSLWSC(1.)
+
+ IF(LPVKT1)THEN !++++++++++++++++++++++++++++++++++++++++++++++++++
+!***************** A FAIRE ET VERIFIER *****************************************
+ IF(MOD(JA,4) == 1)CALL GSLN(1)
+ IF(MOD(JA,4) == 2)CALL GSLN(3)
+ IF(MOD(JA,4) == 3)CALL GSLN(2)
+ IF(MOD(JA,4) == 0)CALL GSLN(4)
+ IF(JA > 4)THEN
+ CALL GSLWSC(2.)
+ ELSE
+ CALL GSLWSC(1.)
+ ENDIF
+
+ ELSE !++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+ IF(MOD(JJ,2) == 1)THEN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ IF(LFTSTYLUSER )THEN
+! IF(ISLNFT1 == 0)THEN
+ print *,' Rentrez le type de trait voulu :'
+ print *,' Trait plein : 1, Tiretes : 2, Pointilles : 3, Tiretes longs-courts : 4'
+ read(5,*,END=50)ISLNFT1
+ GO TO 60
+ 50 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)ISLNFT1
+ 60 CONTINUE
+ !WRITE(YCAR80,*)ISLNFT1
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ISLNFT1)
+
+ print *,' Epaisseur des traits ? (valeur de base 1) '
+ read(5,*,END=52)EPAIS
+ GO TO 62
+ 52 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)EPAIS
+ 62 CONTINUE
+ !WRITE(YCAR80,*)EPAIS
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,EPAIS)
+ CALL GSLWSC(EPAIS)
+! ENDIF
+ CALL GSLN(ISLNFT1)
+ CALL GSLN(1)
+ IF(ISLNFT1 == 1)CALL AGSETR('DAS/PA/1.',65535.)
+ IF(ISLNFT1 == 2)CALL AGSETR('DAS/PA/1.',30583.)
+ IF(ISLNFT1 == 3)CALL AGSETR('DAS/PA/1.',21845.)
+ IF(ISLNFT1 == 4)CALL AGSETR('DAS/PA/1.',10023.)
+ ELSE
+ CALL GSLN(1)
+ ENDIF
+ ELSE IF(MOD(JJ,2) == 0)THEN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Modif pour JMartial
+ IF(LFTSTYLUSER )THEN
+! print *,' ISLNFT2 ',ISLNFT2
+! IF(ISLNFT2 == 0)THEN
+ print *,' Rentrez le type de trait voulu :'
+ print *,' Trait plein : 1, Tiretes : 2, Pointilles : 3, Tiretes longs-courts : 4'
+ read(5,*,END=51)ISLNFT2
+ GO TO 61
+ 51 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)ISLNFT2
+ 61 CONTINUE
+ !WRITE(YCAR80,*)ISLNFT2
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,ISLNFT2)
+#ifdef RHODES
+ CALL FLUSH(NDIR,ISTAF)
+#else
+ CALL FLUSH(NDIR)
+#endif
+! print *,' Conservation de ces caracteristiques pour les autres diagrammes (y/n)?'
+! YREPO=' '
+! read(5,*)YREPO
+! IF(YREPO == 'Y' .OR. YREPO == 'y' .OR. YREPO == 'yes'.OR.&
+! YREPO == 'YES' .OR. YREPO == 'o' .OR. YREPO == 'oui'.OR. &
+! YREPO == 'O' .OR. YREPO == 'OUI')then
+! else
+! print *,' Vous serez sollicite pour chaque courbe !'
+! print *,' Et on ne grogne pas !!!'
+! ISLNFT1=0
+! ENDIF
+! ENDIF
+ CALL GSLN(ISLNFT2)
+ CALL GSLN(1)
+ IF(ISLNFT2 == 1)CALL AGSETR('DAS/PA/1.',65535.)
+ IF(ISLNFT2 == 2)CALL AGSETR('DAS/PA/1.',30583.)
+ IF(ISLNFT2 == 3)CALL AGSETR('DAS/PA/1.',21845.)
+ IF(ISLNFT2 == 4)CALL AGSETR('DAS/PA/1.',10023.)
+ print *,' Epaisseur des traits ? (valeur de base 1) '
+ read(5,*,END=53)EPAIS
+ GO TO 63
+ 53 CONTINUE
+ CLOSE(5)
+ CALL GETENV("VARTTY",YCAR20)
+ YCAR20=ADJUSTL(YCAR20)
+ OPEN(5,FILE=YCAR20)
+ read(5,*)EPAIS
+ 63 CONTINUE
+ !WRITE(YCAR80,*)EPAIS
+ !YCAR80=ADJUSTL(YCAR80)
+ !WRITE(NDIR,'(A80)')YCAR80
+ CALL WRITEDIR(NDIR,EPAIS)
+ CALL GSLWSC(EPAIS)
+! IF(YREPO == 'n' .AND. ISLNFT1==0)ISLNFT2=0
+ ELSE
+ CALL GSLN(2)
+ ENDIF
+ ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! IF(MOD(JJ,2) == 0)CALL GSLN(3)
+ ENDIF !++++++++++++++++++++++++++++++++++++++++++++++++++
+
+! DO JI=1,NBRECOUV
+! JD=NRECOUV(JI*2-1)
+! JF=NRECOUV(JI*2)
+ DO JI=1,IBRECOUV(INUM)
+ JD=IRECOUV(JI*2-1,INUM)
+ JF=IRECOUV(JI*2,INUM)
+! print *,' JD JF AVANT ',JD,JF
+! 270896 !!!!!!!!!!!!!!!
+
+ SELECT CASE(CTYPE)
+ CASE('DRST','RSPL','RAPL')
+ J2=IST(INUM)
+! J2=NLOOPN
+ CASE DEFAULT
+ J2=1
+ END SELECT
+
+ IF(LFT .OR. (LPVKT .AND. L1K))THEN
+ IF(.NOT. LTINCRDIA(INUM,J2))THEN
+ DO JE=1,NBTIMEDIA(INUM,J2)
+ IF(NTIMEDIA(JE,INUM,J2) >= JD)THEN
+ JD=JE
+ EXIT
+ ENDIF
+ ENDDO
+ DO JE=1,NBTIMEDIA(INUM,J2)
+ IF(NTIMEDIA(JE,INUM,J2) == JF)THEN
+ JF=JE
+ EXIT
+ ELSE IF(NTIMEDIA(JE,INUM,J2) > JF)THEN
+ JF=JE-1
+ EXIT
+ ENDIF
+ ENDDO
+ JF=MIN(JF,NBTIMEDIA(INUM,J2))
+ ELSE
+
+ JJE=0
+ DO JE=NTIMEDIA(1,INUM,J2),NTIMEDIA(2,INUM,J2),NTIMEDIA(3,INUM,J2)
+ JJE=JJE+1
+ IF(JE >= JD)THEN
+ JD=JJE
+ EXIT
+ ENDIF
+ ENDDO
+ JJE=0
+ DO JE=NTIMEDIA(1,INUM,J2),NTIMEDIA(2,INUM,J2),NTIMEDIA(3,INUM,J2)
+ JJE=JJE+1
+ IF(JE == JF)THEN
+ JF=JJE
+ EXIT
+ ELSE IF(JE > JF)THEN
+ JF=MIN(JF,JJE-1)
+ EXIT
+ ENDIF
+ ENDDO
+ JJE=0
+ DO JE=NTIMEDIA(1,INUM,J2),NTIMEDIA(2,INUM,J2),NTIMEDIA(3,INUM,J2)
+ JJE=JJE+1
+ ENDDO
+! JF=MIN(JF,NTIMEDIA(2,INUM,J2))
+ JF=MIN(JF,JJE)
+
+ ENDIF
+ ELSE IF((LPVKT .AND. .NOT.L1K) .OR. LPVKT1)THEN
+ IF(.NOT. LTINCRDIA(JA,J2))THEN
+ DO JE=1,NBTIMEDIA(JA,J2)
+ IF(NTIMEDIA(JE,JA,J2) >= JD)THEN
+ JD=JE
+ EXIT
+ ENDIF
+ ENDDO
+ DO JE=1,NBTIMEDIA(JA,J2)
+ IF(NTIMEDIA(JE,JA,J2) == JF)THEN
+ JF=JE
+ EXIT
+ ELSE IF(NTIMEDIA(JE,JA,J2) > JF)THEN
+ JF=JE-1
+ EXIT
+ ENDIF
+ ENDDO
+ JF=MIN(JF,NBTIMEDIA(JA,J2))
+! print *,' JD JF APRES ',JD,JF
+! print *,' ZWT2 ',ZWT2(JD:JF)
+ ELSE
+
+ JJE=0
+ DO JE=NTIMEDIA(1,JA,J2),NTIMEDIA(2,JA,J2),NTIMEDIA(3,JA,J2)
+ JJE=JJE+1
+ IF(JE >= JD)THEN
+ JD=JJE
+ EXIT
+ ENDIF
+ ENDDO
+ JJE=0
+ DO JE=NTIMEDIA(1,JA,J2),NTIMEDIA(2,JA,J2),NTIMEDIA(3,JA,J2)
+ JJE=JJE+1
+ IF(JE == JF)THEN
+ JF=JJE
+ EXIT
+ ELSE IF(JE > JF)THEN
+ JF=MIN(JF,JJE-1)
+ EXIT
+ ENDIF
+ ENDDO
+ JJE=0
+ DO JE=NTIMEDIA(1,JA,J2),NTIMEDIA(2,JA,J2),NTIMEDIA(3,JA,J2)
+ JJE=JJE+1
+ ENDDO
+ JF=MIN(JF,JJE)
+! JF=MIN(JF,NTIMEDIA(2,JA,J2))
+! print *,' JD JF APRES ',JD,JF
+! print *,' ZWT2 ',ZWT2(JD:JF)
+
+ ENDIF
+ ENDIF
+! 270896 !!!!!!!!!!!!!!!
+ IF(JF >= JD)THEN
+ CALL AGSETR('DAS/SE.',1.)
+ WHERE(ZWT1(JD:JF) /= XSPVAL)
+ WHERE(ZWT1(JD:JF) == ZWB)
+ ZWT1(JD:JF)=ZWT1(JD:JF)+(ZWT-ZWB)/100.
+ ENDWHERE
+ WHERE(ZWT1(JD:JF) == ZWT)
+ ZWT1(JD:JF)=ZWT1(JD:JF)-(ZWT-ZWB)/100.
+ ENDWHERE
+ ENDWHERE
+ CALL EZXY(ZWT2(JD:JF),ZWT1(JD:JF),JF-JD+1,0)
+ CALL SFLUSH
+ CALL AGSETR('DAS/PA/1.',65535.)
+ ELSE
+ if(nverbia >0)then
+ print *,' ** varfct 3 JD,JF JD > JF .Suppression appel EZXY',&
+ JD,JF
+ endif
+ ENDIF
+! CALL EZXY(PWORKT(JD:JF),ZWORK1D(JD:JF,INUM),JF-JD+1,0)
+ ENDDO
+ CALL GSLN(1)
+ CALL GSLWSC(1.)
+
+ IF(LPVKT1)THEN
+!***************** A FAIRE *****************************************
+! Distinguer le cas JA=1 et INUM=1 des cas JA>1 et JJ=1
+ IF(JA == 1 .AND. INUM == 1)THEN
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(5,2,4,0,0,0,5,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(5,2,4,0,0,1,5,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+!!!!!!!Avril 2002
+ IF(LHEURX)THEN
+ IF(LMYHEURX)THEN
+ CALL MYHEURX(5,2,4,0,1,0,5,0.,0.)
+ ELSE
+ CALL MYHEURX(5,2,4,0,1,0,5,0.,0.)
+ ENDIF
+ ELSE
+ CALL GRIDAL(5,2,4,0,1,0,5,0.,0.)
+ ENDIF
+ ELSE
+!!!!!!!Avril 2002
+ IF(LHEURX)THEN
+ IF(LMYHEURX)THEN
+ CALL MYHEURX(5,2,4,0,1,1,5,0.,0.)
+ ELSE
+ CALL MYHEURX(5,2,4,0,1,1,5,0.,0.)
+ ENDIF
+ ELSE
+ CALL GRIDAL(5,2,4,0,1,1,5,0.,0.)
+ ENDIF
+ ENDIF
+!Avril 2002
+ ELSE IF(JA > 1 .AND. JJ == IND .AND. .NOT.LZT)THEN
+! ELSE IF(JA > 1 .AND. JJ == 1)THEN
+ WRITE(YCAR8,FORMAY)ZWT
+ CALL PLCHHQ(ZWL+(ZWR-ZWL)/100.+(JA-1)*(ZWR-ZWL)/5., &
+ ZWT-(ZWT-ZWB)/50.,YCAR8,.009,0.,-1.)
+ WRITE(YCAR8,FORMAY)ZWB
+ CALL PLCHHQ(ZWL+(ZWR-ZWL)/100.+(JA-1)*(ZWR-ZWL)/5., &
+ ZWB+(ZWT-ZWB)/50.,YCAR8,.009,0.,-1.)
+ ENDIF
+
+ ELSE
+! CALL GRIDAL(5,2,4,2,-1,1,9,0.,0.)
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,0,9,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,1,9,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+!!!!!!!Avril 2002
+ IF(LHEURX)THEN
+ IF(LMYHEURX)THEN
+ CALL MYHEURX(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,0,9,0.,0.)
+ ELSE
+ CALL MYHEURX(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,0,9,0.,0.)
+ ENDIF
+ ELSE
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,0,9,0.,0.)
+ ENDIF
+ ELSE
+!!!!!!!Avril 2002
+ IF(LHEURX)THEN
+ IF(LMYHEURX)THEN
+ CALL MYHEURX(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,1,9,0.,0.)
+ ELSE
+ CALL MYHEURX(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,1,9,0.,0.)
+ ENDIF
+ ELSE
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,-1,1,9,0.,0.)
+ ENDIF
+ ENDIF
+!Avril 2002
+ ENDIF
+
+ ENDIF
+ DEALLOCATE(ZWT1,ZWT2)
+
+ ENDDO
+!
+!************** Fin Boucle DO JJ=1,INB **************************************
+!
+ IF(.NOT. LPVKT1)THEN
+
+ ZVB=ZDEBYB
+ ZVT=ZDEBYT
+! print *,' ****VARFCT ',ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT
+! CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZVB,ZVT,1)
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,IDA)
+! CALL GRIDAL(5,2,4,2,1,-1,6,0.,0.)
+!Avril 2002
+ IF(LNOLABELX .AND. LNOLABELY)THEN
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,0,-1,6,0.,0.)
+ ELSEIF(LNOLABELX .AND. .NOT.LNOLABELY)THEN
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,0,-1,6,0.,0.)
+ ELSEIF(.NOT.LNOLABELX .AND. LNOLABELY)THEN
+!!!!!!!Avril 2002
+ IF(LHEURX)THEN
+ IF(LMYHEURX)THEN
+ CALL MYHEURX(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,1,-1,6,0.,0.)
+ ELSE
+ CALL MYHEURX(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,1,-1,6,0.,0.)
+ ENDIF
+ ELSE
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDA)
+ IF(LFACTAXEX)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,ZWBB,ZWTT,1)
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,1,-1,6,0.,0.)
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+ ELSE
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,1,-1,6,0.,0.)
+ ENDIF
+ ENDIF
+ ELSE
+!!!!!!!Avril 2002
+ IF(LHEURX)THEN
+ IF(LMYHEURX)THEN
+ CALL MYHEURX(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,1,-1,6,0.,0.)
+ ELSE
+ CALL MYHEURX(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,1,-1,6,0.,0.)
+ ENDIF
+ ELSE
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWLL,ZWRR,ZWBB,ZWTT,IDA)
+ IF(LFACTAXEX)THEN
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWLL*XFACTAXEX,ZWRR*XFACTAXEX,ZWBB,ZWTT,1)
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,1,-1,6,0.,0.)
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+ ELSE
+ CALL GRIDAL(NFTITVXMJ,NFTITVXMN,NFTITVYMJ,NFTITVYMN,1,-1,6,0.,0.)
+ ENDIF
+ ENDIF
+ ENDIF
+!Avril 2002
+
+ ENDIF
+
+ CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,IDA)
+ XCURVPTL=ZVL;XCURVPTR=ZVR;XCURVPTB=ZVB;XCURVPTT=ZVT
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ IF(LFACTIMP)THEN
+ CALL FACTIMP
+ ENDIF
+! tttttttttttttttttttttttttttttttttttttttttttttttttttX
+! Titres en X
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXL',YTEM)
+ CALL PLCHHQ(ZVL,ZVB-MIN(ZVB/3.,.05),YTEM,.008,0.,-1.)
+! CALL PLCHHQ(ZVL,ZVB/3.,YTEM,.008,0.,-1.)
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXM',YTEM)
+ CALL PLCHHQ((ZVL+ZVR)/2.,ZVB-MIN(ZVB/2.,.05),YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.,ZVB/2.,YTEM(1:LEN_TRIM(YTEM)),.008,0.,0.)
+! CALL PLCHHQ((ZVL+ZVR)/2.-ZVB/3.,ZVB/2.,YTEM,.008,0.,-1.)
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ IF(LHEURX)THEN
+ YTEM='(H.)'
+ ELSE
+ YTEM='(Sec.)'
+ ENDIF
+ YTEM=ADJUSTL(YTEM)
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ IF(YTEM /= ' ' .AND. YTEM /= 'DEFAULT')THEN
+ CALL RESOLV_TIT('CTITXR',YTEM)
+ if(nverbia > 0)then
+ print *,' **Passage LFT LPVKT 2',(ZVR-ZVB/2.)
+ endif
+ CALL PLCHHQ(ZVR+.03,ZVB-MIN(ZVB/3.,.05),YTEM(1:LEN_TRIM(YTEM)),.008,0.,-1.)
+! CALL PLCHHQ(ZVR-ZVB/2.,ZVB-MIN(ZVB/3.,.05),YTEM,.008,0.,-1.)
+ ENDIF
+! tttttttttttttttttttttttttttttttttttttttttttttttttttY
+! Titres en Y
+ YTEM(1:LEN(YTEM))=' '
+ IF(LZT)THEN
+ LTITDEF=.FALSE.
+ CTITYT='Altitudes;(M)'
+ ENDIF
+ CALL RESOLV_TITY('CTITYT',ZVL,ZVR,ZVB,ZVT,YTEM)
+ IF(LZT)THEN
+ LTITDEF=.TRUE.
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYM',ZVL,ZVR,ZVB,ZVT,YTEM)
+ IF(LCNSUM)THEN
+ YTEM='SUM(.TRUE.=1)'
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TITY('CTITYB',ZVL,ZVR,ZVB,ZVT,YTEM)
+! tttttttttttttttttttttttttttttttttttttttttttttttttttT
+! Titres TOP
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITT3',YTEM)
+ ZXPOSTITT3=.002
+ ZXYPOSTITT3=.93
+ IF(XPOSTITT3 /= 0.)THEN
+ ZXPOSTITT3=XPOSTITT3
+ ENDIF
+ IF(XYPOSTITT3 /= 0.)THEN
+ ZXYPOSTITT3=XYPOSTITT3
+ ENDIF
+ IF(CTITT3 /= ' ')THEN
+ IF(XSZTITT3 /= 0.)THEN
+ CALL PLCHHQ(0.002,0.93,YTEM,XSZTITT3,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.002,0.93,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ YTEM=YCAR
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.95
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+ IF(CTITT2 /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(0.002,0.95,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+! IF(.NOT.LPVKT)THEN
+! YTEM(1:LEN(YTEM))=' '
+! CALL RESOLV_TIT('CTITT1',YTEM)
+! IF(CTITT1 /= ' ')THEN
+! CALL PLCHHQ(0.002,0.98,YTEM,.012,0.,-1.)
+! ENDIF
+! ENDIF
+! tttttttttttttttttttttttttttttttttttttttttttttttttttB
+! Titres BOTTOM
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITB3',YTEM)
+ ZXPOSTITB3=.002
+ ZXYPOSTITB3=.05
+ IF(XPOSTITB3 /= 0.)THEN
+ ZXPOSTITB3=XPOSTITB3
+ ENDIF
+ IF(XYPOSTITB3 /= 0.)THEN
+ ZXYPOSTITB3=XYPOSTITB3
+ ENDIF
+! IF(YTEM /= ' ')THEN
+! print *,' +++varfct CTITB3 ',CTITB3,CTITB3MEM
+! print *,' +++varfct YDIFF ',YDIFF
+ IF(YDIFF /= ' ' .AND. (YTEM == ' ' .OR. YTEM == 'DEFAULT'))THEN
+ CALL PLCHHQ(0.002,0.05,YDIFF,.008,0.,-1.)
+ YDIFF(1:LEN(YDIFF))=' '
+ ENDIF
+ IF(CTITB3 /= ' ')THEN
+ CALL PLCHHQ(0.002,0.05,YTEM,.008,0.,-1.)
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITB2',YTEM)
+ IF(CTITB2 /= ' ')THEN
+ CALL PLCHHQ(0.002,0.025,YTEM,.007,0.,-1.)
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ CALL RESOLV_TIT('CTITB1',YTEM)
+ IF(CTITB1 /= ' ')THEN
+ CALL PLCHHQ(0.002,0.005,YTEM,.007,0.,-1.)
+ ENDIF
+ IF(LDATFILE)CALL DATFILE_FORDIACHRO
+
+ IF(.NOT. LPVKT1)THEN
+! Ajout Nov 2000
+ IF(LPVKT .OR. (LFT .AND. LCHXY))THEN
+ IF(L1DT)THEN
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ WRITE(YCARCOU,1002)
+ CASE('SSOL')
+ IF(JA == 1)THEN
+ YCARCOU(1:LEN(YCARCOU))=' '
+ YCAR(1:LEN(YCAR))=' '
+ YCARCOU(1:7)='SSOL N.'
+ WRITE(YCARCOU(8:10),'(I3)')IST(1)
+ YCARCOU(11:13)=' ('
+ WRITE(YCARCOU(14:18),'(F5.0)')XTRAJX(1,1,IST(1))
+ YCARCOU(19:19)=','
+ WRITE(YCARCOU(20:24),'(F5.0)')XTRAJY(1,1,IST(1))
+ YCARCOU(25:27)=') '
+ ISUIT=28
+ ISUI=8
+ ALLOCATE(ISTM(SIZE(IST,1)))
+ INDISTM=1
+ ISTM(INDISTM)=IST(1)
+ DO JB=2,ICOMPT
+ ISTOK=0
+ DO JC=1,INDISTM
+ IF(IST(JB) == ISTM(JC))THEN
+ ISTOK=1
+ ENDIF
+ ENDDO
+ IF(ISTOK == 1)THEN
+ CYCLE
+ ELSE
+ INDISTM=INDISTM+1
+ ISTM(INDISTM)=IST(JB)
+ IF(ISUIT > 50)THEN
+ WRITE(YCAR(ISUI:ISUI+3),'(I4)')IST(JB)
+ YCAR(ISUI+4:ISUI+6)=' ('
+ WRITE(YCAR(ISUI+7:ISUI+11),'(F5.0)')XTRAJX(1,1,IST(JB))
+ ISUI=ISUI+12
+ YCAR(ISUI:ISUI)=','
+ ISUI=ISUI+1
+ WRITE(YCAR(ISUI:ISUI+4),'(F5.0)')XTRAJY(1,1,IST(JB))
+ ISUI=ISUI+5
+ YCAR(ISUI:ISUI+2)=') '
+ ISUI=ISUI+3
+ ELSE
+ WRITE(YCARCOU(ISUIT:ISUIT+3),'(I4)')IST(JB)
+ YCARCOU(ISUIT+4:ISUIT+6)=' ('
+ WRITE(YCARCOU(ISUIT+7:ISUIT+11),'(F5.0)')XTRAJX(1,1,IST(JB))
+ ISUIT=ISUIT+12
+ YCARCOU(ISUIT:ISUIT)=','
+ ISUIT=ISUIT+1
+ WRITE(YCARCOU(ISUIT:ISUIT+4),'(F5.0)')XTRAJY(1,1,IST(JB))
+ ISUIT=ISUIT+5
+ YCARCOU(ISUIT:ISUIT+2)=') '
+ ISUIT=ISUIT+3
+ ENDIF
+ ENDIF
+ ENDDO
+ DEALLOCATE(ISTM)
+ ENDIF
+ CASE DEFAULT
+ IF(JA == 1)THEN
+ YCARCOU(1:LEN(YCARCOU))=' '
+ YCARCOU(1:4)=CTYPE
+ YCARCOU(5:7)=' N.'
+ WRITE(YCARCOU(8:10),'(I3)')IST(1)
+ ISUIT=11
+ ALLOCATE(ISTM(SIZE(IST,1)))
+ INDISTM=1
+ ISTM(INDISTM)=IST(1)
+ DO JB=2,ICOMPT
+ ISTOK=0
+ DO JC=1,INDISTM
+ IF(IST(JB) == ISTM(JC))THEN
+ ISTOK=1
+ ENDIF
+ ENDDO
+ IF(ISTOK == 1)THEN
+ CYCLE
+ ELSE
+ INDISTM=INDISTM+1
+ ISTM(INDISTM)=IST(JB)
+ WRITE(YCARCOU(ISUIT:ISUIT+4),'(I5)')IST(JB)
+ ISUIT=ISUIT+5
+ ENDIF
+ ENDDO
+ DEALLOCATE(ISTM)
+ ENDIF
+ END SELECT
+ ELSE
+ IF(XIDEBCOU.NE.-999.)THEN
+ IF(LDEFCV2CC)THEN !%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(LDEFCV2IND)THEN
+ IF(NPROFILE == 1)THEN
+ WRITE(YCARCOU,1018)NIDEBCV,NJDEBCV
+ ELSEIF(NPROFILE == NLMAX)THEN
+ WRITE(YCARCOU,1018)NIFINCV,NJFINCV
+ ELSE
+ ENDIF
+ ELSE IF(LDEFCV2LL)THEN
+ IF(NPROFILE == 1)THEN
+ WRITE(YCARCOU,1019)XIDEBCVLL,XJDEBCVLL
+ ELSEIF(NPROFILE == NLMAX)THEN
+ WRITE(YCARCOU,1019)XIFINCVLL,XJFINCVLL
+ ELSE
+ ENDIF
+ ELSE
+ IF(NPROFILE == 1)THEN
+ WRITE(YCARCOU,1020)XIDEBCV,XJDEBCV
+ ELSEIF(NPROFILE == NLMAX)THEN
+ WRITE(YCARCOU,1020)XIFINCV,XJFINCV
+ ELSE
+ ENDIF
+ ENDIF
+ ELSE !%%%%%%%%%%%%%%%%%%%%%%%%
+ IF(XIDEBCOU < 99999.)THEN
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1001)XIDEBCOU,XJDEBCOU,NLANGLE,NPROFILE
+ ELSE
+ WRITE(YCARCOU,1003)XIDEBCOU,XJDEBCOU,NLANGLE,NPROFILE
+ END IF
+ ELSE
+ IF(XJDEBCOU < 99999.)THEN
+ WRITE(YCARCOU,1004)XIDEBCOU,XJDEBCOU,NLANGLE,NPROFILE
+ ELSE
+ WRITE(YCARCOU,1005)XIDEBCOU,XJDEBCOU,NLANGLE,NPROFILE
+ END IF
+ END IF
+ ENDIF !%%%%%%%%%%%%%%%%%%%%%%%%
+ ELSE
+ WRITE(YCARCOU,1000)NIDEBCOU,NJDEBCOU,NLANGLE,NPROFILE
+ END IF
+ END IF
+! CALL PCSETI('BF',1) ! Fills a box around characters
+! CALL PCSETR('BL',2.) ! heavy line plotted
+! CALL PCSETR('BM',.3) ! sets a box margin
+! CALL PCSETI('BC(1)',1) ! sets box color for prints
+! CALL GETSET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ IF(LFACTIMP)THEN
+ CALL FACTIMP
+ ENDIF
+! tttttttttttttttttttttttttttttttttttttttttttttttttttT
+ CALL RESOLV_TIT('CTITT1',YCARCOU)
+ ZXPOSTITT1=.002
+ ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+ IF(CTITT1 /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(.002,.98,YCARCOU,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(.002,.98,YCARCOU,.010,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ YTEM=YCAR
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.95
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+ IF(CTITT2 /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(0.002,0.95,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+ CALL GSFAIS(0)
+! CALL PCSETI('BF',0) ! Fills a box around characters
+ ENDIF
+ IF(J <IPAGE)CALL FRAME
+
+ ELSE
+
+ SELECT CASE(CTYPE)
+ CASE('CART')
+ CASE('SSOL')
+ IF(JA == 1)THEN
+ YCARCOU(1:LEN(YCARCOU))=' '
+ YCAR(1:LEN(YCAR))=' '
+ YCARCOU(1:7)='SSOL N.'
+ WRITE(YCARCOU(8:10),'(I3)')IST(1)
+ YCARCOU(11:13)=' ('
+ WRITE(YCARCOU(14:18),'(F5.0)')XTRAJX(1,1,IST(1))
+ YCARCOU(19:19)=','
+ WRITE(YCARCOU(20:24),'(F5.0)')XTRAJY(1,1,IST(1))
+ YCARCOU(25:27)=') '
+ ISUIT=28
+ ISUI=8
+ ALLOCATE(ISTM(SIZE(IST,1)))
+ INDISTM=1
+ ISTM(INDISTM)=IST(1)
+ DO JB=2,ICOMPT
+ ISTOK=0
+ DO JC=1,INDISTM
+ IF(IST(JB) == ISTM(JC))THEN
+ ISTOK=1
+ ENDIF
+ ENDDO
+ IF(ISTOK == 1)THEN
+ CYCLE
+ ELSE
+ INDISTM=INDISTM+1
+ ISTM(INDISTM)=IST(JB)
+ IF(ISUIT > 50)THEN
+ WRITE(YCAR(ISUI:ISUI+3),'(I4)')IST(JB)
+ YCAR(ISUI+4:ISUI+6)=' ('
+ WRITE(YCAR(ISUI+7:ISUI+11),'(F5.0)')XTRAJX(1,1,IST(JB))
+ ISUI=ISUI+12
+ YCAR(ISUI:ISUI)=','
+ ISUI=ISUI+1
+ WRITE(YCAR(ISUI:ISUI+4),'(F5.0)')XTRAJY(1,1,IST(JB))
+ ISUI=ISUI+5
+ YCAR(ISUI:ISUI+2)=') '
+ ISUI=ISUI+3
+ ELSE
+ WRITE(YCARCOU(ISUIT:ISUIT+3),'(I4)')IST(JB)
+ YCARCOU(ISUIT+4:ISUIT+6)=' ('
+ WRITE(YCARCOU(ISUIT+7:ISUIT+11),'(F5.0)')XTRAJX(1,1,IST(JB))
+ ISUIT=ISUIT+12
+ YCARCOU(ISUIT:ISUIT)=','
+ ISUIT=ISUIT+1
+ WRITE(YCARCOU(ISUIT:ISUIT+4),'(F5.0)')XTRAJY(1,1,IST(JB))
+ ISUIT=ISUIT+5
+ YCARCOU(ISUIT:ISUIT+2)=') '
+ ISUIT=ISUIT+3
+ ENDIF
+ ENDIF
+ ENDDO
+ DEALLOCATE(ISTM)
+ ENDIF
+ CASE DEFAULT
+ IF(JA == 1)THEN
+ YCARCOU(1:LEN(YCARCOU))=' '
+ YCARCOU(1:4)=CTYPE
+ YCARCOU(5:7)=' N.'
+ WRITE(YCARCOU(8:10),'(I3)')IST(1)
+ ISUIT=11
+ ALLOCATE(ISTM(SIZE(IST,1)))
+ INDISTM=1
+ ISTM(INDISTM)=IST(1)
+ DO JB=2,ICOMPT
+ ISTOK=0
+ DO JC=1,INDISTM
+ IF(IST(JB) == ISTM(JC))THEN
+ ISTOK=1
+ ENDIF
+ ENDDO
+ IF(ISTOK == 1)THEN
+ CYCLE
+ ELSE
+ INDISTM=INDISTM+1
+ ISTM(INDISTM)=IST(JB)
+ WRITE(YCARCOU(ISUIT:ISUIT+4),'(I5)')IST(JB)
+ ISUIT=ISUIT+5
+ ENDIF
+ ENDDO
+ DEALLOCATE(ISTM)
+ ENDIF
+ END SELECT
+
+ CALL SET(0.,1.,0.,1.,0.,1.,0.,1.,1)
+ IF(LFACTIMP)THEN
+ CALL FACTIMP
+ ENDIF
+ CALL RESOLV_TIT('CTITT1',YCARCOU)
+ ZXPOSTITT1=.002
+ ZXYPOSTITT1=.98
+ IF(XPOSTITT1 /= 0.)THEN
+ ZXPOSTITT1=XPOSTITT1
+ ENDIF
+ IF(XYPOSTITT1 /= 0.)THEN
+ ZXYPOSTITT1=XYPOSTITT1
+ ENDIF
+ IF(CTITT1 /= ' ')THEN
+ IF(XSZTITT1 /= 0.)THEN
+ CALL PLCHHQ(.002,.98,YCARCOU,XSZTITT1,0.,-1.)
+ ELSE
+ CALL PLCHHQ(.002,.98,YCARCOU,.010,0.,-1.)
+ ENDIF
+ ENDIF
+ YTEM(1:LEN(YTEM))=' '
+ YTEM=YCAR
+ CALL RESOLV_TIT('CTITT2',YTEM)
+ ZXPOSTITT2=.002
+ ZXYPOSTITT2=.95
+ IF(XPOSTITT2 /= 0.)THEN
+ ZXPOSTITT2=XPOSTITT2
+ ENDIF
+ IF(XYPOSTITT2 /= 0.)THEN
+ ZXYPOSTITT2=XYPOSTITT2
+ ENDIF
+ IF(CTITT2 /= ' ')THEN
+ IF(XSZTITT2 /= 0.)THEN
+ CALL PLCHHQ(0.002,0.95,YTEM,XSZTITT2,0.,-1.)
+ ELSE
+ CALL PLCHHQ(0.002,0.95,YTEM,.008,0.,-1.)
+ ENDIF
+ ENDIF
+ CALL SET(ZVL,ZVR,ZVB,ZVT,ZWL,ZWR,ZWB,ZWT,1)
+!
+! Eventuels Titres cas LPVKT1
+!
+ ENDIF
+
+ ENDDO ! Fin boucle DO JA=1,JAF
+ ENDDO
+!
+!************ Fin Boucle DO J=1,IPAGE ***************************************
+!
+ if(nverbia > 0)then
+ print *,' **varfct AV DEALLOCATE lig 3444'
+ endif
+ DEALLOCATE(ZWORK1D)
+ DEALLOCATE(ZWORKT)
+ IF(ALLOCATED(ZPVMNMX))THEN
+ DEALLOCATE(ZPVMNMX)
+ ENDIF
+ IF(ALLOCATED(YK))THEN
+ DEALLOCATE(YK)
+ ENDIF
+ DEALLOCATE(YGROUP)
+ DEALLOCATE(ICOMPTSZ)
+ DEALLOCATE(IST)
+ DEALLOCATE(IBRECOUV)
+ DEALLOCATE(IRECOUV)
+ ICOMPT=0
+ if(nverbia > 0)then
+ print *,' **varfct AP DEALLOCATE lig 3461'
+ endif
+ ENDIF
+
+ENDIF
+
+!*****************************************************************************
+!****************** Fin LFT LPVKT LPVKT1 ***********************************
+!*****************************************************************************
+
+1000 FORMAT('Vertical section IDEB=',I4,' JDEB=',I4,' ANG.=',I3,' IPRO=',I4)
+1001 FORMAT('Vertical section XDEB=',F6.0,' YDEB=',F6.0,' ANG.=',I3,' IPRO=',I4)
+1002 FORMAT('Vertical profile (1D)')
+1003 FORMAT('Vertical section XDEB=',F6.0,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1004 FORMAT('Vertical section XDEB=',E7.2,' YDEB=',F6.0,' ANG.=',I3,' NBPTS=',I4)
+1005 FORMAT('Vertical section XDEB=',E6.2,' YDEB=',E7.2,' ANG.=',I3,' NBPTS=',I4)
+1018 FORMAT('IND I,J = (',I4,',',I4,')')
+1019 FORMAT('LAT,LON = (',F5.1,',',F5.1,')')
+1020 FORMAT('CONF. COORD. = (',F8.0,',',F8.0,')')
+
+RETURN
+END SUBROUTINE VARFCT
diff --git a/LIBTOOLS/tools/diachro/src/DIAPRO/veriflen_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/DIAPRO/veriflen_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f3da5b6463f35a3394e29e8214e3375b5079d134
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/DIAPRO/veriflen_fordiachro.f90
@@ -0,0 +1,864 @@
+! ######spl
+ SUBROUTINE VERIFLEN_FORDIACHRO
+! ##############################
+!
+!!**** *VERIFLEN_FORDIACHRO* - Computes the length of the abscissa axis for the vertical
+!! cross-sections and checks whether it gets out of the
+!! display boundaries
+!!
+!! PURPOSE
+!! -------
+! Computes the meshsizes along the abscissa axis of vertical
+! cross-sections and checks the requested number of points gets
+! out of the display boundaries. The calculation is made for all
+! the possible grids
+!
+!!** METHOD
+!! ------
+!! -NA-
+!!
+!! EXTERNAL
+!! --------
+!! LENMAILLD : locates the four corners of the x-y gridbox containing
+!! the starting point of a vertical cross section. This
+!! information is a prerequisite to calculate the meshsizes
+!! along a vertical cross-section abscissa axis.
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_COORD : declares gridpoint coordinates
+!! (TRACE use only)
+!! XXDXHAT, XXDYHAT : Mesh size arrays (meters), for all grid locations
+!! XXX, XXY : XHAT, YHAT values (meters) for all grid locations
+!! XXDS : Mesh size (meters) along the horizontal axis of an
+!! oblique vertical cross-section, for all grid locations
+!! XDS : Abscissa array along the horizontal axis of an oblique
+!! vertical cross-section (meters), for all grid locations
+!! XDSX, XDSY : Projections on the MESO-NH cartesian axes of the XDS
+!! oblique abscissa (meters), for all grid locations
+!!
+!! Module MODD_GRID1 : declares grid variables (Model module)
+!! XXHAT, XYHAT : x, y in the conformal or cartesian plane
+!!
+!! Module MODN_PARA : Defines NAM_DOMAIN_POS namelist (former PARA common)
+!! NIDEBCOU,NJDEBCOU : Origin of a vertical cross-section
+!! in grid index integer values
+!! (XIDEBCOU and XJDEBCOU must
+!! be = to -999.)
+!! XIDEBCOU,XJDEBCOU : Origin of a vertical cross-section
+!! in cartesian (or conformal) real values
+!! NLANGLE : Angle between X Meso-NH axis and
+!! cross-section direction in degrees
+!! (Integer value anticlockwise)
+!! NLMAX, : Number of points horizontally along
+!! the vertical section
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NIMAX,NKMAX : x, and z array dimensions
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 14/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_COORD
+USE MODD_CONF
+USE MODD_DIM1
+USE MODD_TYPE_AND_LH
+USE MODD_NMGRID
+USE MODD_GRID1
+USE MODD_GRID, ONLY: XLONORI,XLATORI
+USE MODN_PARA
+USE MODD_PARAMETERS
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_RESOLVCAR
+USE MODD_DEFCV
+USE MODD_NMGRID
+USE MODE_GRIDPROJ
+
+IMPLICIT NONE
+
+REAL :: ZRANGLE, ZCANGLE, ZZSANGLE, ZIX, ZIY, ZZSIC, ZZSIS
+REAL,SAVE :: ZCVX1, ZCVX2, ZCVY1, ZCVY2
+REAL,SAVE :: ZXREF1, ZXREF2, ZYREF1, ZYREF2
+REAL :: ZME, ZMEY, ZMEX
+REAL :: ZZLA, ZZLO
+
+INTEGER :: J2LOOP, JILOOP, IIA, IJA, ISIZ
+INTEGER :: IIB, IIE, IJB, IJE, IIU, IJU
+INTEGER :: IID, IJD, IIF, IJF
+INTEGER :: ICV, IINF, IJINF, ISUP, IJSUP
+INTEGER :: IMODIF
+
+LOGICAL :: GEND, GEND2
+LOGICAL :: GOKX, GOKY
+!
+!-------------------------------------------------------------------------------
+IIB=1+JPHEXT
+IIE=NIMAX+JPHEXT
+IIU=NIMAX+2*JPHEXT
+IJB=1+JPHEXT
+IJE=NJMAX+JPHEXT
+IJU=NJMAX+2*JPHEXT
+!
+!* 1. LOCATING THE STARTING GRIDBOX AND CHECKING FOR LOCATION
+!* OUT OF THE DISPLAY BOUNDARIES
+! -------------------------------------------------------
+!
+!* 1.0 array allocations
+!
+ISIZ=MAX(SIZE(XXHAT),SIZE(XYHAT))
+IF(ALLOCATED(XDS))THEN
+ DEALLOCATE(XDS)
+END IF
+ ALLOCATE(XDS(ISIZ+100,7))
+IF(ALLOCATED(XXDS))THEN
+ DEALLOCATE(XXDS)
+END IF
+ ALLOCATE(XXDS(ISIZ+100,7))
+IF(ALLOCATED(XDSX))THEN
+ DEALLOCATE(XDSX)
+END IF
+ ALLOCATE(XDSX(ISIZ+100,7))
+IF(ALLOCATED(XDSY))THEN
+ DEALLOCATE(XDSY)
+END IF
+ ALLOCATE(XDSY(ISIZ+100,7))
+! Avril 2002
+IF(LCV .AND. .NOT.LCARTESIAN)THEN
+IF(ALLOCATED(XLATCV))THEN
+ DEALLOCATE(XLATCV)
+ENDIF
+ALLOCATE(XLATCV(ISIZ+100))
+IF(ALLOCATED(XLONCV))THEN
+ DEALLOCATE(XLONCV)
+ENDIF
+ALLOCATE(XLONCV(ISIZ+100))
+ENDIF
+! Avril 2002
+!
+if(nverbia > 0)then
+ print *,' ** veriflen LDEFCV2 LDEFCV2LL LDEFCV2IND ',LDEFCV2,LDEFCV2ll,LDEFCV2IND
+endif
+
+IF(LDEFCV2)THEN
+ZCVX1=XIDEBCV; ZCVX2=XIFINCV; ZCVY1=XJDEBCV; ZCVY2=XJFINCV
+LDEFCV2CC=.TRUE.
+ELSE IF(LDEFCV2LL)THEN
+CALL SM_XYHAT_S(XLATORI,XLONORI,XIDEBCVLL,XJDEBCVLL,ZCVX1,ZCVY1)
+CALL SM_XYHAT_S(XLATORI,XLONORI,XIFINCVLL,XJFINCVLL,ZCVX2,ZCVY2)
+LDEFCV2CC=.TRUE.
+ELSE IF(LDEFCV2IND)THEN
+ZCVX1=XXX(NIDEBCV,NMGRID)
+ZCVY1=XXY(NJDEBCV,NMGRID)
+ZCVX2=XXX(NIFINCV,NMGRID)
+ZCVY2=XXY(NJFINCV,NMGRID)
+LDEFCV2CC=.TRUE.
+ELSE
+LDEFCV2CC=.FALSE.
+ENDIF
+IF(LDEFCV2CC)THEN
+ IINF=NIINF; ISUP=NISUP; IJINF=NJINF; IJSUP=NJSUP
+ IF(LCV)THEN
+ ICV=1
+ ELSE
+ ICV=0
+ LCV=.TRUE.
+ ENDIF
+ CALL RESOLV_NIJINF_NIJSUP
+ENDIF
+!
+!* 1.1 Checking successive gridbox locations along axis
+!
+IF(LDEFCV2CC)THEN
+ ZRANGLE=ATAN2((ZCVY2-ZCVY1),(ZCVX2-ZCVX1))
+! print *,' ** veriflen ZRANGLE,ZCANGLE,ZZSANGLE ',ZRANGLE
+ IF(ZCVY2 == ZCVY1 .AND. ABS(ZRANGLE) < 1.E-6)THEN
+ ZRANGLE=0.
+ ENDIF
+ XANGLECV=ZRANGLE
+ELSE
+ ZRANGLE=FLOAT(NLANGLE)*ACOS(-1.)/180.
+ENDIF
+ZCANGLE=COS(ZRANGLE)
+ZZSANGLE=SIN(ZRANGLE)
+if(nverbia > 0)then
+ print *,' ** veriflen ZRANGLE,ZCANGLE,ZZSANGLE ',ZRANGLE,ZCANGLE,ZZSANGLE
+endif
+IF(.NOT.LDEFCV2CC)THEN
+ IF(NLANGLE.EQ.0.OR.NLANGLE.EQ.180)ZZSANGLE=0.
+ IF(NLANGLE.EQ.90.OR.NLANGLE.EQ.270)ZCANGLE=0.
+ELSE
+ IF(XANGLECV == 0. .OR. XANGLECV/ACOS(-1.)*180. == 180.)ZZSANGLE=0.
+ IF(XANGLECV/ACOS(-1.)*180. == 90. .OR.XANGLECV/ACOS(-1.)*180. == 270.)ZCANGLE=0.
+ENDIF
+ZZSIC=SIGN(1.,ZCANGLE)
+ZZSIS=SIGN(1.,ZZSANGLE)
+IF(LDEFCV2CC)THEN
+ XIDEBCOU=ZCVX1; XJDEBCOU=ZCVY1
+ NLMAX=500
+ ZXREF1=MIN(ZCVX1,ZCVX2)
+ ZXREF2=MAX(ZCVX1,ZCVX2)
+ ZYREF1=MIN(ZCVY1,ZCVY2)
+ ZYREF2=MAX(ZCVY1,ZCVY2)
+ if(nverbia > 0)then
+ print *,' *** veriflen XIDEBCOU XJDEBCOU NLMAX AV calcul ZXREF1,ZXREF2,ZYREF1,ZYREF2'
+ print *,' *** veriflen',XIDEBCOU,XJDEBCOU,NLMAX,ZXREF1,ZXREF2,ZYREF1,ZYREF2
+ print *,' ** veriflen ZRANGLE,ZCANGLE,ZZSANGLE ',ZRANGLE,ZCANGLE,ZZSANGLE
+ endif
+ENDIF
+!
+! Verification origine OK
+!
+IF(XIDEBCOU.EQ.-999.)THEN
+ IF(NIDEBCOU >= NIL .AND. NIDEBCOU <= NIH)THEN
+ GOKX=.TRUE.
+ ELSE
+ print *,' NIDEBCOU EN DEHORS DES LIMITES en X ',NIDEBCOU,' (',NIL,' - ', &
+ NIH,')'
+ GOKX=.FALSE.
+ ENDIF
+ IF(NJDEBCOU >= NJL .AND. NJDEBCOU <= NJH)THEN
+ GOKY=.TRUE.
+ ELSE
+ print *,' NJDEBCOU EN DEHORS DES LIMITES en Y ',NJDEBCOU,' (',NJL,' - ', &
+ NJH,')'
+ GOKY=.FALSE.
+ ENDIF
+ELSE
+ IF(XIDEBCOU >= XXX(NIL,NMGRID) .AND. XIDEBCOU <= XXX(NIH,NMGRID))THEN
+ GOKX=.TRUE.
+ ELSE
+ print *,' XIDEBCOU EN DEHORS DES LIMITES en X ',XIDEBCOU,' (', &
+ XXX(NIL,NMGRID),' - ', &
+ XXX(NIH,NMGRID),')'
+ GOKX=.FALSE.
+ ENDIF
+ IF(XJDEBCOU >= XXY(NJL,NMGRID) .AND. XJDEBCOU <= XXY(NJH,NMGRID))THEN
+ GOKY=.TRUE.
+ ELSE
+ print *,' XJDEBCOU EN DEHORS DES LIMITES en Y ',XJDEBCOU,' (', &
+ XXY(NJL,NMGRID),' - ', &
+ XXY(NJH,NMGRID),')'
+ GOKY=.FALSE.
+ ENDIF
+ENDIF
+IF(.NOT.GOKX .OR. .NOT.GOKY)THEN
+ print *,' -> ABORT: REDEFINISSEZ L'' ORIGINE DE LA COUPE '
+ LPBREAD=.TRUE.
+ !RETURN
+ STOP
+ENDIF
+!
+! Scanning all the existing grids
+! J2LOOP --> NGRID
+!
+IMODIF=0
+DO J2LOOP=1,7 !do 1 (grid loop)
+GEND=.FALSE.
+GEND2=.FALSE.
+!print *,' GRILLE NLMAX ',J2LOOP,' ',NLMAX
+ IF(XIDEBCOU.EQ.-999.)THEN ! Section defined by indexes
+ ZIX=XXDXHAT(NIDEBCOU,J2LOOP)
+ IF(ZZSIC.LT.0.)ZIX=XXDXHAT(MAX(NIL,NIDEBCOU-1),J2LOOP)
+! IF(ZZSIC.LT.0.)ZIX=XXDXHAT(MAX(1,NIDEBCOU-1),J2LOOP)
+ ZIY=XXDYHAT(NJDEBCOU,J2LOOP)
+ IF(ZZSIS.LT.0.)ZIY=XXDYHAT(MAX(NJL,NJDEBCOU-1),J2LOOP)
+! IF(ZZSIS.LT.0.)ZIY=XXDYHAT(MAX(1,NJDEBCOU-1),J2LOOP)
+ XDSX(1,J2LOOP)=XXX(NIDEBCOU,J2LOOP)
+ XDSY(1,J2LOOP)=XXY(NJDEBCOU,J2LOOP)
+ ELSE ! Section defined by range
+ XDSX(1,J2LOOP)=XIDEBCOU
+ XDSY(1,J2LOOP)=XJDEBCOU
+ CALL LENMAILLD(XIDEBCOU,XJDEBCOU,IIA,IJA,1,J2LOOP)
+ ZIX=XXDXHAT(IIA,J2LOOP)
+ ZIY=XXDYHAT(IJA,J2LOOP)
+ if(nverbia > 0)then
+ print *,' veriflen XIDEBCOU,XJDEBCOU,ZIX,ZIY ',XIDEBCOU,XJDEBCOU,ZIX,ZIY
+ endif
+ END IF
+!
+! Scans oblique abscissa from origin to end.
+! XDS ---> X along oblique cross-section
+! XXDS ---> X-meshsize along X of oblique cross-section
+!
+ XDS(1,J2LOOP)=0.
+! print *,' TINY ',TINY(1.)
+ DO JILOOP=2,NLMAX ! do 2 (abscissa loop)
+ XXDS(JILOOP-1,J2LOOP)=ABS(ZIX*ZCANGLE)+ABS(ZIY*ZZSANGLE)
+ if(nverbia >8)then
+ print *,' **** veriflen boucle DO JILOOP=2,NLMAX, XXDS(JILOOP-1,J2LOOP)',XXDS(JILOOP-1,J2LOOP),JILOOP-1,XXDS(1,J2LOOP)
+ endif
+ XDS(JILOOP,J2LOOP)=XDS(JILOOP-1,J2LOOP)+XXDS(JILOOP-1,J2LOOP)
+ XDSX(JILOOP,J2LOOP)=XDSX(JILOOP-1,J2LOOP)+XXDS(JILOOP-1,J2LOOP)*ZCANGLE
+ XDSY(JILOOP,J2LOOP)=XDSY(JILOOP-1,J2LOOP)+XXDS(JILOOP-1,J2LOOP)*ZZSANGLE
+!
+! Checks whether the section length fits into the displayed domain?
+!
+ IF(LDEFCV2CC)THEN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! IF(ABS((ZCVX1-ZCVX2)/zcvx1) > 1.E-7)THEN
+!!*******************************************************
+ IF(ZCVX1 /= ZCVX2)THEN
+!!*******************************************************
+
+ if(nverbia > 0)then
+ print '('' +++veriflen ZCVX1,ZCVX2,ZXREF1,ZXREF2,XDSX(JILOOP,J2LOOP)'',5(2X,F12.3))',ZCVX1,ZCVX2, &
+ ZXREF1,ZXREF2,XDSX(JILOOP,J2LOOP)
+ print '('' +++veriflen ZCVY1,ZCVY2,ZYREF1,ZYREF2,XDSY(JILOOP,J2LOOP)'',5(2X,F12.3))',ZCVY1,ZCVY2, &
+ ZYREF1,ZYREF2,XDSY(JILOOP,J2LOOP)
+ endif
+
+ IF(XDSX(JILOOP,J2LOOP) < ZXREF1) THEN
+! IF(XDSX(JILOOP,J2LOOP) <= ZXREF1) THEN
+ XDSX(JILOOP,J2LOOP) = ZXREF1
+ IF(ZXREF1 == ZCVX1)THEN
+ XDSY(JILOOP,J2LOOP)= ZCVY1
+ ELSE
+ XDSY(JILOOP,J2LOOP)= ZCVY2
+ ENDIF
+ ZMEY=ABS(XDSY(JILOOP,J2LOOP)-XDSY(JILOOP-1,J2LOOP))
+ ZMEX=ABS(XDSX(JILOOP,J2LOOP)-XDSX(JILOOP-1,J2LOOP))
+ ZME=ABS(ZMEX*ZCANGLE) + ABS(ZMEY*ZZSANGLE)
+ if(NVERBIA > 0)THEN
+ print *,' AP IF(XDSX(JILOOP,J2LOOP) < ZXREF1 Longueur de la derniere maille calculee ',ZME
+ endif
+ XDS(JILOOP,J2LOOP)=XDS(JILOOP-1,J2LOOP)+ZME
+ XXDS(JILOOP-1,J2LOOP)=ZME
+ NLMAX=JILOOP
+ if(NVERBIA > 0)THEN
+ print *,' Controles . NLMAX calcule : ',NLMAX,' Grille N.',J2LOOP
+ print *,' Controles . Coord. conformes des extremites de la coupe demandees :'
+ print *,' (',ZCVX1,',',ZCVY1,') (',ZCVX2,',',ZCVY2,')'
+ print *,' Controles . Coord. conformes des extremites de la coupe calculees :'
+ print *,' (',XDSX(1,J2LOOP),',',XDSY(1,J2LOOP),') (',XDSX(NLMAX,J2LOOP),',',XDSY(NLMAX,J2LOOP),')'
+ print *,' xds xdsx xdsy ZCANGLE ZSANGLE ', ZCANGLE,ZZSANGLE
+ print *,' **** XDS'
+ print *,xds(1:nlmax,j2loop)
+ print *,' **** XXDS'
+ print *,xxds(1:nlmax,j2loop)
+ print *,' **** XDSX'
+ print *,xdsx(1:nlmax,j2loop)
+ print *,' **** XDSY'
+ print *,xdsy(1:nlmax,j2loop)
+ endif
+ EXIT
+ ELSE IF(XDSX(JILOOP,J2LOOP) > ZXREF2)THEN
+! ELSE IF(XDSX(JILOOP,J2LOOP) >= ZXREF2)THEN
+ XDSX(JILOOP,J2LOOP) = ZXREF2
+ IF(ZXREF2 == ZCVX1)THEN
+ XDSY(JILOOP,J2LOOP)= ZCVY1
+ ELSE
+ XDSY(JILOOP,J2LOOP)= ZCVY2
+ ENDIF
+ ZMEY=ABS(XDSY(JILOOP,J2LOOP)-XDSY(JILOOP-1,J2LOOP))
+! IF(ABS(ZZSANGLE) < 1.E-32)THEN
+! ZME=ZMEY
+! ELSE
+! ZME=ABS(ZMEY/ZZSANGLE)
+! ENDIF
+ ZMEX=ABS(XDSX(JILOOP,J2LOOP)-XDSX(JILOOP-1,J2LOOP))
+ ZME=ABS(ZMEX*ZCANGLE) + ABS(ZMEY*ZZSANGLE)
+ IF(NVERBIA > 0)THEN
+ print *,' AP IF(XDSX(JILOOP,J2LOOP) > ZXREF2 Longueur de la derniere maille calculee ',ZME
+ ENDIF
+ XDS(JILOOP,J2LOOP)=XDS(JILOOP-1,J2LOOP)+ZME
+ XXDS(JILOOP-1,J2LOOP)=ZME
+ NLMAX=JILOOP
+ if(NVERBIA > 0)THEN
+ print *,' Controles . NLMAX calcule : ',NLMAX,' Grille N.',J2LOOP
+ print *,' Controles . Coord. conformes des extremites de la coupe demandees :'
+ print *,' (',ZCVX1,',',ZCVY1,') (',ZCVX2,',',ZCVY2,')'
+ print *,' Controles . Coord. conformes des extremites de la coupe calculees :'
+ print *,' (',XDSX(1,J2LOOP),',',XDSY(1,J2LOOP),') (',XDSX(NLMAX,J2LOOP),',',XDSY(NLMAX,J2LOOP),')'
+ print *,' xds xdsx xdsy ZCANGLE ZSANGLE ', ZCANGLE,ZZSANGLE
+ print *,' **** XDS'
+ print *,xds(1:nlmax,j2loop)
+ print *,' **** XXDS'
+ print *,xxds(1:nlmax,j2loop)
+ print *,' **** XDSX'
+ print *,xdsx(1:nlmax,j2loop)
+ print *,' **** XDSY'
+ print *,xdsy(1:nlmax,j2loop)
+ endif
+ EXIT
+!!ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
+ ELSE IF(XDSY(JILOOP,J2LOOP) < ZYREF1) THEN
+! ELSEIF(XDSY(JILOOP,J2LOOP) <= ZYREF1) THEN
+ XDSY(JILOOP,J2LOOP) = ZYREF1
+ IF(ZYREF1 == ZYREF2)THEN
+ IF(ABS(XDSX(JILOOP-1,J2LOOP)-ZCVX1) < &
+ ABS(XDSX(JILOOP-1,J2LOOP)-ZCVX2))THEN
+ XDSX(JILOOP,J2LOOP)= ZCVX1
+ ELSE
+ XDSX(JILOOP,J2LOOP)= ZCVX2
+ ENDIF
+ ELSE
+ IF(ZYREF1 == ZCVY1)THEN
+ XDSX(JILOOP,J2LOOP)= ZCVX1
+ ELSE
+ XDSX(JILOOP,J2LOOP)= ZCVX2
+ ENDIF
+ ENDIF
+ ZMEY=ABS(XDSY(JILOOP,J2LOOP)-XDSY(JILOOP-1,J2LOOP))
+ ZMEX=ABS(XDSX(JILOOP,J2LOOP)-XDSX(JILOOP-1,J2LOOP))
+ ZME=ABS(ZMEX*ZCANGLE) + ABS(ZMEY*ZZSANGLE)
+ IF(NVERBIA > 0)THEN
+ print *,' AP IF(XDSY(JILOOP,J2LOOP) <= ZYREF1 Longueur de la derniere maille calculee ',ZME
+ ENDIF
+ XDS(JILOOP,J2LOOP)=XDS(JILOOP-1,J2LOOP)+ZME
+ XXDS(JILOOP-1,J2LOOP)=ZME
+ NLMAX=JILOOP
+ if(NVERBIA > 0)THEN
+ print *,' Controles . NLMAX calcule : ',NLMAX,' Grille N.',J2LOOP
+ print *,' Controles . Coord. conformes des extremites de la coupe demandees :'
+ print *,' (',ZCVX1,',',ZCVY1,') (',ZCVX2,',',ZCVY2,')'
+ print *,' Controles . Coord. conformes des extremites de la coupe calculees :'
+ print *,' (',XDSX(1,J2LOOP),',',XDSY(1,J2LOOP),') (',XDSX(NLMAX,J2LOOP),',',XDSY(NLMAX,J2LOOP),')'
+ print *,' xds xdsx xdsy ZCANGLE ZSANGLE ', ZCANGLE,ZZSANGLE
+ print *,' **** XDS'
+ print *,xds(1:nlmax,j2loop)
+ print *,' **** XXDS'
+ print *,xxds(1:nlmax,j2loop)
+ print *,' **** XDSX'
+ print *,xdsx(1:nlmax,j2loop)
+ print *,' **** XDSY'
+ print *,xdsy(1:nlmax,j2loop)
+ endif
+ EXIT
+ ELSE IF(XDSY(JILOOP,J2LOOP) > ZYREF2)THEN
+! ELSE IF(XDSY(JILOOP,J2LOOP) >= ZYREF2)THEN
+ IF(ZYREF1 == ZYREF2)THEN
+ IF(ABS(XDSX(JILOOP-1,J2LOOP)-ZCVX1) < &
+ ABS(XDSX(JILOOP-1,J2LOOP)-ZCVX2))THEN
+ XDSX(JILOOP,J2LOOP)= ZCVX1
+ ELSE
+ XDSX(JILOOP,J2LOOP)= ZCVX2
+ ENDIF
+ ELSE
+ XDSY(JILOOP,J2LOOP) = ZYREF2
+ IF(ZYREF2 == ZCVY1)THEN
+ XDSX(JILOOP,J2LOOP)= ZCVX1
+ ELSE
+ XDSX(JILOOP,J2LOOP)= ZCVX2
+ ENDIF
+ ENDIF
+ ZMEY=ABS(XDSY(JILOOP,J2LOOP)-XDSY(JILOOP-1,J2LOOP))
+ ZMEX=ABS(XDSX(JILOOP,J2LOOP)-XDSX(JILOOP-1,J2LOOP))
+ ZME=ABS(ZMEX*ZCANGLE) + ABS(ZMEY*ZZSANGLE)
+ if(NVERBIA > 0)THEN
+ print *,' AP ELSE IF(XDSY(JILOOP,J2LOOP) >= ZYREF2 Longueur de la derniere maille calculee ',ZME
+ endif
+ XDS(JILOOP,J2LOOP)=XDS(JILOOP-1,J2LOOP)+ZME
+ XXDS(JILOOP-1,J2LOOP)=ZME
+ NLMAX=JILOOP
+ if(NVERBIA > 0)THEN
+ print *,' Controles . NLMAX calcule : ',NLMAX,' Grille N.',J2LOOP
+ print *,' Controles . Coord. conformes des extremites de la coupe demandees :'
+ print *,' (',ZCVX1,',',ZCVY1,') (',ZCVX2,',',ZCVY2,')'
+ print *,' Controles . Coord. conformes des extremites de la coupe calculees :'
+ print *,' (',XDSX(1,J2LOOP),',',XDSY(1,J2LOOP),') (',XDSX(NLMAX,J2LOOP),',',XDSY(NLMAX,J2LOOP),')'
+ print *,' xds xdsx xdsy ZCANGLE ZSANGLE ', ZCANGLE,ZZSANGLE
+ print *,' **** XDS'
+ print *,xds(1:nlmax,j2loop)
+ print *,' **** XXDS'
+ print *,xxds(1:nlmax,j2loop)
+ print *,' **** XDSX'
+ print *,xdsx(1:nlmax,j2loop)
+ print *,' **** XDSY'
+ print *,xdsy(1:nlmax,j2loop)
+ endif
+ EXIT
+!!ooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
+
+ ENDIF
+
+!!*******************************************************
+ ELSE
+!!*******************************************************
+
+ IF(XDSY(JILOOP,J2LOOP) < ZYREF1) THEN
+! IF(XDSY(JILOOP,J2LOOP) <= ZYREF1) THEN
+ XDSY(JILOOP,J2LOOP) = ZYREF1
+ IF(ZYREF1 == ZCVY1)THEN
+ XDSX(JILOOP,J2LOOP)= ZCVX1
+ ELSE
+ XDSX(JILOOP,J2LOOP)= ZCVX2
+ ENDIF
+ ZMEY=ABS(XDSY(JILOOP,J2LOOP)-XDSY(JILOOP-1,J2LOOP))
+ ZMEX=ABS(XDSX(JILOOP,J2LOOP)-XDSX(JILOOP-1,J2LOOP))
+ ZME=ABS(ZMEX*ZCANGLE) + ABS(ZMEY*ZZSANGLE)
+ IF(NVERBIA > 0)THEN
+ print *,' AP IF(XDSY(JILOOP,J2LOOP) < ZYREF1 Longueur de la derniere maille calculee ',ZME
+ ENDIF
+ XDS(JILOOP,J2LOOP)=XDS(JILOOP-1,J2LOOP)+ZME
+ XXDS(JILOOP-1,J2LOOP)=ZME
+ NLMAX=JILOOP
+ IF(NVERBIA > 0)THEN
+ print *,' Controles . NLMAX calcule : ',NLMAX,' Grille N.',J2LOOP
+ print *,' Controles . Coord. conformes des extremites de la coupe demandees :'
+ print *,' (',ZCVX1,',',ZCVY1,') (',ZCVX2,',',ZCVY2,')'
+ print *,' Controles . Coord. conformes des extremites de la coupe calculees :'
+ print *,' (',XDSX(1,J2LOOP),',',XDSY(1,J2LOOP),') (',XDSX(NLMAX,J2LOOP),',',XDSY(NLMAX,J2LOOP),')'
+ print *,' xds xdsx xdsy ZCANGLE ZSANGLE ', ZCANGLE,ZZSANGLE
+ print *,' **** XDS'
+ print *,xds(1:nlmax,j2loop)
+ print *,' **** XXDS'
+ print *,xxds(1:nlmax,j2loop)
+ print *,' **** XDSX'
+ print *,xdsx(1:nlmax,j2loop)
+ print *,' **** XDSY'
+ print *,xdsy(1:nlmax,j2loop)
+ endif
+ EXIT
+ ELSE IF(XDSY(JILOOP,J2LOOP) > ZYREF2)THEN
+! ELSE IF(XDSY(JILOOP,J2LOOP) >= ZYREF2)THEN
+ XDSY(JILOOP,J2LOOP) = ZYREF2
+ IF(ZYREF2 == ZCVY1)THEN
+ XDSX(JILOOP,J2LOOP)= ZCVX1
+ ELSE
+ XDSX(JILOOP,J2LOOP)= ZCVX2
+ ENDIF
+ ZMEY=ABS(XDSY(JILOOP,J2LOOP)-XDSY(JILOOP-1,J2LOOP))
+ ZMEX=ABS(XDSX(JILOOP,J2LOOP)-XDSX(JILOOP-1,J2LOOP))
+ ZME=ABS(ZMEX*ZCANGLE) + ABS(ZMEY*ZZSANGLE)
+ if(NVERBIA > 0)THEN
+ print *,' AP ELSE IF(XDSY(JILOOP,J2LOOP) > ZYREF2 Longueur de la derniere maille calculee ',ZME
+ ENDIF
+ XDS(JILOOP,J2LOOP)=XDS(JILOOP-1,J2LOOP)+ZME
+ XXDS(JILOOP-1,J2LOOP)=ZME
+! ZMEX=ABS(XDSX(JILOOP,J2LOOP)-XDSX(JILOOP-1,J2LOOP))
+! IF(ABS(ZCANGLE) < 1.E-32)THEN
+! ZME=ZMEX
+! ELSE
+! ZME=ABS(ZMEX/ZCANGLE)
+! ENDIF
+! IF(NVERBIA > 0)THEN
+! print *,' Longueur de la derniere maille calculee avec COS pour controle ',ZME
+! ENDIF
+ NLMAX=JILOOP
+ if(NVERBIA > 0)THEN
+ print *,' Controles . NLMAX calcule : ',NLMAX,' Grille N.',J2LOOP
+ print *,' Controles . Coord. conformes des extremites de la coupe demandees :'
+ print *,' (',ZCVX1,',',ZCVY1,') (',ZCVX2,',',ZCVY2,')'
+ print *,' Controles . Coord. conformes des extremites de la coupe calculees :'
+ print *,' (',XDSX(1,J2LOOP),',',XDSY(1,J2LOOP),') (',XDSX(NLMAX,J2LOOP),',',XDSY(NLMAX,J2LOOP),')'
+ print *,' xds xdsx xdsy ZCANGLE ZSANGLE ', ZCANGLE,ZZSANGLE
+ print *,' **** XDS'
+ print *,xds(1:nlmax,j2loop)
+ print *,' **** XXDS'
+ print *,xxds(1:nlmax,j2loop)
+ print *,' **** XDSX'
+ print *,xdsx(1:nlmax,j2loop)
+ print *,' **** XDSY'
+ print *,xdsy(1:nlmax,j2loop)
+ endif
+ EXIT
+
+ ENDIF
+
+!!*******************************************************
+ ENDIF
+!!*******************************************************
+
+ ELSE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ IF(LPOINTG)THEN
+ IID=1
+ IIF=IIU
+ ELSE
+ IID=IIB
+ IIF=IIE
+ ENDIF
+ IF(XDSX(JILOOP,J2LOOP).LT.XXX(MAX(NIL,IID),J2LOOP).OR. &
+ XDSX(JILOOP,J2LOOP).GT. &
+ XXX(MIN(NIH,IIF),J2LOOP))THEN
+ print *,' Vertical section overflows postprocessing window: ', &
+ 'X boundary reached after ',JILOOP,' points.'
+ print *,' Requested number of points: ',NLMAX
+ print *,' Computed X : ',XDSX(JILOOP,J2LOOP),' XMIN(NIL): ', &
+ XXX(NIL,J2LOOP),' XMAX(NIH): ',XXX(NIH,J2LOOP),' XMIN(1 or IIB): ', &
+ XXX(IID,J2LOOP),' XMAX(IIE or IIU): ',XXX(IIF,J2LOOP)
+! STOP
+ GEND=.TRUE.
+! print *,' NLMAX AVANT MODIF GRILLE ',NLMAX,' ',J2LOOP
+ IF(LPOINTG)THEN
+ NLMAX=JILOOP
+ ELSE
+ NLMAX=JILOOP-1
+ ENDIF
+ print *,' NLMAX APRES MODIF, NIDEBCOU NIL NIH ',NLMAX,NIDEBCOU, &
+ NIL,NIH
+ EXIT
+ END IF
+ IF(LPOINTG)THEN
+ IJD=1
+ IJF=IJU
+ ELSE
+ IJD=IJB
+ IJF=IJE
+ ENDIF
+ IF(XDSY(JILOOP,J2LOOP).LT.XXY(MAX(NJL,IJD),J2LOOP).OR. &
+ XDSY(JILOOP,J2LOOP).GT. &
+ XXY(MIN(NJH,IJF),J2LOOP))THEN
+ print *,' Vertical section overflows postprocessing window: ', &
+ 'Y boundary reached after ',JILOOP,' points.'
+ print *,' Requested number of points : ',NLMAX
+ print *,' Computed Y : ',XDSY(JILOOP,J2LOOP),' YMIN(NJL): ', &
+ XXY(NJL,J2LOOP),' YMAX(NJH): ',XXY(NJH,J2LOOP),' YMIN(1 or IJB): ', &
+ XXY(IJD,J2LOOP),' YMAX(IJE or IJU): ',XXY(IJF,J2LOOP)
+! STOP
+ GEND=.TRUE.
+! print *,' NLMAX AVANT MODIF GRILLE ',NLMAX,' ',J2LOOP
+ IF(LPOINTG)THEN
+ NLMAX=JILOOP
+ ELSE
+ NLMAX=JILOOP-1
+ ENDIF
+ print *,' NLMAX APRES MODIF, NJDEBCOU NJL NJH ',NLMAX,NJDEBCOU, &
+ NJL,NJH
+ EXIT
+ END IF
+
+ ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Gets IIA, IJA indexes to move forward to next meshbox
+!
+ CALL LENMAILLD(XDSX(JILOOP,J2LOOP),XDSY(JILOOP,J2LOOP),IIA,IJA, &
+ JILOOP,J2LOOP)
+
+ IF(GEND)THEN
+ print *,' NLMAX AVANT MODIF ',NLMAX,' pour grille ',J2LOOP
+ NLMAX=JILOOP
+ print *,' NLMAX APRES MODIF ',NLMAX
+ IF(XIDEBCOU.EQ.-999.)THEN
+ print *,' NIDEBCOU,NJDEBCOU,NIL,NIH,NJL,NJH ',NIDEBCOU, &
+ NJDEBCOU,NIL,NIH,NJL,NJH
+ ENDIF
+ EXIT
+ ENDIF
+ IF(GEND2)THEN
+ print *,' NLMAX AVANT MODIF ',NLMAX,' pour grille ',J2LOOP
+ NLMAX=JILOOP-1
+ print *,' NLMAX APRES MODIF ',NLMAX
+ IMODIF=J2LOOP ! car GEND2 remis a f pour grille suivante
+ EXIT
+ ENDIF
+!
+ ZIX=XXDXHAT(IIA,J2LOOP)
+ ZIY=XXDYHAT(IJA,J2LOOP)
+
+ ENDDO ! enddo 2
+ !
+ENDDO ! enddo 1
+! Avril 2002 Calcul lat,lon de la coupe
+IF(LCV .AND. .NOT.LCARTESIAN)THEN
+ DO J2LOOP=1,1 !do 1 (grid loop)
+ DO JILOOP=1,NLMAX !do 2
+ CALL SM_LATLON_S(XLATORI,XLONORI,XDSX(JILOOP,J2LOOP),&
+ XDSY(JILOOP,J2LOOP),ZZLA,ZZLO)
+ XLATCV(JILOOP)=ZZLA
+ XLONCV(JILOOP)=ZZLO
+ ENDDO ! enddo 2
+if(nverbia > 0)then
+ print *,' *** LATCV ',XLATCV(1:NLMAX)
+ print *,' *** LONCV ',XLONCV(1:NLMAX)
+endif
+ ENDDO ! enddo 1
+ IF (IMODIF/=0 .AND. LDEFCV2LL) THEN
+ ! prise en compte du chgt d extremite
+ XIFINCVLL=XLATCV(NLMAX) ; XJFINCVLL=XLONCV(NLMAX)
+ END IF
+ENDIF
+! Avril 2002
+IF(LDEFCV2CC)THEN
+ NIINF=IINF; NISUP=ISUP; NJINF=IJINF; NJSUP=IJSUP
+ IF(ICV == 0)THEN
+ LCV=.FALSE.
+ ENDIF
+ENDIF
+!
+CONTAINS
+!
+!--------------------------------------------------------------------------
+!--------------------------------------------------------------------------
+!
+!* 2. CONTAINED ROUTINE LENMAILLD
+! ---------------------------
+!--------------------------------------------------------------------------
+! ###################################################
+ SUBROUTINE LENMAILLD(PSX,PSY,KIA,KJA,KILOOP,K2LOOP)
+! ###################################################
+!
+!!**** *LENMAILLD* - Gets the I,J indexes of the gribox containing the current
+!!**** point along the abscissa of a vertical cross-section.
+!!
+!! PURPOSE
+!! -------
+! Computes the (KIA,KJA) indexes of the gridbox containing the current
+! (PSX,PSY) point along the abscissa of a vertical cross-section, and
+! checks whether the point is within the limits of the postprocessing
+! window. Test is made using grid number K2LOOP to locate the gridpoints.
+!
+!!** METHOD
+!! ------
+!! -NA-
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 14/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+!
+REAL :: PSX, PSY ! Given gridpoint location (meters)
+INTEGER :: KIA, KJA ! Return indexes to be used for the relevant
+ ! gridbox containing the given point
+INTEGER :: K2LOOP ! Selector of the grid to be used
+INTEGER :: KILOOP ! Current value of the "oblique index" along
+ ! the oblique vertical cross-section
+!
+!* 0.2 Local variables
+!
+INTEGER :: JI, JJ
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. LOCATES CIRCUMSCRIBING GRIDBOX AND CHECKS FOR OVERFLOW
+! ------------------------------------------------------
+! X scanning
+!
+DO JI=NIL,NIH
+ IF(PSX.LE.XXX(JI,K2LOOP))GO TO 1
+ENDDO
+!
+print *,' Out of TRACE window X=',PSX,' XMAX=',XXX(NIH,K2LOOP)
+!! no more STOP
+!STOP
+KIA=NIH
+GEND2=.TRUE.
+!! no more STOP
+!
+1 CONTINUE
+!
+!! no more STOP
+IF (.NOT. GEND2) THEN
+!! no more STOP
+IF(ABS(PSX-XXX(JI,K2LOOP)).LE.ABS(PSX-XXX(MAX(NIL,JI-1),K2LOOP)))THEN
+ IF(ZZSIC.GT.0.)KIA=JI
+ IF(ZZSIC.LT.0.)KIA=MAX(NIL,JI-1)
+ELSE
+ IF(ZZSIC.GT.0.)KIA=MAX(NIL,JI-1)
+ IF(ZZSIC.LT.0.)KIA=MAX(NIL,JI-2)
+END IF
+!! no more STOP
+END IF
+!! no more STOP
+!
+! Y scanning
+!
+DO JJ=NJL,NJH
+ IF(PSY.LE.XXY(JJ,K2LOOP))GO TO 2
+ENDDO
+!
+print *,' Out of TRACE window Y=',PSY,' YMAX=',XXY(NJH,K2LOOP)
+!! no more STOP
+!STOP
+KJA=NJH
+GEND2=.TRUE.
+!! no more STOP
+!
+2 CONTINUE
+!
+!! no more STOP
+IF (.NOT. GEND2) THEN
+!! no more STOP
+IF(ABS(PSY-XXY(JJ,K2LOOP)).LE.ABS(PSY-XXY(MAX(NJL,JJ-1),K2LOOP)))THEN
+ IF(ZZSIC.GT.0.)KJA=JJ
+ IF(ZZSIC.LT.0.)KJA=MAX(NJL,JJ-1)
+ELSE
+ IF(ZZSIC.GT.0.)KJA=MAX(NJL,JJ-1)
+ IF(ZZSIC.LT.0.)KJA=MAX(NJL,JJ-2)
+END IF
+!! no more STOP
+END IF
+!! no more STOP
+!
+! Index range control
+!
+IF(KIA.GE.NIH.AND.KILOOP.NE.NLMAX.AND.ZCANGLE.NE.0.)THEN
+ print *,' Out of TRACE window, X limit reached', &
+ ' after ',KILOOP,' points.'
+ print *,' Requested number of points : ',NLMAX
+ print *,' Computed X : ',XDSX(KILOOP,K2LOOP),' XMIN : ', &
+ XXX(NIL,K2LOOP),' XMAX : ',XXX(NIH,K2LOOP)
+ GEND=.TRUE.
+! EXIT
+! STOP
+END IF
+IF(KJA.GE.NJH.AND.KILOOP.NE.NLMAX.AND.ZZSANGLE.NE.0.)THEN
+ print *,' Out of TRACE window, Y limit reached', &
+ ' after',KILOOP,' points.'
+ print *,' Requested number of points : ',NLMAX
+ print *,' Computed Y : ',XDSY(KILOOP,K2LOOP),' YMIN : ', &
+ XXY(NJL,K2LOOP),' YMAX : ',XXY(NJH,K2LOOP)
+ GEND=.TRUE.
+! EXIT
+! STOP
+END IF
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+END SUBROUTINE LENMAILLD
+!------------------------------------------------------------------------------
+END SUBROUTINE VERIFLEN_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/compute_r00_pc.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/compute_r00_pc.f90
new file mode 100644
index 0000000000000000000000000000000000000000..95f8affcb3a99e038607005d06209f4251e036b8
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/compute_r00_pc.f90
@@ -0,0 +1,630 @@
+PROGRAM COMPUTE_R00
+! ###############################
+!
+! ce programme est la version PC du programme compute_r00.f90 de mesoNH utilisee
+! dans DIAG pouvant tourner sur PC seul afin de pouvoir se passer du
+! super-calculateur pour reconstituer a loisir des lachers de particules
+! arbitraires.
+!
+! on garde la structure Fortran 90 et les routines d'interpolation mais on
+! saisit les noms des fichiers a travers le fichier compute_r00.nam
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+! modules commun pour la lecture et l'ecriture
+!
+! NIMAX,NJMAX,NKMAX, NIINF, NISUP
+USE MODD_DIM1
+! grille : XXDXHAT(:,1:7) et XXX(:,1:7), XXZS(:,:,1:7)
+USE MODD_COORD
+! ref grille: XLON0,XLAT0,XBETA,XRPK
+USE MODD_GRID
+! descriptif grille: XXHAT(:) ,XLAT(:,:),XDXHAT(:),XMAP(:,:)
+! ,XZS(:,:),XZZ(:,:,:) ,XCOSSLOPE(:,:),XDIRCOSXW(:,:)
+USE MODD_GRID1
+! XVAR(i,j,k,,,), XMASK,XTRAJ ,XDATIME(16,t)
+USE MODD_ALLOC_FORDIACHRO
+! NBFILES + nom des fichiers CFILEDIAS, CLUOUTDIAS
+USE MODD_DIACHRO, ONLY:CFILEDIA,CLUOUTDIA, &
+ NLUOUTDIA,NRESPDIA,NNPRARDIA,NFTYPEDIA,NVERBDIA, NNINARDIA
+!
+USE MODI_WRITEVAR
+!
+IMPLICIT NONE
+!
+TYPE DATE
+INTEGER :: YEAR
+INTEGER :: MONTH
+INTEGER :: DAY
+END TYPE DATE
+!
+TYPE DATE_TIME
+TYPE (DATE) :: TDATE
+REAL :: TIME
+END TYPE DATE_TIME
+!
+!
+CHARACTER (LEN=28) :: HFMFILE ! name of the OUTPUT FM-file
+CHARACTER (LEN=31) :: HFMFILE_sto
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: IRESP ! return code in FM routines
+INTEGER :: INPRAR ! number of articles predicted in
+ ! the LFIFM file
+INTEGER :: ININAR ! number of articles present in
+ ! the LFIFM file
+INTEGER :: ITYPE ! type of file (conv2dia and transfer)
+!
+! **** la longueur du nom ne doit pas depasser 13 car. si le fichier
+! contient des groupes a un seul PROCessus, ou 9 si plusieurs PROCessus ****
+CHARACTER (LEN=13) :: YRECFM
+CHARACTER (LEN=100) :: YCOMMENT
+!
+INTEGER :: IFILECUR,JFILECUR,NIU,NJU,NKU,IGRID,ILENCH
+INTEGER :: NFILES,JLOOP
+REAL :: ZXOR,ZYOR,ZDX,ZDY
+REAL :: ZSPVAL
+REAL, ALLOCATABLE, DIMENSION(:,:,:):: ZX0, ZY0, ZZ0 ! origin of the
+ ! particules colocated with the mesh-grid points read in the file
+REAL, ALLOCATABLE, DIMENSION(:,:,:):: ZX00, ZY00, ZZ00, ZZL ! cumulative
+ ! origin for more than one restart of the tracers
+REAL, ALLOCATABLE, DIMENSION(:,:,:,:):: ZWORK
+TYPE(DATE_TIME) :: TDTCUR_START
+CHARACTER(LEN=24) :: YDATE
+INTEGER :: IHOUR, IMINUTE
+REAL :: ZSECOND, ZREMAIN
+LOGICAL :: GSTART
+INTEGER :: INBR_START
+REAL :: ZXMAX,ZYMAX,ZZMAX ! domain extrema
+INTEGER, DIMENSION(100) :: NBRFILES
+! declarations supplementaires
+INTEGER :: iret ! code de retour de lecture
+CHARACTER (LEN=3), SAVE :: CNAME_SUP
+!-----------------------------------------------------------------------
+! definitions des noms de fichiers venant de modd_sto_file de Meso-NH
+! et definition de la namelist prise dans diag.f90
+CHARACTER (LEN=28), SAVE :: CFILES(100) ! names of the files to be treated
+CHARACTER (LEN=28), SAVE :: CFILES_STA(100) ! status of these files 'INIT_SV'
+ ! if a restart of the lagrangian
+ ! tracers has been performed
+INTEGER , SAVE :: NSTART_SUPP(100) ! supplementary starts
+ ! for the lagrangian trajectories
+!-----------------------------------------------------------------------
+!
+! article supplementaire
+CHARACTER (LEN=28), SAVE :: CFIELD_LAG(100) ! tableau de noms de record devant
+CHARACTER (LEN=100),DIMENSION(:),ALLOCATABLE :: YUNITE
+! etre etudies lagrangiennement THM RVM RRM...
+INTEGER :: NUNDEF, inbr_field, NFILES_tot, k, ifield
+LOGICAL :: L2D
+CHARACTER (LEN=3), SAVE :: CFLAGFILE
+!
+!-----------------------------------------------------------------------
+!
+NAMELIST/NAM_STO_FILE/ CFILES, NSTART_SUPP
+!-----------------------------------------------------------------------
+!
+NAMELIST/NAM_FIELD /CFIELD_LAG
+!
+!-------------------------------------------------------------------------------
+!
+!* 1.0 Lecture des noms des fichiers et initialisation
+! -----------------------------------------------
+!
+! ouverture du fichier contenant les noms des fichiers diachroniques a
+! traiter
+!
+! ecrire les fichiers dans le meme ordre que pour DIAG1.nam (cf doc Gheusi +
+! Stein) dans NAM_STO_FILES i.e. ordre inverse chrono
+!
+!
+open (unit=104,FILE='compute_r00.nam',FORM='FORMATTED')
+!
+!
+nverbdia=1
+ITYPE=2
+ZSPVAL=-1.E+11
+NUNDEF=-9999
+CFILES(:) = ' '
+NSTART_SUPP(:) = NUNDEF
+CFILES_STA(:) = 'INIT_SV'
+CFIELD_LAG(:) = ' '
+CNAME_SUP='SAM'
+!
+READ(104,NML=NAM_STO_FILE)
+!
+READ(104,NML=NAM_FIELD)
+!
+close(104)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2.0 FIND THE FILE TO BE TREATED AND THE INIT-SV FILES
+! -------------------------------------------------
+!
+!
+! determination du nombre de champs de var a traiter lagrangiennement
+inbr_field=0
+DO JLOOP=1,100
+ IF (LEN_TRIM(CFIELD_LAG(JLOOP))/= 0) THEN
+ inbr_field=inbr_field+1
+ END IF
+END DO
+!
+!
+! recherche du nombre total de fichier a traiter
+NFILES_tot=0
+DO JFILECUR=1,100
+ IF (LEN_TRIM(CFILES(JFILECUR)) /= 0 ) THEN
+ NFILES_tot= NFILES_tot +1
+ ENDIF
+END DO
+!
+! ouverture des fichiers
+do jfilecur=1,NFILES_tot
+ CFLAGFILE='OPE'
+ CALL READVAR('ZSBIS',CFILES(jfilecur),CFLAGFILE,nverbdia,iret)
+end do
+!
+if (nverbdia>0) then
+ print *,'nbre de fichiers a traiter',NFILES_tot
+ print *,'nombre de champs de var a traiter lagrangiennement',inbr_field
+end if
+!
+!**************************************************
+!**************************************************
+! pour coller a la version MESONH je prends les memes noms
+! cette boucle correspond au traitement de diag pour chacun des fichiers
+! a traiter
+do ifilecur=1,NFILES_tot
+HFMFILE=CFILES(ifilecur)
+print *,'fichier traite HFMFILE = ',HFMFILE
+!**************************************************
+!**************************************************
+! rem on n'indente pas la boucle ifilecur
+!pour garder le code commun avec compute_r00.f90 sur VPP
+!
+!
+! Search the number of the files(NFILES), where the Lagrangian tracers
+!have been reinitialized
+NFILES=0
+DO JFILECUR=IFILECUR+1,100
+ IF (LEN_TRIM(CFILES(JFILECUR)) /= 0 .AND. &
+ CFILES_STA(JFILECUR) == 'INIT_SV') THEN
+ NFILES= NFILES +1
+ NBRFILES(NFILES)=JFILECUR ! contains the number of the files where
+ ! the Lag. tracers have been restarted
+ ENDIF
+END DO
+!
+! compute the number of supplementary cumulative starts
+INBR_START=1
+DO JLOOP=1,NFILES-1
+ IF (NSTART_SUPP(JLOOP)/=NUNDEF .AND. NSTART_SUPP(JLOOP)> IFILECUR ) THEN
+ INBR_START=INBR_START+1
+ END IF
+END DO
+!
+if (nverbdia >0) then
+ print *,'INBR_START = ',INBR_START,' pour le fichier ',IFILECUR
+end if
+!-------------------------------------------------------------------------------
+!
+!* 3.0 ALLOCATIONS OF THE ARRAYS AND CONVERSIONS
+! -----------------------------------------
+!
+NIU=SIZE(XZZ,1)
+NJU=SIZE(XZZ,2)
+NKU=SIZE(XZZ,3)
+if (nju==3) then
+ L2D=.TRUE.
+else
+ L2D=.FALSE.
+end if
+if (nverbdia >0) print *,'L2D = ',L2D
+!
+if (.NOT. allocated(ZX0)) then ! pas d'indentation pour garder la possibilite
+ ! de faire un diff des compute_r00
+ALLOCATE(ZX0(NIU,NJU,NKU))
+ALLOCATE(ZY0(NIU,NJU,NKU))
+ALLOCATE(ZZ0(NIU,NJU,NKU))
+ALLOCATE(ZWORK(NIU,NJU,NKU,inbr_field+3))
+ALLOCATE(YUNITE(inbr_field))
+ALLOCATE(ZX00(NIU,NJU,NKU))
+ALLOCATE(ZY00(NIU,NJU,NKU))
+ALLOCATE(ZZ00(NIU,NJU,NKU))
+ALLOCATE(ZZL(NIU,NJU,NKU))
+!
+end if
+! initial values
+ZXOR=0.5 * (XXHAT(2)+XXHAT(3))
+ZYOR=0.5 * (XYHAT(2)+XYHAT(3))
+ZDX= XXHAT(3)-XXHAT(2)
+ZDY= XYHAT(3)-XYHAT(2)
+!ZZL=MZF(XZZ)
+do k=1,nku-1
+ zzl(:,:,k)=(XZZ(:,:,k)+XZZ(:,:,k+1))*0.5
+end do
+ZZL(:,:,NKU)=2*XZZ(:,:,NKU)-ZZL(:,:,NKU-1)
+ZXMAX=ZXOR+(NIU-3)*ZDX
+ZYMAX=ZYOR+(NJU-3)*ZDY
+ZZMAX=ZZL(2,2,NKU-1)
+! conversion from m to km
+ZXOR=ZXOR*1.E-3
+ZYOR=ZYOR*1.E-3
+ZDX=ZDX*1.E-3
+ZDY=ZDY*1.E-3
+ZZL(:,:,:)=ZZL(:,:,:)*1.E-3
+ZXMAX=ZXMAX*1.E-3
+ZYMAX=ZYMAX*1.E-3
+ZZMAX=ZZMAX*1.E-3
+!
+CALL READVAR('LGXM',CFILES(ifilecur),CFLAGFILE,nverbdia,iret)
+ZX00(:,:,:)=XVAR(:,:,:,1,1,1)
+CALL READVAR('LGYM',CFILES(ifilecur),CFLAGFILE,nverbdia,iret)
+ZY00(:,:,:)=XVAR(:,:,:,1,1,1)
+CALL READVAR('LGZM',CFILES(ifilecur),CFLAGFILE,nverbdia,iret)
+ZZ00(:,:,:)=XVAR(:,:,:,1,1,1)
+! what is the unit of Lag. var. (km after DIAG, m after MODEL) ?
+IF (INDEX(CCOMMENT(1),'KM')/=0 .OR. &
+ MAXVAL(ZZ00(:,:,:))<100. ) THEN
+ print*,'unit of Lagrangian variables in ',TRIM(CFILES(ifilecur)),' is KM'
+ELSE
+ print*,'unit of Lagrangian variables in ',TRIM(CFILES(ifilecur)),' is M'
+ ZX00(:,:,:)=ZX00(:,:,:)*1.E-3 ! conversion from m to km
+ ZY00(:,:,:)=ZY00(:,:,:)*1.E-3
+ ZZ00(:,:,:)=ZZ00(:,:,:)*1.E-3
+ENDIF
+!
+!
+IF (L2D) THEN
+ WHERE ( ZX00<ZXOR .OR. ZX00>ZXMAX .OR. &
+ ZZ00>ZZMAX)
+ ZX00=ZSPVAL
+ ZZ00=ZSPVAL
+ END WHERE
+ELSE
+ WHERE ( ZX00<ZXOR .OR. ZX00>ZXMAX .OR. &
+ ZY00<ZYOR .OR. ZY00>ZYMAX .OR. &
+ ZZ00>ZZMAX)
+ ZX00=ZSPVAL
+ ZY00=ZSPVAL
+ ZZ00=ZSPVAL
+ END WHERE
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 4.0 COMPUTE THE ORIGIN STEP BY STEP
+! -------------------------------
+!
+!
+! General loop for the files where a reinitialisation of the tracers
+! is performed
+DO JFILECUR=1,NFILES
+ !
+ !CALL FMOPEN_ll(CFILES(NBRFILES(JFILECUR)),'READ',CLUOUT, &
+ ! INPRAR,ITYPE,NVERB,ININAR,IRESP)
+!
+!* 4.1 check if this file is a start instant
+!
+ GSTART=.FALSE.
+ DO JLOOP=1,NFILES
+ IF (NBRFILES(JFILECUR)==NSTART_SUPP(JLOOP) .OR. JFILECUR==NFILES) THEN
+ INBR_START=INBR_START-1
+ GSTART=.TRUE.
+ EXIT
+ END IF
+ ENDDO
+ !
+ if (nverbdia>0) then
+ print *, 'fichier pour la reconstitution ',JFILECUR,' GSTART =',GSTART
+ end if
+!
+!* 4.2 read the potential temp or the water vapor at the start instant
+!
+ IF (GSTART) THEN
+ !
+ if(inbr_field>0) then
+ do ifield=1,inbr_field
+ YRECFM=CFIELD_LAG(ifield)
+ CALL READVAR(YRECFM,CFILES(NBRFILES(JFILECUR)),CFLAGFILE &
+ ,nverbdia,iret)
+ ZWORK(:,:,:,ifield)=XVAR(:,:,:,1,1,1)
+ YUNITE(ifield)=CUNITE(1)
+ end do
+ else
+ CALL READVAR('PABSM',CFILES(NBRFILES(JFILECUR)),CFLAGFILE &
+ ,nverbdia,iret)
+ endif
+ TDTCUR_START%TDATE%YEAR=XDATIME(5,1)
+ TDTCUR_START%TDATE%MONTH=XDATIME(6,1)
+ TDTCUR_START%TDATE%DAY=XDATIME(7,1)
+ TDTCUR_START%TIME=XDATIME(8,1)
+ IHOUR = INT(TDTCUR_START%TIME/3600.)
+ ZREMAIN = MOD(TDTCUR_START%TIME,3600.)
+ IMINUTE = INT(ZREMAIN/60.)
+ ZSECOND = MOD(ZREMAIN,60.)
+ WRITE(YDATE,FMT='(1X,I4.4,I2.2,I2.2,2X,I2.2,"H",I2.2,"M", &
+ & F5.2,"S")') TDTCUR_START%TDATE, IHOUR,IMINUTE,ZSECOND
+ END IF
+!
+!* 4.3 store the X0,Y0,Z0 field for the current start before
+! computing the new origin
+!
+ IF (GSTART) THEN
+ IGRID=1
+ PRINT *,'INBR_START',INBR_START,' NBRFILES(JFILECUR)',NBRFILES(JFILECUR)
+ WRITE(YRECFM,'(A2,I2.2)')'X0',INBR_START
+ WRITE(YCOMMENT,'(A8,I2.2)')'X_Y_Z_X0',INBR_START
+ CTITRE(1)=YRECFM
+ CUNITE(1)='(KM)'
+ CCOMMENT(1)=YCOMMENT(1:10)//YDATE//' (KM)'
+ PRINT *,'COMMENT = ',CCOMMENT(1)
+ XVAR(:,:,:,1,1,1)=ZX00(:,:,:)
+ CALL WRITEVAR(1,NIU,1,NJU,1,NKU,1,1,1,1,1,1, &
+ YRECFM,HFMFILE,'OLD',CNAME_SUP,nverbdia,iret)
+ !
+ WRITE(YRECFM,'(A2,I2.2)')'Y0',INBR_START
+ WRITE(YCOMMENT,'(A8,I2.2)')'X_Y_Z_Y0',INBR_START
+ CTITRE(1)=YRECFM
+ CCOMMENT(1)=YCOMMENT(1:10)//YDATE//' (KM)'
+ CUNITE(1)='(KM)'
+ PRINT *,'COMMENT = ',CCOMMENT(1)
+ XVAR(:,:,:,1,1,1)=ZY00(:,:,:)
+ CALL WRITEVAR(1,NIU,1,NJU,1,NKU,1,1,1,1,1,1, &
+ YRECFM,HFMFILE,'OLD',CNAME_SUP,nverbdia,iret)
+ !
+ WRITE(YRECFM,'(A2,I2.2)')'Z0',INBR_START
+ WRITE(YCOMMENT,'(A8,I2.2)')'X_Y_Z_Z0',INBR_START
+ CTITRE(1)=YRECFM
+ CCOMMENT(1)=YCOMMENT(1:10)//YDATE//' (KM)'
+ CUNITE(1)='(KM)'
+ PRINT *,'COMMENT = ',CCOMMENT(1)
+ XVAR(:,:,:,1,1,1)=ZZ00(:,:,:)
+ CALL WRITEVAR(1,NIU,1,NJU,1,NKU,1,1,1,1,1,1, &
+ YRECFM,HFMFILE,'OLD',CNAME_SUP,nverbdia,iret)
+ END IF
+!
+!* 4.4 compute the origin of the particules using one more segment
+!
+ IF (JFILECUR /= NFILES) THEN
+ CALL READVAR('LGXM',CFILES(NBRFILES(JFILECUR)), &
+ CFLAGFILE,nverbdia,iret)
+ ZX0(:,:,:)=XVAR(:,:,:,1,1,1)
+ CALL READVAR('LGYM',CFILES(NBRFILES(JFILECUR)), &
+ CFLAGFILE,nverbdia,iret)
+ ZY0(:,:,:)=XVAR(:,:,:,1,1,1)
+ CALL READVAR('LGZM',CFILES(NBRFILES(JFILECUR)), &
+ CFLAGFILE,nverbdia,iret)
+ ZZ0(:,:,:)=XVAR(:,:,:,1,1,1)
+ ! what is the unit of Lag. var. (km after DIAG, m after MODEL) ?
+ IF (INDEX(CCOMMENT(1),'KM')/=0 .OR. &
+ MAXVAL(ZZ00(:,:,:))<100. ) THEN
+ print*,'unit of Lagrangian variables in ', &
+ TRIM(CFILES(NBRFILES(jfilecur))),' is KM'
+ ELSE
+ print*,'unit of Lagrangian variables in ', &
+ TRIM(CFILES(NBRFILES(jfilecur))),' is M'
+ ZX00(:,:,:)=ZX00(:,:,:)*1.E-3 ! conversion from m to km
+ ZY00(:,:,:)=ZY00(:,:,:)*1.E-3
+ ZZ00(:,:,:)=ZZ00(:,:,:)*1.E-3
+ ENDIF
+ !
+ ! old position of the set of particles
+ ZWORK(:,:,:,inbr_field+1)=ZX00
+ ZWORK(:,:,:,inbr_field+2)=ZY00
+ ZWORK(:,:,:,inbr_field+3)=ZZ00
+ !
+ IF (L2D) THEN
+ CALL INTERPXYZ(ZWORK(:,:,:,inbr_field+1),ZWORK(:,:,:,inbr_field+2),&
+ ZWORK(:,:,:,inbr_field+3),ZX0,ZX00,ZZ0,ZZ00 )
+ ELSE
+ CALL INTERPXYZ(ZWORK(:,:,:,inbr_field+1),ZWORK(:,:,:,inbr_field+2),&
+ ZWORK(:,:,:,inbr_field+3),ZX0,ZX00,ZY0,ZY00,ZZ0,ZZ00 )
+ END IF
+ !
+ IF (L2D) THEN
+ WHERE ( ZX00<ZXOR .OR. ZX00>ZXMAX .OR. &
+ ZZ00>ZZMAX)
+ ZX00=ZSPVAL
+ ZZ00=ZSPVAL
+ END WHERE
+ ELSE
+ WHERE ( ZX00<ZXOR .OR. ZX00>ZXMAX .OR. &
+ ZY00<ZYOR .OR. ZY00>ZYMAX .OR. &
+ ZZ00>ZZMAX)
+ ZX00=ZSPVAL
+ ZY00=ZSPVAL
+ ZZ00=ZSPVAL
+ END WHERE
+ END IF
+ !
+ !
+ END IF
+!
+!* 4.5 close the input file
+!
+ !!CALL FMCLOS_ll(CFILES(NBRFILES(JFILECUR)),'KEEP',CLUOUT,IRESP)
+!
+!
+!* 4.6 compute and store potential temp and water vapor at the origin
+!
+ IF (GSTART) THEN
+ !
+ do ifield=1,inbr_field
+ !
+ CALL INTERPXYZ(ZX00,ZY00,ZZ00, &
+ ZWORK(:,:,:,ifield),ZWORK(:,:,:,inbr_field+1) )
+ !
+ WRITE(YRECFM,'(A3,I2.2)')CFIELD_LAG(ifield),INBR_START
+ CTITRE(1)=YRECFM
+ print*,'CFIELD_LAG ',ifield,' TITRE= ',TRIM(CTITRE(1))
+ WRITE(YCOMMENT,'(A6,A3,I2.2)')'X_Y_Z_',CFIELD_LAG(ifield),INBR_START
+ CCOMMENT(1)=YCOMMENT(1:10)//YDATE//' (USI)'
+ PRINT *,'COMMENT = ',TRIM(CCOMMENT(1))
+ CUNITE(1)=YUNITE(ifield)
+ PRINT *,'CUNIT = ',TRIM(CUNITE(1))
+ XVAR(:,:,:,1,1,1)=ZWORK(:,:,:,ifield)
+ CALL WRITEVAR(1,NIU,1,NJU,1,NKU,1,1,1,1,1,1, &
+ YRECFM,HFMFILE,'OLD',CNAME_SUP,nverbdia,iret)
+ !
+ !
+ end do
+ !
+ END IF
+!
+!
+END DO
+!
+! fermeture du fichier diachronique
+IF (GSTART) call WRITEVAR(1,NIU,1,NJU,1,NKU,1,1,1,1,1,1, &
+ YRECFM,HFMFILE,'CLO',CNAME_SUP,nverbdia,iret)
+end do
+!***********************************************
+!***********************************************
+!
+PRINT*, ' '
+PRINT*, 'COMPUTE_R00 AFTER ORIGIN COMPUTATIONS AND STORAGE'
+!
+!-------------------------------------------------------------------------------
+!!
+CONTAINS
+!
+!
+!-------------------------------------------------------------------------------
+!
+!
+SUBROUTINE INTERPXYZ(PX,PY,PZ,PIN1,POUT1,PIN2,POUT2,PIN3,POUT3)
+!
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!* 0.1 declaration of arguments
+!
+REAL, INTENT(IN), DIMENSION(:,:,:) :: PX,PY,PZ
+REAL, INTENT(IN), DIMENSION(:,:,:) :: PIN1
+REAL, INTENT(OUT), DIMENSION(:,:,:) :: POUT1
+REAL, INTENT(IN), DIMENSION(:,:,:), OPTIONAL :: PIN2,PIN3
+REAL, INTENT(OUT), DIMENSION(:,:,:), OPTIONAL :: POUT2,POUT3
+!
+!* 0.2 declaration of local variables
+!
+INTEGER :: JI,JJ,JK,JKK ! loop index
+INTEGER :: II,IJ,IK ! grid index for the interpolation
+REAL :: ZXREL,ZYREL ! fractional grid index for the interpolation
+REAL, DIMENSION(SIZE(PIN1,3)) :: ZZLXY ! vertical grid at the interpolated point
+REAL :: ZEPS1,ZEPS2,ZEPS3 ! coeff. for the interpolation
+REAL :: ZX,ZY,ZZ
+LOGICAL :: GEXT
+!
+!-------------------------------------------------------------------------------
+!
+DO JK=1,NKU
+ DO JJ=1,NJU
+ DO JI=1,NIU
+ !
+ ZX=PX(JI,JJ,JK)
+ ZY=PY(JI,JJ,JK)
+ ZZ=PZ(JI,JJ,JK)
+ !
+ ! remove external points
+ IF (L2D) THEN
+ GEXT=(ZX==ZSPVAL).OR.(ZZ==ZSPVAL)
+ ELSE
+ GEXT=(ZX==ZSPVAL).OR.(ZY==ZSPVAL).OR.(ZZ==ZSPVAL)
+ END IF
+ IF (GEXT) THEN
+ POUT1(JI,JJ,JK) = ZSPVAL
+ IF (PRESENT(PIN2)) THEN
+ POUT2(JI,JJ,JK) = ZSPVAL
+ END IF
+ IF (PRESENT(PIN3)) THEN
+ POUT3(JI,JJ,JK) = ZSPVAL
+ ENDIF
+ !
+ CYCLE
+ !
+ END IF
+ !
+ ZXREL=(ZX-ZXOR)/ZDX+2
+ ZYREL=(ZY-ZYOR)/ZDY+2
+ !
+ II=FLOOR(ZXREL)
+ IJ=FLOOR(ZYREL)
+ !
+ ZEPS1=ZXREL-REAL(II)
+ ZEPS2=ZYREL-REAL(IJ)
+ IF (L2D) ZEPS2=0.
+ !
+ DO JKK=1,NKU
+ ZZLXY(JKK)=ZEPS2*(ZEPS1*(ZZL(II+1,IJ+1,JKK))+(1-ZEPS1)*(ZZL(II,IJ+1,JKK))) &
+ + (1-ZEPS2)*(ZEPS1*(ZZL(II+1,IJ,JKK))+(1-ZEPS1)*(ZZL(II,IJ,JKK)))
+ ENDDO
+ !
+ IK=999
+ DO JKK=2,NKU
+ IF (ZZLXY(JKK).GE.ZZ) THEN
+ IK=JKK-1
+ EXIT
+ ENDIF
+ ENDDO
+ !
+ IF (IK==999) THEN
+ PRINT*,'PROBLEM AT POINT',II,IJ
+ PRINT*,'XREL, YREL, Z =',ZXREL,ZYREL,ZZ
+ PRINT*,'ZZLXY(NKU)',ZZLXY(NKU)
+ STOP
+ END IF
+ !
+ ZEPS3=(ZZ-ZZLXY(IK))/(ZZLXY(IK+1)-ZZLXY(IK))
+ !
+ POUT1(JI,JJ,JK) = &
+ ZEPS3 * &
+ ( ZEPS2*(ZEPS1*(PIN1(II+1,IJ+1,IK+1))+(1-ZEPS1)*(PIN1(II,IJ+1,IK+1))) &
+ + (1-ZEPS2)*(ZEPS1*(PIN1(II+1,IJ,IK+1))+(1-ZEPS1)*(PIN1(II,IJ,IK+1))) &
+ ) &
+ + (1-ZEPS3) * &
+ ( ZEPS2*(ZEPS1*(PIN1(II+1,IJ+1,IK))+(1-ZEPS1)*(PIN1(II,IJ+1,IK))) &
+ + (1-ZEPS2)*(ZEPS1*(PIN1(II+1,IJ,IK))+(1-ZEPS1)*(PIN1(II,IJ,IK))) &
+ )
+ IF (PRESENT(POUT2)) THEN
+ POUT2(JI,JJ,JK) = &
+ ZEPS3 * &
+ ( ZEPS2*(ZEPS1*(PIN2(II+1,IJ+1,IK+1))+(1-ZEPS1)*(PIN2(II,IJ+1,IK+1)))&
+ + (1-ZEPS2)*(ZEPS1*(PIN2(II+1,IJ,IK+1))+(1-ZEPS1)*(PIN2(II,IJ,IK+1)))&
+ ) &
+ + (1-ZEPS3) * &
+ ( ZEPS2*(ZEPS1*(PIN2(II+1,IJ+1,IK))+(1-ZEPS1)*(PIN2(II,IJ+1,IK))) &
+ + (1-ZEPS2)*(ZEPS1*(PIN2(II+1,IJ,IK))+(1-ZEPS1)*(PIN2(II,IJ,IK))) &
+ )
+ ENDIF
+ !
+ IF (PRESENT(POUT3)) THEN
+ POUT3(JI,JJ,JK) = &
+ ZEPS3 * &
+ ( ZEPS2*(ZEPS1*(PIN3(II+1,IJ+1,IK+1))+(1-ZEPS1)*(PIN3(II,IJ+1,IK+1)))&
+ + (1-ZEPS2)*(ZEPS1*(PIN3(II+1,IJ,IK+1))+(1-ZEPS1)*(PIN3(II,IJ,IK+1)))&
+ ) &
+ + (1-ZEPS3) * &
+ ( ZEPS2*(ZEPS1*(PIN3(II+1,IJ+1,IK))+(1-ZEPS1)*(PIN3(II,IJ+1,IK))) &
+ + (1-ZEPS2)*(ZEPS1*(PIN3(II+1,IJ,IK))+(1-ZEPS1)*(PIN3(II,IJ,IK))) &
+ )
+ ENDIF
+ !
+ END DO
+ END DO
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+!
+END SUBROUTINE INTERPXYZ
+!
+!-------------------------------------------------------------------------------
+!
+END program
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/concat_time_diafile.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/concat_time_diafile.f90
new file mode 100644
index 0000000000000000000000000000000000000000..75ddd982c19cb7ca6e94d1e485bad0e694ca6342
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/concat_time_diafile.f90
@@ -0,0 +1,1392 @@
+ PROGRAM EXTRACTDIA
+! ###################
+!
+!!**** *EXTRACTDIA* - lecture d'enregistrements dans fichier diachronique,
+! traitement,
+! ecriture (11 types de format de fichier possibles)
+!!
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+! Lecture en entree:
+! d'une liste de fichiers diachroniques
+! du format de sortie
+! d'une liste de champs a traiter pour chaque fichier diachronique
+! d'un zoom selon toutes les directions inclu dans le champ a traiter
+! ( seul le zoom selon i,j,k est possible pour le format DIAC)
+!
+! Ecriture en sortie:
+! d'un fichier au format fonction de TYPEOUT c.a.d
+! DIAC= type diachro (un seul fichier contenant toutes
+! les variables selectionnées)
+! LLHV= lon lat alt val (un seul fichier contenant toutes
+! les variables selectionnées)
+! llhv= lat lon alt val (un seul fichier contenant toutes
+! les variables selectionnées)
+! ll ou LL zv lon lat niveau Z val
+!
+! ll ou LL pv lon lat niveau P val
+! FREE= format libre a choisir par l utilisateur (un fichier par variable)
+! KCDL ou ZCDL ou PCDL= format CDL (à convertir en netcdf via "tonetcdf")
+! (un seul fichier contenant toutes
+! les variables selectionnées)
+! KCDL si les niveaux verticaux sont les niveaux du modele
+! ZCDL si les niveaux verticaux sont des niveaux Z=constante donnes au programme
+! PCDL si les niveaux verticaux sont des niveaux P=constante donnes au programme
+!
+! pour les formats *CDL,*Z*,*P*, 2 types de grille horizontale sont possibles:
+! 'CONF' grille reguliere sur le plan de projection (conforme ou cartesien)
+! 'LALO' grille reguliere en lat-lon
+! dans ce cas les composantes du vent sont transformees
+! en composantes zonales et méridiennes.
+!!
+!! EXTERNAL
+!! --------
+!! FROM_COMPUTING_UNITS: retour aux unites initiales avant ecriture
+!! = passage inverse a celui realise par
+!! TO_COMPUTING_UNITS
+!! appele par writevar,writecdl,writellhv
+!! et par extractdia avant l ecriture au format FREE
+!! REFERENCE
+!! ---------
+!!
+!! AUTHORS
+!! -------
+!! I. Mallet , N. Asencio, J. Stein
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 17/03/2003
+! call to dd and ff routines
+! call to writeLLHV if LLHV
+! clean writevar to delete choice LLHV inside this routine
+! add PCDL,LLZV,llzv,LLPV,llpv cases
+! allow a zoom 0,0,jdeb,jfin or ideb,ifin,0,0 or 0,0,0,0 05/2005
+! add ALT 3Dfield if KCDL, add the LAT and LON 3Dfields if CONF and *CDL
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+! modules MesoNH
+USE MODD_CONF, ONLY: NVERB
+USE MODD_PARAMETERS, ONLY: JPHEXT,JPVEXT,XUNDEF
+USE MODD_DIM1, ONLY: NIMAX,NJMAX,NKMAX
+USE MODD_GRID, ONLY: XLATORI,XLONORI
+USE MODD_GRID1, ONLY: XZS,XZZ,XLAT,XLON,XXHAT,XYHAT
+USE MODD_LUNIT1, ONLY: CLUOUT
+USE MODE_GRIDPROJ ! subroutines SM_XYHAT et SM_LATLON
+USE MODI_UV_TO_ZONAL_AND_MERID
+USE MODI_HOR_INTERP_4PTS
+USE MODI_ZINTER
+USE MODI_PINTER
+! modules DIACHRO
+USE MODD_FILES_DIACHRO
+USE MODN_NCAR, ONLY: XSPVAL
+USE MODD_ALLOC_FORDIACHRO, ONLY: XVAR, & ! XVAR(i,j,k,t,n,p)
+ XTRAJZ, & ! XTRAJZ(k,t,n)
+ XDATIME, & ! XDATIME(16,t)
+ CTITRE, CUNITE,&! CTITRE(p),CUNITE(p)
+!* UPG irina
+ XTRAJT, & ! XTRAJT(t,n)
+!* UPG irina
+ NGRIDIA, & ! NGRIDIA(p)
+ NGRID
+USE MODD_COORD, ONLY: XXX,XXY,XXZS, & ! XXX(:,1:7), XXY(:,1:7), XXZS(:,:,1:7)
+ XXDXHAT,XXDYHAT ! XXDXHAT(:,1:7), XXDYHAT(:,1:7)
+USE MODD_RESOLVCAR, ONLY: CGROUP, NVERBIA, &
+ NNDIA, NPROCDIA, NBPROCDIA !pour appel a interp_grids
+USE MODD_TYPE_AND_LH, ONLY: NIL,NIH,NJL,NJH,NKL,NKH,CTYPE,LICP,LJCP
+! modules tools
+USE MODI_CHANGE_A_GRID
+USE MODI_LOW2UP
+USE MODI_CREATLINK
+USE MODI_DD
+USE MODI_FF
+USE MODI_WRITEDIR
+USE MODI_WRITELLHV
+USE MODI_WRITECDL
+USE MODI_WRITEVAR
+USE MODI_FROM_COMPUTING_UNITS
+USE MODD_READLH
+!
+IMPLICIT NONE
+!
+!* 0.1 Local variables declarations
+!
+INTEGER :: I
+INTEGER :: ILUDIR,IRESP
+INTEGER :: JLOOP,JI,JJ,JK,J5,J6,J4,JA,JGR
+! zoom lu pour les 6 dimensions possibles
+INTEGER :: iideb,iifin,ijdeb,ijfin,ikdeb,ikfin
+REAL :: zideb,zifin,zjdeb,zjfin
+INTEGER, dimension(2) :: iloc
+INTEGER :: itinf,itsup,itrajinf,itrajsup,iprocinf,iprocsup
+! zoom recalcule en fonction des dimensions du champ traite
+INTEGER :: ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin
+INTEGER :: ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup
+INTEGER :: ivarzmin,ivarzmax
+INTEGER :: inbvertz,IND_VERT,IND_LL
+REAL , allocatable, dimension(:,:,:):: ZWORK3D,ZWORK3D2,zffvent,zdirvent
+REAL , allocatable, dimension(:,:) :: zwork2d,zwork2d2
+REAL , allocatable, dimension(:,:) :: ZLAT,ZLON
+! pour traiter les champs budget deja zoomes
+REAL , allocatable, dimension(:,:,:,:,:,:):: ZVARSAVE
+! pour l interpolation verticale a P=cst : pinter
+REAL , allocatable, dimension(:,:,:) :: ZPABS
+! pour les interpolations verticales a P ou Z=cst
+REAL , allocatable, dimension(:,:,:) :: ZVARZCST
+REAL , allocatable, dimension(:) :: zlistevert
+INTEGER :: ikdebzint ! premier niveau a traiter
+! pour l interpolation sur grille reguliere lat lon
+REAL , allocatable, dimension(:,:) :: ZNEWLAT,ZNEWLON,ZNEWX,ZNEWY
+REAL :: ZDELTALAT,ZDELTALON
+!* UPG irina
+REAL :: ZLAG
+!* UPG irina
+REAL :: zmini,zmaxi
+INTEGER :: inetadd ! compteur de champs supp dans le fichier Netcdf
+INTEGER :: IFLAGzcst,IGRID
+INTEGER :: IDIM1,IDIM2,I1,I2,IZOOMIDEB,IZOOMIFIN,IZOOMJDEB,IZOOMJFIN
+INTEGER :: IAN,IMOIS,IJOUR,IHEURE,IMINUTE,ISECONDE
+!
+INTEGER :: ilocverbia,iret,iret2,iskip,ISAVENGRIDIA,iarg,INDX,IK
+CHARACTER(LEN=3) :: YK
+! flag pour initialiser/ne pas initialiser le zoom d
+! d ecriture :
+! ne pas initialiser quand ajout par le programme
+! des champs ALT LAT LON qui doivent conserver le
+! zoom de l utilisateur
+INTEGER :: ino_init_zoom
+! **** la taille des variables caracteres contenant les noms
+! de fichiers est obligatoirement de 28 ****
+CHARACTER(LEN=28) :: YFILEIN,YFILEOUT
+! **** la longueur du nom ne doit pas depasser 13 car. si le fichier
+! contient des groupes a un seul PROCessus, ou 9 si plusieurs PROCessus ****
+CHARACTER(LEN=13) :: YGROUP,YGROUP_OLD
+CHARACTER(LEN=20) :: YGROUP_SAVE
+CHARACTER(LEN=4) :: YTYPEOUT
+CHARACTER(LEN=1) :: YTYPEOUT3
+CHARACTER(LEN=3) :: YSUFFIX_file
+CHARACTER(LEN=250):: YFMTFREE ! format ecriture des champs si YTYPEOUT='FREE'
+CHARACTER(LEN=45) :: YFILEOUTFREE ! nom du fichier de sortie si YTYPEOUT='FREE'
+
+CHARACTER(LEN=5) :: YFLAGREADVAR ,YFLAGWRITE
+CHARACTER(LEN=4) :: YOUTGRID ! grille en sortie:
+ !CONF pour rester dans le plan conforme,
+ ! (le logiciel graphique devra réaliser la projection)
+ !LALO pour passer à lat,lon réguliers
+CHARACTER(LEN=28) :: YDUMMYFILE
+CHARACTER(LEN=11) :: YLUDIR ! Name of the dir file
+REAL , DIMENSION(:,:) ,ALLOCATABLE :: ZX,ZY
+!-------------------------------------------------------------------------------
+!
+!* 1. INIT
+! ----
+inetadd=0 !compteur de champs supp dans le fichier Netcdf
+!
+!Prints : 0=mini 1=debug mode in extractdia, readvar and writevar , writecdl, writellhv
+! 3=debug mode in routines diachro'
+! nverbia= controle des prints dans les routines diachro
+ilocverbia=0
+!
+! dans mesonh Xundef est utilise =999.
+! dans les routines diachro XSPVAL est utilisé
+XSPVAL=XUNDEF
+!
+! ouverture d un fichier dir ou vont s ecrire les entrees clavier
+YLUDIR='dirextract'
+CALL FMATTR(YLUDIR,YLUDIR,ILUDIR,IRESP)
+OPEN(UNIT=ILUDIR,FILE=YLUDIR,FORM='FORMATTED')
+!
+! Possibilite de definir un zoom d ecriture
+! definition locale du zoom pour extractdia et writevar, writecdl, writellhv
+iideb=0
+iifin=0
+ijdeb=0
+ijfin=0
+ikdeb=0
+ikfin=0
+itinf=0
+itsup=0
+itrajinf=0
+itrajsup=0
+iprocinf=0
+iprocsup=0
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. INPUT FILE AND FORMAT
+! ---------------------
+!
+!* 2.1 name of file and output format
+! ------------------------------
+!
+PRINT*, '- Name of the diachro file (without .lfi) ?'
+READ(5,'(A28)') YFILEIN
+CALL WRITEDIR(ILUDIR,YFILEIN)
+!
+PRINT*, '- type of the output file (DIAC/llhv/llzv/llpv/LLHV/LLZV/LLPV/FREE/KCDL/ZCDL/PCDL)'
+READ(5,'(A4)')YTYPEOUT
+CALL WRITEDIR(ILUDIR,YTYPEOUT)
+PRINT*,'the file ',TRIM(YFILEIN),' will be converted in type ',YTYPEOUT
+!
+PRINT*, '- Prints : 0=mini 1=debug mode in extractdia'
+PRINT*, ' 3=debug mode in routines diachro'
+PRINT*, '?'
+READ(5,*)ilocverbia
+CALL WRITEDIR(ILUDIR,ilocverbia)
+PRINT*, ' output prints= ',ilocverbia
+if ( ilocverbia > 2) nverbia=ilocverbia ! verbosity of diachro routines
+NVERB=ilocverbia ! verbosity of mesonh routines
+!
+!* 2.2 other parameters
+! ----------------
+!
+SELECT CASE (YTYPEOUT)
+ CASE('LLHV','llhv','DIAC','FREE','KCDL','ZCDL','PCDL','llzv','LLZV','llpv','LLPV') ! lecture des choix de l utilisateur
+!* UPG irina
+ IF ( YTYPEOUT == 'DIAC' ) THEN
+ PRINT*, 'valeur temporelle a ajouter a XTRAJT ? '
+ read(5,*) ZLAG
+ print*,ZLAG
+ ENDIF
+!* UPG irina
+ IF ( YTYPEOUT == 'FREE' ) THEN
+ PRINT*, '- format of writing for fields ? '
+ PRINT*, ' (fortran syntaxe of FMT in WRITE)'
+ PRINT*,'exemple: (10F9.3) or (8F0.3)'
+ PRINT*, '?'
+ READ(5,'(A)') YFMTFREE
+ CALL WRITEDIR(ILUDIR,YFMTFREE)
+ PRINT*, ' format=', TRIM(YFMTFREE)
+ ENDIF
+ ! lecture du zoom
+ IND_VERT= INDEX(YTYPEOUT(1:4),'Z') + INDEX(YTYPEOUT(1:4),'P') + &
+ INDEX(YTYPEOUT(1:4),'z') + INDEX(YTYPEOUT(1:4),'p')
+ IND_LL= INDEX(YTYPEOUT(1:2),'L') + INDEX(YTYPEOUT(1:2),'l')
+ IF (IND_LL==0) THEN
+ IF (IND_VERT/=0) THEN
+ ! cas 'ZCDL','PCDL'
+ PRINT*, '- zoom on the 2 first dimensions: '
+ PRINT*, ' ideb,ifin,jdeb,jfin'
+ PRINT*, '0,0,0,0 for the whole physical domain'
+ PRINT*, '-1,-1,-1,-1 for the whole domain'
+ PRINT*, '?'
+ READ(5,*) iideb,iifin,ijdeb,ijfin
+ CALL WRITEDIR(ILUDIR,iideb)
+ CALL WRITEDIR(ILUDIR,iifin)
+ CALL WRITEDIR(ILUDIR,ijdeb)
+ CALL WRITEDIR(ILUDIR,ijfin)
+ ELSE
+ ! cas 'DIAC','FREE','KCDL'
+ PRINT*, '- zoom on the 3 first dimensions: '
+ PRINT*, ' ideb,ifin,jdeb,jfin,kdeb,kfin'
+ PRINT*, '0,0,0,0,0,0 for the whole physical domain'
+ PRINT*, '-1,-1,-1,-1,-1,-1 for the whole domain'
+ PRINT*, '?'
+ READ(5,*) iideb,iifin,ijdeb,ijfin,ikdeb,ikfin
+ CALL WRITEDIR(ILUDIR,iideb)
+ CALL WRITEDIR(ILUDIR,iifin)
+ CALL WRITEDIR(ILUDIR,ijdeb)
+ CALL WRITEDIR(ILUDIR,ijfin)
+ CALL WRITEDIR(ILUDIR,ikdeb)
+ CALL WRITEDIR(ILUDIR,ikfin)
+ END IF
+ ELSE
+ ! cas 'llzv','LLZV','llpv','LLPV','llhv','LLHV'
+ PRINT*, '- zoom on the 2 first directions: '
+ PRINT*, ' lonmin,lonmax,latmin,latmax'
+ PRINT*, '0.,0.,0.,0. for the whole physical domain'
+ PRINT*, '-1.,-1.,-1.,-1. for the whole domain'
+ PRINT*, '?'
+ READ(5,*) zideb,zifin,zjdeb,zjfin
+ CALL WRITEDIR(ILUDIR,zideb)
+ CALL WRITEDIR(ILUDIR,zifin)
+ CALL WRITEDIR(ILUDIR,zjdeb)
+ CALL WRITEDIR(ILUDIR,zjfin)
+ if(zideb==0. .AND. zifin==0.) then
+ iideb=0 ; iifin=0
+ else if(zideb==-1. .AND. zifin==-1.) then
+ iideb=-1 ; iifin=-1
+ else
+ iideb=-2 ; iifin=-2
+ endif
+ if(zjdeb==0. .AND. zjfin==0.) then
+ ijdeb=0 ; ijfin=0
+ else if(zjdeb==-1. .AND. zjfin==-1.) then
+ ijdeb=-1 ; ijfin=-1
+ else
+ ijdeb=-2 ; ijfin=-2
+ endif
+ !! O.Nuissier
+ !!iideb=zideb ; iifin=zifin ; ijdeb=zjdeb ; ijfin=zjfin
+ !! O.Nuissier
+ IF (IND_VERT==0) THEN
+ ! cas 'llhv','LLHV'
+ PRINT*, '- zoom on the 3rd dimension: '
+ PRINT*, ' kdeb,kfin'
+ PRINT*, '0,0 for the whole physical domain'
+ PRINT*, '-1,-1 for the whole domain'
+ PRINT*, '?'
+ READ(5,*) ikdeb,ikfin
+ CALL WRITEDIR(ILUDIR,ikdeb)
+ CALL WRITEDIR(ILUDIR,ikfin)
+ END IF
+ END IF
+ PRINT*, '- zoom on the 3 last dimensions : '
+ PRINT*, ' itinf,itsup,itrajinf,itrajsup,iprocinf,iprocsup'
+ PRINT*, '0,0,0,0,0,0 for the whole last dimensions'
+ PRINT*, '?'
+ READ(5,*) itinf,itsup,itrajinf,itrajsup,iprocinf,iprocsup
+ CALL WRITEDIR(ILUDIR,itinf)
+ CALL WRITEDIR(ILUDIR,itsup)
+ CALL WRITEDIR(ILUDIR,itrajinf)
+ CALL WRITEDIR(ILUDIR,itrajsup)
+ CALL WRITEDIR(ILUDIR,iprocinf)
+ CALL WRITEDIR(ILUDIR,iprocsup)
+ IF ((iideb==-2) .AND. (ijdeb==-2)) THEN
+ PRINT*, ' zoom= ',zideb,zifin,zjdeb,zjfin,ikdeb,ikfin&
+ ,itinf,itsup,itrajinf,itrajsup,iprocinf,iprocsup
+ ELSE
+ PRINT*, ' zoom= ',iideb,iifin,ijdeb,ijfin,ikdeb,ikfin&
+ ,itinf,itsup,itrajinf,itrajsup,iprocinf,iprocsup
+ END IF
+ IF (IND_VERT/=0) THEN
+ PRINT*, '- Number of vertical levels for ',YTYPEOUT(IND_VERT:IND_VERT),' interpolation ?'
+ READ(5,*) inbvertz
+ CALL WRITEDIR(ILUDIR,inbvertz)
+ PRINT*, '- List of these levels (in meters or in hPa): exemple 500 1500 ?'
+ allocate (zlistevert(inbvertz))
+ READ(5,*) zlistevert
+ DO JI=1,inbvertz
+ CALL WRITEDIR(ILUDIR,zlistevert(JI))
+ END DO
+ PRINT*, ' interpolation for the following ',YTYPEOUT(IND_VERT:IND_VERT),' levels='
+ PRINT*, zlistevert
+ ENDIF
+ YOUTGRID='CONF'
+ IF (YTYPEOUT/='DIAC' .AND. YTYPEOUT/='llhv' .AND. YTYPEOUT/='LLHV') THEN
+ PRINT *,'- Fields in regular LAt/LOn grid'
+ PRINT *,' or in regular grid on CONFormal plan (native MesoNH grid) ?'
+ PRINT *,'LALO/CONF ?'
+ READ(5,*) YOUTGRID
+ CALL WRITEDIR(ILUDIR,YOUTGRID)
+ PRINT*, ' Output grid= ', YOUTGRID
+ PRINT*, ''
+ YSUFFIX_file=YTYPEOUT(1:2)//YTYPEOUT(4:4)
+ IF ( YTYPEOUT(2:4) == 'CDL') THEN
+ PRINT*, '!!!!!!!! Warning !!!!!!!!'
+ PRINT*, 'For the CDL type, the dimensions are initialised'
+ PRINT*, ' with those of the first field:'
+ PRINT*, 'the values of the 6 dimensions must be the maximum that'
+ PRINT*, ' will be treated '
+ PRINT*, '!!!!!!!! Warning !!!!!!!!'
+ PRINT*, 'For the CDL type, the coordinates must be the same'
+ PRINT*, ' for all fields'
+ PRINT*, '(stored in the output file with LAT/LON/ALT groups)'
+ PRINT*, '!!!!!!!!'
+ ENDIF
+ ENDIF
+ CASE DEFAULT
+ PRINT*, 'Incorrect value for the output type:',YTYPEOUT
+ PRINT*, ' the following ones are currently available : DIAC,LLHV,llhv,FREE,KCDL,ZCDL,PCDL,llzv,LLZV,llpv,LLPV'
+ STOP
+END SELECT
+!
+!* 2.3 init for input file and output file
+! -----------------------------------
+! in READVAR, input file must be opened before reading
+YFLAGREADVAR='OPE'
+! in WRITE routine, output file is new
+YFLAGWRITE='NEW'
+!
+!* 2.4 lecture de la pression pour interpolation
+! -----------------------------------------
+IF (INDEX(YTYPEOUT(1:4),'p')/=0 .OR. INDEX(YTYPEOUT(1:4),'P')/=0 )THEN
+ CALL READVAR('PABSM',YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print *, '- PABSM not found, name of the pressure variable ? '
+ read *,YGROUP
+ CALL WRITEDIR(ILUDIR,YGROUP)
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print *,' interpolation at P=cst not possible because PABSM and ',TRIM(YGROUP),' are not available'
+ STOP
+ ENDIF
+ ENDIF
+ ! stockage de ZPABS utilise par pinter
+ ALLOCATE ( ZPABS(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ZPABS(:,:,:)=XVAR(:,:,:,1,1,1)
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. LOOP ON GROUPS IN THE FILE
+! --------------------------
+!
+DO JGR=1,10000
+ !
+ !* 3.0 preparation pour la lecture du champ suivant
+ !
+ ino_init_zoom=0
+ PRINT*,'- Name of the group in upper case (13 characters max.)'
+ PRINT*,' (ex: THM or DD or FF or DD10 or FF10 or LAT or LON or ALT)'
+ PRINT*,'(GROUP for the list of groups, END to stop)?'
+ READ(5,'(A13)',END=88) CGROUP
+ CALL WRITEDIR(ILUDIR,CGROUP)
+ CGROUP=ADJUSTL(CGROUP)
+ CALL LOW2UP(CGROUP)
+ IF (CGROUP=='END') GO TO 88
+ ! point de reprise pour forcer l ecriture des champs ALT,LAT,LON
+ ! dans les fichiers netcdf
+77 CONTINUE
+ YGROUP_SAVE=CGROUP(1:13)
+ YK=''
+ INDX=INDEX(CGROUP,'_K_')
+ IF (INDX/=0) THEN
+ CGROUP=YGROUP_SAVE(1:INDX-1)
+ YK(1:3)=YGROUP_SAVE(INDX+3:INDX+5)
+ READ(YK,'(I3)') IK
+ END IF
+ IF (CGROUP(1:5)/='GROUP') &
+ PRINT*,'you asked for the following record: ',TRIM(CGROUP)
+ !
+ !* 3.1 Lecture et initialisation du tableau XVAR
+ ! passé en module MODD_ALLOC_FORDIACHRO
+ !
+ !
+ ! 3.1.1 Cas particulier pour le vent
+ !
+ IF ( CGROUP(1:2) == 'UM' .OR. &
+ CGROUP(1:2) == 'VM' .OR. &
+ CGROUP(1:2) == 'DD' .OR. &
+ CGROUP(1:2) == 'FF' ) THEN
+ !
+ IF ( (CGROUP(1:2)=='UM'.OR.CGROUP(1:2)=='VM') .AND. &
+ YOUTGRID(1:4) /= 'LALO' ) THEN
+ ! Lecture du champ U ou V sans calcul
+ ! les composantes du vent restent dans le plan conforme
+ CALL READVAR(CGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ ELSE
+ ! Lecture des 2 composantes du vent
+ !(stockees dans les tableaux ZWORK3D et ZWORK3D2)
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='UM'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='UM'//CGROUP(3:4)
+ ELSE
+ print*,'** problem with the name of group: ',CGROUP
+ CYCLE
+ ENDIF
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print *,TRIM(CGROUP),': ',TRIM(YGROUP),' not available'
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='UT'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='UT'//CGROUP(3:4)
+ ENDIF
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret2)
+ IF ( iret2 /= 0 ) then
+ print *,'** no processing for ',TRIM(CGROUP), &
+ ' because UM and ',TRIM(YGROUP),' are not available'
+ CYCLE
+ ENDIF
+ ENDIF
+ ! allocation du tableau de stockage de la 1e composante du vent
+ ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+ size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+ ZVARSAVE=XVAR
+ !
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VM'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='VM'//CGROUP(3:4)
+ ENDIF
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print *,TRIM(CGROUP),': ',TRIM(YGROUP),' not available'
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VT'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='VT'//CGROUP(3:4)
+ ENDIF
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret2)
+ IF ( iret2 /= 0 ) then
+ print *,'** no processing for ',TRIM(CGROUP), &
+ ' because VM and ',TRIM(YGROUP),' are not available'
+ CYCLE
+ ENDIF
+ iret=iret2
+ ENDIF
+ !
+ ! Calcul de ff
+ IF (CGROUP(1:2) == 'FF' ) THEN
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VENTFF'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='VENT'//CGROUP(3:4)//'FF'
+ ENDIF
+ ! allocation du tableau de calcul
+ IF (allocated(ZWORK3D)) DEALLOCATE(ZWORK3D)
+ ALLOCATE(ZWORK3D(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ ZWORK3D(:,:,:)=XSPVAL
+ DO J6=1,SIZE(XVAR,6)
+ IGRID=NGRIDIA(J6)
+ DO J5=1,SIZE(XVAR,5)
+ DO J4=1,SIZE(XVAR,4)
+ CALL FF (ZVARSAVE(:,:,:,J4,J5,J6),XVAR(:,:,:,J4,J5,J6),ZWORK3D, &
+ JPVEXT,JPHEXT,IGRID)
+ XVAR(:,:,:,J4,J5,J6)=ZWORK3D(:,:,:)
+ END DO
+ END DO
+ ! initialisation des variables necessaires a l ecriture
+ CGROUP=YGROUP
+ CTITRE(J6)=YGROUP
+ NGRIDIA(J6)=1
+ END DO
+ DEALLOCATE(ZWORK3D)
+ ! Calcul de dd par rapport au Nord geographique
+ ELSE IF (CGROUP(1:2) == 'DD') THEN
+ IF (CTYPE=='CART' .OR. CTYPE=='MASK' .OR. CTYPE=='SPXY') THEN
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VENTDD'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='VENT'//CGROUP(3:4)//'DD'
+ ENDIF
+ ! allocation du tableau de calcul
+ IF (allocated(ZWORK3D)) DEALLOCATE(ZWORK3D)
+ ALLOCATE(ZWORK3D(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ DO J6=1,SIZE(XVAR,6)
+ IGRID=NGRIDIA(J6)
+ DO J5=1,SIZE(XVAR,5)
+ DO J4=1,SIZE(XVAR,4)
+ iskip=1 ! tous les points de grille
+ CALL DD(ZVARSAVE(:,:,:,J4,J5,J6),XVAR(:,:,:,J4,J5,J6),ZWORK3D, &
+ iskip,IGRID,PLON=XLON(NIL:NIH,NJL:NJH))
+ XVAR(:,:,:,J4,J5,J6)=ZWORK3D(:,:,:)
+ END DO
+ END DO
+ ! initialisation des variables necessaires a l ecriture
+ CGROUP=YGROUP
+ CTITRE(J6)=YGROUP
+ CUNITE(J6)='degrees'
+ NGRIDIA(J6)=1
+ END DO
+ DEALLOCATE(ZWORK3D)
+ ELSE
+ print *,'** processing of ',TRIM(CGROUP),' is not performed for CTYPE= ',CTYPE
+ CYCLE
+ ENDIF
+ ELSE IF (CGROUP(1:2) == 'UM' .OR. CGROUP(1:2) == 'VM') THEN
+ IF (CTYPE=='CART' .OR. CTYPE=='MASK' .OR. CTYPE=='SPXY') THEN
+ ! Calcul des composantes zonale et meridienne
+ !(YOUTGRID(1:4) == 'LALO') avec la routine UV_TO_ZONAL_AND_MERID
+ print*,' Translate to meridional and zonal wind components'
+ ALLOCATE(ZWORK3D(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ ALLOCATE(ZWORK3D2(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ IF (ilocverbia >= 3 ) then
+ print *,'before UV_TO_ZONAL_AND_MERID KGRID=23'
+ print *,' dimensions of the input arrays',size(ZVARSAVE,1),&
+ size(ZVARSAVE,2),size(ZVARSAVE,3)
+ print *,size(XVAR,1),size(XVAR,2),size(XVAR,3)
+ print *,' dimensions of the output arrays',size(ZWORK3D,1),&
+ size(ZWORK3D,2),size(ZWORK3D,3)
+ print *,size(ZWORK3D2,1),size(ZWORK3D2,2),size(ZWORK3D2,3)
+ ENDIF
+ DO J6=1,SIZE(XVAR,6)
+ IGRID=NGRIDIA(J6)
+ DO J5=1,SIZE(XVAR,5)
+ DO J4=1,SIZE(XVAR,4)
+ CALL UV_TO_ZONAL_AND_MERID(ZVARSAVE(:,:,:,J4,J5,J6), &
+ XVAR(:,:,:,J4,J5,J6), &
+ 23,PZC=ZWORK3D,PMC=ZWORK3D2)
+ IF (CGROUP(1:1) == 'U' ) THEN
+ XVAR(:,:,:,J4,J5,J6)=ZWORK3D(:,:,:)
+ ENDIF
+ IF (CGROUP(1:1) == 'V' ) THEN
+ XVAR(:,:,:,J4,J5,J6)=ZWORK3D2(:,:,:)
+ ENDIF
+ END DO
+ END DO
+ END DO
+ IF (ilocverbia >= 3 ) then
+ print *,'after UV_TO_ZONAL_AND_MERID KGRID=23'
+ END IF
+ ! Stockage dans le tableau XVAR qui est le tableau ecrit
+ ! de la composante souhaitée
+ IF (CGROUP(1:1) == 'U' ) THEN
+ print *, ' U zonal wind component'
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='UZON'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='U'//CGROUP(3:4)//'ZON'
+ ENDIF
+ CGROUP=YGROUP
+ CTITRE(:)='U zonal wind component'
+ ENDIF
+ IF (CGROUP(1:1) == 'V' ) THEN
+ print *, ' V meridian wind component'
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VMED'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='V'//CGROUP(3:4)//'MED'
+ END IF
+ CGROUP=YGROUP
+ CTITRE(:)='V meridian wind component'
+ ENDIF
+ DEALLOCATE(ZWORK3D,ZWORK3D2)
+ ELSE
+ print *,' No processing of UZON and VMED for CTYPE= ',CTYPE
+ CYCLE
+ ENDIF
+ ENDIF
+ DEALLOCATE(ZVARSAVE)
+ ENDIF
+ !
+ ! 3.1.2 LATitude ou LONgitude de chaque point de la grille conforme
+ !
+ ELSE IF (CGROUP(1:3)=='LAT' .OR. CGROUP(1:3)=='LON') THEN
+ print *, 'LAT/LON asked and YFLAGREADVAR=', YFLAGREADVAR
+ IF ( YFLAGREADVAR /= 'NOP') THEN
+ ! Lecture d un champ 2D quelconque pour initialiser XLAT et XLON
+ CALL READVAR('ZSBIS',YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ ! cas de fichier diachronique sans ZSBIS
+ print *, '- Name of one group in upper case '
+ read *,YGROUP
+ CALL WRITEDIR(ILUDIR,YGROUP)
+ CALL LOW2UP(YGROUP)
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print * ,'**group ', TRIM(YGROUP) , 'not found'
+ stop
+ ENDIF
+ ENDIF
+ ENDIF
+ ! init du tableau XVAR au champ souhaite
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(size(XLAT,1),size(XLAT,2),1,1,1,1) )
+ IF (CGROUP(1:3)=='LAT') THEN
+ XVAR(:,:,1,1,1,1)=XLAT(:,:)
+ CTITRE(1)='latitudes'
+ CUNITE(1)='degrees_north'
+ ELSE IF (CGROUP(1:3)=='LON') THEN
+ XVAR(:,:,1,1,1,1)=XLON(:,:)
+ CTITRE(1)='longitudes'
+ CUNITE(1)='degrees_east'
+ ENDIF
+ !
+ ! 3.1.3 ALTitude de chaque point de la grille conforme
+ !
+ ELSE IF (CGROUP(1:3)=='ALT') THEN
+ print *, 'ALT asked and YFLAGREADVAR=', YFLAGREADVAR
+ IF(CTYPE=='SSOL'.OR.CTYPE=='DRST'.OR.CTYPE=='RAPL'.OR.CTYPE=='RSPL') THEN
+ IF ( YFLAGREADVAR == 'NOP') THEN
+ ! altitude des niveaux du groupe precedent dans XTRAJZ
+ print *,'warning, for CTYPE=',CTYPE,' ALTitude of previous group (',TRIM(YGROUP_OLD),')'
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(1,1,size(XTRAJZ,1),1,1,1))
+ XVAR(1,1,:,1,1,1)=XTRAJZ(:,1,1)
+ ELSE
+ print*,'** no processing with ALT at the first group'
+ GOTO 99
+ ENDIF
+ ELSE
+ IF ( YFLAGREADVAR /= 'NOP') THEN
+ ! Lecture d un champ 2D quelconque pour initialiser les tableaux XZZ
+ CALL READVAR('ZSBIS',YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ ! cas de fichier diachronique sans ZSBIS
+ print *, '- Name of one group in upper case '
+ read *,YGROUP
+ CALL WRITEDIR(ILUDIR,YGROUP)
+ CALL LOW2UP(YGROUP)
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print * ,'** group ', TRIM(YGROUP) , 'not found'
+ stop
+ ENDIF
+ ENDIF
+ ENDIF
+ ! init de XZZ a la grille de masse ( par defaut readvar
+ ! l initialise a la grille 4 des vitesse verticales W)
+ CALL COMPCOORD_FORDIACHRO(1)
+ ! init du tableau XVAR au champ souhaite
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(size(XZZ,1),size(XZZ,2),size(XZZ,3),1,1,1))
+ XVAR(:,:,:,1,1,1)=XZZ(:,:,:)
+ ! retour au XZZ grille 4
+ CALL COMPCOORD_FORDIACHRO(4)
+ ENDIF
+ CTITRE(1)='model levels altitudes ASL'
+ CUNITE(1)='meters'
+ !
+ ! 3.1.4 Default case
+ !
+ ELSE
+ !
+ ! Lecture du champ CGROUP et stockage dans XVAR
+ ! + Initialisation (si YFLAGREADVAR='OPE') des variables
+ ! des modules (cf USE en debut de programme)
+ ! Appel a menu_diachro pour la liste des groupes si CGROUP(1:5)=='GROUP'
+ !
+ CALL READVAR(CGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF (CGROUP(1:5)=='GROUP') CYCLE
+!* UPG irina
+ print*,'XTRAJT ',SIZE(XTRAJT,1),SIZE(XTRAJT,2)
+ print*,'XTRAJT av. modif. pour les .000 ',XTRAJT(:,:)
+ XTRAJT(:,:)=XTRAJT(:,:)+ZLAG
+!* UPG irina
+ !
+ ENDIF
+ !
+ IF ( iret == 0 ) THEN
+ zmini=MINVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ zmaxi=MAXVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ print * ,' After read, min,max of the variable ',TRIM(CGROUP),'=', zmini,zmaxi
+ !
+ !* 3.2 Init des bornes min max du zoom en fonction des
+ ! dimensions du tableau XVAR traite
+ !
+ IF ( ino_init_zoom == 0) THEN
+ IF (iideb == 0 .AND. iifin == 0 ) THEN
+ ivarideb=NREADIL ; ivarifin=NREADIH
+ IF (ivarideb/=ivarifin) THEN ! domI/=1
+ ivarideb=MAX(1+JPHEXT,NREADIL)
+ ivarifin=MIN(SIZE(XVAR,1)-JPHEXT,NREADIH)
+ !IF (ivarifin <= 0) THEN
+ ! dimI =1
+ !ivarideb=1 ; ivarifin=SIZE(XVAR,1)
+ !ENDIF
+ ENDIF
+ ELSE IF (iideb == -1 .AND. iifin == -1 ) THEN
+ ivarideb=MAX(1,NREADIL)
+ ivarifin=MIN(SIZE(XVAR,1),NREADIH)
+ ELSE IF (iideb == -2 .AND. iifin == -2 ) THEN
+ ivarideb=-2
+ iideb=1+JPHEXT
+ IF (zideb >= minval(XLON)) THEN
+ DO JJ=1,SIZE(XLON,2)
+ ivarideb=MAX(MIN(COUNT(XLON(:,JJ)<zideb),SIZE(XLON,1)),iideb)
+ iideb=ivarideb
+ END DO
+ ENDIF
+ ivarifin=-2
+ iifin=1+JPHEXT
+ IF (zifin <= maxval(XLON)) THEN
+ DO JJ=1,SIZE(XLON,2)
+ ivarifin=MAX(MIN(COUNT(XLON(:,JJ)<zifin),SIZE(XLON,1)),iifin)
+ iifin=ivarifin
+ END DO
+ ENDIF
+ ELSE
+ ivarideb=max(iideb,NREADIL)
+ ivarifin=min(iifin,NREADIH)
+ ivarideb=min(ivarideb,ivarifin)
+ ENDIF
+ IF(ijdeb == 0 .AND. ijfin == 0) THEN
+ ivarjdeb=NREADJL ; ivarjfin=NREADJH
+ IF (ivarjdeb/=ivarjfin) THEN ! domJ/=1
+ ivarjdeb=MAX(1+JPHEXT,NREADJL)
+ ivarjfin=MIN(SIZE(XVAR,2)-JPHEXT,NREADJH)
+ !IF (ivarjfin <= 0) THEN
+ ! dimJ =1
+ !ivarjdeb=1 ; ivarjfin=SIZE(XVAR,2)
+ !ENDIF
+ ENDIF
+ ELSE IF (ijdeb == -1 .AND. ijfin == -1 ) THEN
+ ivarjdeb=MAX(1,NREADJL)
+ ivarjfin=MIN(SIZE(XVAR,2),NREADJH)
+ ELSE IF (ijdeb == -2 .AND. ijfin == -2 ) THEN
+ ivarjdeb=-2
+ ijdeb=1+JPHEXT
+ IF (zjdeb >= minval(XLAT)) THEN
+ DO JI=1,SIZE(XLAT,1)
+ ivarjdeb=MAX(MIN(COUNT(XLAT(JI,:)<zjdeb),SIZE(XLAT,2)),ijdeb)
+ ijdeb=ivarjdeb
+ END DO
+ ENDIF
+ ivarjfin=-2
+ ijfin=1+JPHEXT
+ IF (zjfin <= maxval(XLAT)) THEN
+ DO JI=1,SIZE(XLAT,1)
+ ivarjfin=MAX(MIN(COUNT(XLAT(JI,:)<zjfin),SIZE(XLAT,2)),ijfin)
+ ijfin=ivarjfin
+ END DO
+ ENDIF
+ ELSE
+ ivarjdeb=max(ijdeb,NREADJL)
+ ivarjfin=min(ijfin,NREADJH)
+ ivarjdeb=min(ivarjdeb,ivarjfin)
+ ENDIF
+ IF(ivarideb==-2 .OR. ivarifin==-2 .OR. ivarjdeb==-2 .OR. ivarjfin==-2) THEN
+ print *,'****zoom provided is not included in the FM-file grid'
+ print *,'LON (zoom: ',zideb,zifin,') (file: ',minval(XLON),maxval(XLON)
+ print *,'LAT (zoom: ',zjdeb,zjfin,') (file: ',minval(XLAT),maxval(XLAT)
+ GOTO 99
+ ENDIF
+ IF (IND_VERT/=0) THEN
+ ivarzmin=1 ; ivarzmax=inbvertz
+ ELSE
+ ivarzmin=MAX(1,NREADKL) ; ivarzmax=MIN(SIZE(XVAR,3),NREADKH)
+ inbvertz=ivarzmax-ivarzmin+1
+ ENDIF
+ IF (ikdeb == 0 .AND. ikfin == 0 ) THEN
+ ivarkdeb=NREADKL ; ivarkfin=NREADKH
+ IF (ivarkdeb/=ivarkfin) THEN ! domK/=1
+ ivarkdeb=MAX(1+JPVEXT,NREADKL)
+ ivarkfin=min(ivarzmax,SIZE(XVAR,3)-JPVEXT)
+ !IF (ivarkfin <= 0) THEN
+ ! dimK =1
+ !ivarkdeb=1 ; ivarKfin=SIZE(XVAR,3)
+ !ENDIF
+ ENDIF
+ ELSEIF (ikdeb == -1 .AND. ikfin ==-1 ) THEN
+ ivarkdeb=ivarzmin
+ ivarkfin=ivarzmax
+ ELSE
+ ivarkdeb=max(ikdeb,ivarzmin)
+ ivarkfin=min(ikfin,ivarzmax)
+ ivarkdeb=min(ivarkdeb,ivarkfin)
+ ENDIF
+ IF (INDX/=0) THEN
+ ivarkdeb=IK ; ivarkfin=IK
+ END IF
+ ENDIF
+
+ IF (itinf == 0 .AND. itsup == 0 ) THEN
+ ivartinf=1 ; ivartsup=SIZE(XVAR,4)
+ ELSE
+ ivartinf=max(itinf,1)
+ ivartsup=min(itsup,SIZE(XVAR,4))
+ ivartinf=min(ivartinf,ivartsup)
+ ENDIF
+ IF (itrajinf == 0 .AND. itrajsup == 0 ) THEN
+ ivartrajinf=1 ; ivartrajsup=SIZE(XVAR,5)
+ ELSE
+ ivartrajinf=max(itrajinf,1)
+ ivartrajsup=min(itrajsup,SIZE(XVAR,5))
+ ivartrajinf=min(ivartrajinf,ivartrajsup)
+ ENDIF
+ IF (iprocinf == 0 .AND. iprocsup == 0 ) THEN
+ ivarprocinf=1 ; ivarprocsup=SIZE(XVAR,6)
+ ELSE
+ ivarprocinf=max(iprocinf,1)
+ ivarprocsup=min(iprocsup,SIZE(XVAR,6))
+ ivarprocinf=min(ivarprocinf,ivarprocsup)
+ ENDIF
+ if (ilocverbia > 0 ) then
+ PRINT*,' Zoom limits initialized with:'
+ PRINT*,'ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin',&
+ ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin
+ PRINT*,'ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocfin',&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup
+ endif
+ !
+ !* 3.3 Ecriture du tableau XVAR (module MODD_ALLOC_FORDIACHRO)
+ !
+ print *,' Write with the format ', YTYPEOUT(1:4)
+ SELECT CASE(YTYPEOUT(1:4))
+ !
+ CASE('DIAC')
+ CALL WRITEVAR(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ CGROUP,YFILEIN,YFLAGWRITE,'2 ',ilocverbia,iret)
+ if (ilocverbia > 0 ) then
+ print*,'WRITEVAR return= ',iret
+ end if
+ !
+ CASE('FREE')
+ if (ilocverbia >= 0 ) then
+ print*,' format ',YTYPEOUT
+ print*,' domaine for writting : ideb,ifin,jdeb,jfin,kdeb,kfin', &
+ ',itinf,itsup,itrajinf,itrajsup,iprocinf,iprocsup= ', &
+ ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup
+ endif
+ ! Retour aux unites initiales si necessaire
+ CALL FROM_COMPUTING_UNITS(CGROUP,CUNITE(1))
+ !
+ YFILEOUTFREE=ADJUSTL(ADJUSTR(YFILEIN)//'.'//ADJUSTL(ADJUSTR(CGROUP)))
+ OPEN (UNIT=7,STATUS='NEW',FORM='FORMATTED',FILE=YFILEOUTFREE)
+ ! a. Ecriture de l entete
+ !temps courant
+ IAN=XDATIME(13,1)
+ IMOIS=XDATIME(14,1)
+ IJOUR=XDATIME(15,1)
+ IHEURE=XDATIME(16,1)/3600
+ IMINUTE=(XDATIME(16,1)-(IHEURE*3600))/60
+ ISECONDE=ISECONDE-(IHEURE*3600)-(IMINUTE*60)
+ WRITE(7,*) ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ IAN,IMOIS,IJOUR,IHEURE,IMINUTE ,&
+ 'format ligne1= 12 Indices (.deb .fin) du ',&
+ 'tableau an mois jour hUTC minute'
+ ! b. ecriture des données au fmt choisi par l utilisateur
+ WRITE(7,FMT=YFMTFREE) &
+ XVAR(ivarideb:ivarifin,ivarjdeb:ivarjfin,ivarkdeb:ivarkfin,&
+ ivartinf:ivartsup,ivartrajinf:ivartrajsup,ivarprocinf:ivarprocsup)
+ PRINT*,'File ',TRIM(YFILEOUTFREE),' available'
+ CLOSE(7)
+ !
+ CASE('LLHV','llhv')
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YTYPEOUT,&
+ ilocverbia,iret)
+ if (ilocverbia > 0 ) then
+ print*,' WRITELLHV return= ',iret
+ end if
+ !
+ CASE('KCDL','ZCDL','PCDL','LLZV','LLPV','llpv','llzv')
+ ! replace field at mass points
+ If (ALLOCATED(ZWORK3D))DEALLOCATE(ZWORK3D)
+ If (ALLOCATED(ZWORK3D2))DEALLOCATE(ZWORK3D2)
+ ALLOCATE(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ALLOCATE(ZWORK3D2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ DO J6=ivarprocinf,ivarprocsup
+ IGRID=NGRIDIA(J6)
+ IF(SIZE(XVAR,3)/=1 .OR. IGRID/=4) THEN
+ ! pas d interpolation verticale pour champ 2D
+ DO J5=ivartrajinf,ivartrajsup
+ DO J4=ivartinf,ivartsup
+ ZWORK3D(:,:,:)=XVAR(:,:,:,J4,J5,J6)
+ print *,' mass point grid for J4,J5,J6=',J4,J5,J6
+ CALL CHANGE_A_GRID(ZWORK3D,IGRID,ZWORK3D2)
+ ! IGRID=1 en sortie de change_a_grid
+ XVAR(:,:,:,J4,J5,J6)=ZWORK3D2(:,:,:)
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+ DEALLOCATE(ZWORK3D,ZWORK3D2)
+ !
+ ! a. reinit avant ecriture de la grille verticale correspondant a la
+ !grille de masse sur laquelle le champ a ete interpole
+ IFLAGzcst=0
+ IF (IND_VERT/=0) THEN
+ IF ( CGROUP == 'ALT' ) THEN
+ ! ecriture de la liste des niveaux verticaux
+ IFLAGzcst=1
+ DEALLOCATE(XVAR)
+ allocate(XVAR(1,1,inbvertz,1,1,1))
+ XVAR(1,1,:,1,1,1)=zlistevert
+ ivarideb=1 ; ivarifin=1
+ ivarjdeb=1 ; ivarjfin=1
+ ivarkdeb=1 ; ivarkfin=inbvertz
+ CTITRE(1)='vertical_levels'
+ CUNITE(1)='user choice'
+ IF ( YTYPEOUT(IND_VERT:IND_VERT) == 'z' .OR. YTYPEOUT(IND_VERT:IND_VERT) == 'Z' ) THEN
+ CUNITE(1)='meters'
+ ENDIF
+ IF ( YTYPEOUT(IND_VERT:IND_VERT) == 'p' .OR. YTYPEOUT(IND_VERT:IND_VERT) == 'P' ) THEN
+ CUNITE(1)='hPa'
+ ENDIF
+ ENDIF
+ ! b. interpolation eventuelle selon la verticale
+ IF( SIZE(XVAR,3)>1 .AND. SIZE(XVAR,2)>1 .AND. SIZE(XVAR,1)>1 ) THEN
+ ! ALT, LON, LAT et chps 2D ne passent pas cette partie
+ if (ilocverbia >= 0 ) then
+ print*,' Interpolations on ',inbvertz,' ', &
+ YTYPEOUT(IND_VERT:IND_VERT),'-levels'
+ endif
+ if (ilocverbia >= 1 .AND. IND_VERT/=0) THEN
+ print*,'levels= ',zlistevert
+ endif
+ ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+ size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+ ZVARSAVE=XVAR
+ ALLOCATE(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ALLOCATE(ZVARZCST(SIZE(XVAR,1),SIZE(XVAR,2),inbvertz))
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(SIZE(ZVARSAVE,1),SIZE(ZVARSAVE,2),SIZE(ZVARZCST,3),&
+ size(ZVARSAVE,4),size(ZVARSAVE,5),size(ZVARSAVE,6)))
+ DO J6=ivarprocinf,ivarprocsup
+ IGRID=NGRIDIA(J6)
+ ! init du tableau des altitudes XZZ pour la grille= IGRID
+ CALL COMPCOORD_FORDIACHRO(IGRID)
+ DO J5=ivartrajinf,ivartrajsup
+ DO J4=ivartinf,ivartsup
+ ZWORK3D(:,:,:)=ZVARSAVE(:,:,:,J4,J5,J6)
+ ikdebzint=2
+ IF (INDEX(YTYPEOUT(1:4),'Z')/=0 .OR. INDEX(YTYPEOUT(1:4),'z')/=0) THEN
+ CALL ZINTER(ZWORK3D,XZZ,ZVARZCST,zlistevert,ikdebzint,XSPVAL)
+ ELSE IF (INDEX(YTYPEOUT(1:4),'P')/=0 .OR. INDEX(YTYPEOUT(1:4),'p')/=0) THEN
+ CALL PINTER(ZWORK3D,IGRID,XSPVAL,zlistevert,ZVARZCST,ZPABS)
+ ELSE IF (INDEX(YTYPEOUT(1:4),'H')/=0 .OR. INDEX(YTYPEOUT(1:4),'h')/=0) THEN
+ ZVARZCST(:,:,:)=ZWORK3D(:,:,:)
+ ELSE
+ print*,'** ERROR in vertical interpolations with ',YTYPEOUT
+ ENDIF
+ XVAR(:,:,:,J4,J5,J6)=ZVARZCST
+ END DO
+ END DO
+ END DO
+ DEALLOCATE(ZVARSAVE,ZVARZCST,ZWORK3D)
+ zmini=MINVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ zmaxi=MAXVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ print * ,' After vertical interpolation, min,max of the variable ',TRIM(CGROUP),'=', zmini,zmaxi
+ ivarkdeb=1
+ ivarkfin=inbvertz
+ IF (ilocverbia >= 5 ) then
+ print*,'ivarkdeb,ivarkfin= ',ivarkdeb,ivarkfin
+ ENDIF
+ ENDIF
+ ENDIF
+ ! c. interpolation eventuelle sur l horizontale
+ IF ( YOUTGRID(1:4) == 'LALO' ) THEN
+ if (ilocverbia >= 0 ) then
+ print *,'Translate to a regular lat lon grid '
+ end if
+ IF ( .NOT. ALLOCATED (ZNEWX) ) THEN
+ IF ( IFLAGzcst == 1 ) THEN
+ print*,'** no processing with ALT at the first group'
+ GOTO 99
+ ELSE
+ ! c.1. creation de la grille réguliere en lat lon
+ if (ilocverbia >= 2 ) then
+ print *,'grid creation, size of XLON: ',SIZE(XLON,1),SIZE(XLON,2)
+ end if
+ ! calcul des coord X Y des points de la grille lat-lon reguliere
+ ! determine le maximum d espacement en lat et lon sur le zoom
+ ZDELTALON=max(XLON(ivarideb+1,ivarjdeb)-XLON(ivarideb,ivarjdeb)&
+ ,XLON(ivarifin,ivarjfin)-XLON(ivarifin-1,ivarjfin))
+ ZDELTALAT=max(XLAT(ivarideb,ivarjdeb+1)-XLAT(ivarideb,ivarjdeb)&
+ ,XLAT(ivarifin,ivarjfin)-XLAT(ivarifin,ivarjfin-1))
+ if (ZDELTALON == 0 .OR. ZDELTALAT == 0 ) THEN
+ print *,' error during ZDELTALON,ZDELTALAT computation=', ZDELTALON,ZDELTALAT
+ print *,'XLON(ivarideb+1,ivarjdeb)-XLON(ivarideb,ivarjdeb)'&
+ ,'XLON(ivarifin,ivarjfin)-XLON(ivarifin-1,ivarjfin)'&
+ ,'XLAT(ivarideb,ivarjdeb+1)-XLAT(ivarideb,ivarjdeb)'&
+ ,'XLAT(ivarifin,ivarjfin)-XLAT(ivarifin,ivarjfin-1)'
+ print *,XLON(ivarideb+1,ivarjdeb)-XLON(ivarideb,ivarjdeb)&
+ ,XLON(ivarifin,ivarjfin)-XLON(ivarifin-1,ivarjfin)&
+ ,XLAT(ivarideb,ivarjdeb+1)-XLAT(ivarideb,ivarjdeb)&
+ ,XLAT(ivarifin,ivarjfin)-XLAT(ivarifin,ivarjfin-1)
+ print *, 'ivarideb+1,ivarjdeb,ivarifin-1,ivarjfin',ivarideb+1,ivarjdeb,ivarifin-1,ivarjfin
+ print *,'Verify the fields LAT LON of the FM file'
+ ALLOCATE(ZX(SIZE(XLAT,1),SIZE(XLAT,2)),ZY(SIZE(XLAT,1),SIZE(XLAT,2)))
+ ZX(1:SIZE(XZZ,1),1) = XXX(1:SIZE(XZZ,1),IGRID)
+ ZX(:,2:SIZE(XZZ,2)) = SPREAD(ZX(:,1),2,SIZE(XZZ,2)-1)
+ ZY(1,1:SIZE(XZZ,2)) = XXY(1:SIZE(XZZ,2),IGRID)
+ ZY(2:SIZE(XZZ,1),:) = SPREAD(ZY(1,:),1,SIZE(XZZ,1)-1)
+ !CALL SM_LATLON(XXHAT,XYHAT,XLATORI,XLONORI, &
+ !! XXHAT,XYHAT supprimes en masdev4_7
+ CALL SM_LATLON(XLATORI,XLONORI,ZX,ZY,XLAT,XLON)
+ ZDELTALON=max(XLON(ivarideb+1,ivarjdeb)-XLON(ivarideb,ivarjdeb)&
+ ,XLON(ivarifin,ivarjfin)-XLON(ivarifin-1,ivarjfin))
+ ZDELTALAT=max(XLAT(ivarideb,ivarjdeb+1)-XLAT(ivarideb,ivarjdeb)&
+ ,XLAT(ivarifin,ivarjfin)-XLAT(ivarifin,ivarjfin-1))
+ print *,' After Model Grid computation: ZDELTALON,ZDELTALAT=', ZDELTALON,ZDELTALAT
+ endif
+ IDIM1=(maxval(XLON)-minval(XLON))/ZDELTALON
+ IDIM2=(maxval(XLAT)-minval(XLAT))/ZDELTALAT
+ ALLOCATE (ZNEWLAT(IDIM1,IDIM2),ZNEWLON(IDIM1,IDIM2) )
+ if (ilocverbia >= 1 ) then
+ print*,' ZDELTALON,ZDELTALAT= ',ZDELTALON,ZDELTALAT
+ endif
+ if (ilocverbia >= 2 ) then
+ print*,' IDIM1,IDIM2= ',IDIM1,IDIM2
+ endif
+ ! depart de la nouvelle grille : coin Sud Ouest
+ DO JI=1,IDIM1
+ ZNEWLON(JI,:)=minval(XLON) + (JI-1) *ZDELTALON
+ ENDDO
+ DO JJ=1,IDIM2
+ ZNEWLAT(:,JJ)=minval(XLAT) + (JJ-1) *ZDELTALAT
+ ENDDO
+ if (ilocverbia >= 4 ) then
+ print*, 'new lat lon grid=',ZNEWLAT(1,:)
+ print*, ZNEWLON(:,1)
+ endif
+ ALLOCATE (ZNEWX(IDIM1,IDIM2))
+ ALLOCATE (ZNEWY(IDIM1,IDIM2))
+ CALL SM_XYHAT(XLATORI,XLONORI,ZNEWLAT,ZNEWLON,ZNEWX,ZNEWY)
+ if (ilocverbia >= 4 ) then
+ ! XXX= XXHAT et XXY=XYHAT pour les 7 grilles
+ print*,' After SM_XYHAT old limits X: ', &
+ XXX(1,IGRID),XXX(SIZE(XVAR,1),IGRID)
+ print*,' new limits X: ', &
+ ZNEWX(1,1),ZNEWX(IDIM1,IDIM2)
+ print*,' old limits Y: ', &
+ XXY(1,IGRID),XXY(SIZE(XVAR,2),IGRID)
+ print*,' new limits Y: ', &
+ ZNEWY(1,1),ZNEWY(IDIM1,IDIM2)
+ endif
+ if (ilocverbia >= 5 ) then
+ DO JI= 1,SIZE(XVAR,1)
+ print*,'XXHAT ZNEWX',XXX(JI,IGRID),ZNEWX(JI,1),ZNEWX(JI,IDIM2)
+ ENDDO
+ DO JJ= 1,SIZE(XVAR,2)
+ print*,'XYHAT ZNEWY',XXY(JJ,IGRID),ZNEWY(1,JJ),ZNEWX(IDIM1,JJ)
+ ENDDO
+ endif
+ ! calcul de la section de tableau correspondant au zoom
+ I1=(maxval(XLON(ivarideb:ivarifin,ivarjdeb:ivarjfin)) &
+ -minval(XLON(ivarideb:ivarifin,ivarjdeb:ivarjfin)) )/ZDELTALON
+ I2=(maxval(XLAT(ivarideb:ivarifin,ivarjdeb:ivarjfin)) &
+ -minval(XLAT(ivarideb:ivarifin,ivarjdeb:ivarjfin)) )/ZDELTALAT
+ IZOOMIDEB=MAX(MIN(COUNT(ZNEWLON(:,1)<XLON(ivarideb,ivarjdeb)),IDIM1),1)
+ IZOOMJDEB=MAX(MIN(COUNT(ZNEWLAT(1,:)<XLAT(ivarideb,ivarjdeb)),IDIM2),1)
+ !IZOOMIFIN=MIN(IZOOMIDEB+I1,IDIM1)
+ !IZOOMJFIN=MIN(IZOOMJDEB+I2,IDIM2)
+ IZOOMIFIN=MAX(MIN(COUNT(ZNEWLON(:,1)<XLON(ivarifin,ivarjfin)),IDIM1),1)
+ IZOOMJFIN=MAX(MIN(COUNT(ZNEWLAT(1,:)<XLAT(ivarifin,ivarjfin)),IDIM2),1)
+ if (ilocverbia >= 2 ) then
+ print*,' ZOOM along i in the LON-LAT grid: ', &
+ IZOOMIDEB,IZOOMIFIN,I1
+ print*,' j : ', &
+ IZOOMJDEB,IZOOMJFIN,I2
+ endif
+ ENDIF
+ ENDIF ! fin grille ZNEWX deja allouee
+ ! c.2. interpolation sur la nouvelle grille
+ IF( IFLAGzcst/= 1 .AND. (NREADIH-NREADIL)>0 .AND. (NREADJH-NREADJL)>0 )THEN
+ ! interpolation vers la nouvelle grille réguliere en lat lon
+ !sauf la grille verticale definie en niveaux Z et champs 1D
+ if (ilocverbia >= 1 ) then
+ print*,' interpolation for the variable ',trim(CGROUP)
+ end if
+ allocate(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ allocate(ZWORK3D2(IDIM1,IDIM2,SIZE(XVAR,3)))
+ ! stockage des champs interpoles dans la nouvelle grille
+ if (allocated (ZVARSAVE)) DEALLOCATE(ZVARSAVE)
+ allocate(ZVARSAVE(IDIM1,IDIM2,SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),SIZE(XVAR,6)))
+ ! boucle sur les dimensions 4 5 6
+ DO J6=ivarprocinf,ivarprocsup
+ DO J5=ivartrajinf,ivartrajsup
+ DO J4=ivartinf,ivartsup
+ ZWORK3D(:,:,:)=XVAR(:,:,:,J4,J5,J6)
+ if (ilocverbia >= 2 ) then
+ print *,'before HOR_INTERP_4PTS J4,J5,J6=', J4,J5,J6
+ end if
+ CALL HOR_INTERP_4PTS(XXX(:,IGRID),XXY(:,IGRID),ZWORK3D, &
+ ZNEWX,ZNEWY,ZWORK3D2)
+ ZVARSAVE(:,:,:,J4,J5,J6)=ZWORK3D2(:,:,:)
+ END DO
+ END DO
+ END DO
+ ! resultat dans XVAR passe en module
+ DEALLOCATE (XVAR)
+ ALLOCATE(XVAR(IDIM1,IDIM2,SIZE(ZVARSAVE,3),&
+ SIZE(ZVARSAVE,4),SIZE(ZVARSAVE,5),SIZE(ZVARSAVE,6)))
+ XVAR=XSPVAL
+ XVAR(:,:,:,ivartinf:ivartsup,ivartrajinf:ivartrajsup,ivarprocinf:ivarprocsup)= &
+ ZVARSAVE(:,:,:,ivartinf:ivartsup,ivartrajinf:ivartrajsup,ivarprocinf:ivarprocsup)
+ DEALLOCATE (ZVARSAVE)
+ zmini=MINVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ zmaxi=MAXVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ print * ,' After horizontal interpolation, min,max of the variable ',TRIM(CGROUP),'=', zmini,zmaxi
+ if (ilocverbia >= 2 ) then
+ print*, 'After HOR_INTERP_4PTS all the dim 4,5,6'
+ endif
+ IF (allocated(ZWORK3D)) DEALLOCATE(ZWORK3D)
+ IF (allocated(ZWORK3D2)) DEALLOCATE(ZWORK3D2)
+ ENDIF
+ ENDIF
+ ! d. ecriture des donnees au format cdl ou llz/llp
+ IF ( YOUTGRID(1:4) == 'LALO' ) THEN
+ IF ( IFLAGzcst /= 1 ) THEN
+ ivarideb=IZOOMIDEB
+ ivarifin=IZOOMIFIN
+ ivarjdeb=IZOOMJDEB
+ ivarjfin=IZOOMJFIN
+ ENDIF
+ SELECT CASE(YTYPEOUT(1:4))
+ CASE('LLZV','llzv','LLPV','llpv')
+ IF (allocated(ZWORK3D)) DEALLOCATE(ZWORK3D)
+ ALLOCATE(ZWORK3D(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ IF (SIZE(XVAR,3)==inbvertz) THEN
+ ZWORK3D(1,1,:)=zlistevert
+ ELSE
+ ZWORK3D(1,1,:)=XSPVAL
+ ENDIF
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YTYPEOUT,&
+ ilocverbia,iret,PLON=ZNEWLON,PLAT=ZNEWLAT,&
+ PALT=ZWORK3D)
+ if (ilocverbia > 0 ) then
+ print*,'WRITELLHV LALO return= ', YTYPEOUT,'= ',iret
+ end if
+ DEALLOCATE(ZWORK3D)
+ !
+ CASE('KCDL','ZCDL','PCDL')
+ YGROUP=ADJUSTL(ADJUSTR(CGROUP)//ADJUSTL(YK))
+ CALL WRITECDL(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ YGROUP,YFILEIN,YFLAGWRITE,YOUTGRID,YSUFFIX_file, &
+ ilocverbia,iret,PGRIDX=ZNEWLON(:,1),PGRIDY=ZNEWLAT(1,:))
+ IF (ilocverbia >= 1 ) print *,' counter of added fields=',inetadd
+ if ( inetadd == 0) then
+ print *,' The program adds the ALT 3Dfield to the netcdf file'
+ YGROUP_OLD=CGROUP(1:13)
+ CGROUP='ALT'
+ inetadd=inetadd+1
+ YFLAGWRITE='OLD'
+ ino_init_zoom=1
+ GO TO 77
+ endif
+ if ( inetadd == 1 .AND. YOUTGRID(1:4) == 'CONF' )THEN
+ print *,' The program adds the LAT 3Dfield to the netcdf file'
+ CGROUP='LAT'
+ inetadd=inetadd+1
+ ino_init_zoom=1
+ GO TO 77
+ endif
+ if ( inetadd == 2 .AND. YOUTGRID(1:4) == 'CONF' )THEN
+ print *,' The program adds the LON 3Dfield to the netcdf file'
+ CGROUP='LON'
+ inetadd=inetadd+1
+ ino_init_zoom=1
+ GO TO 77
+ endif
+
+ END SELECT
+ ELSE ! pas d interpolation horizontale
+ SELECT CASE(YTYPEOUT(1:4))
+ CASE('LLZV','llzv','LLPV','llpv')
+ IF (SIZE(XVAR,3)==inbvertz) THEN ! champ 3D
+ IF (allocated(ZWORK3D)) DEALLOCATE(ZWORK3D)
+ ALLOCATE(ZWORK3D(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ ZWORK3D(1,1,:)=zlistevert
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YTYPEOUT,&
+ ilocverbia,iret,&
+ PALT=ZWORK3D)
+ ELSE ! champ 2D
+ IF((YTYPEOUT(3:3)=='z').OR.(YTYPEOUT(3:3)=='p')) YTYPEOUT3='h'
+ IF((YTYPEOUT(3:3)=='Z').OR.(YTYPEOUT(3:3)=='P')) YTYPEOUT3='H'
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ CGROUP,YFILEIN,YFLAGWRITE, &
+ YTYPEOUT(1:2)//YTYPEOUT3//YTYPEOUT(4:4), &
+ ilocverbia,iret)
+ ENDIF
+ if (ilocverbia > 0 ) then
+ print*,' WRITELLHV for ', YTYPEOUT,', return value= ',iret
+ end if
+ IF (allocated(ZWORK3D)) DEALLOCATE(ZWORK3D)
+ !
+ CASE('KCDL','ZCDL','PCDL')
+ YGROUP=ADJUSTL(ADJUSTR(CGROUP)//ADJUSTL(YK))
+ CALL WRITECDL(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ YGROUP,YFILEIN,YFLAGWRITE,YOUTGRID,YSUFFIX_file, &
+ ilocverbia,iret,PGRIDX=XXX(:,IGRID),PGRIDY=XXY(:,IGRID))
+ IF (ilocverbia >= 1 ) print *,' counter of added fields=',inetadd
+ if ( inetadd == 0) then
+ if (ivarkdeb == ivarkfin .AND. ivarkdeb == 1 ) THEN
+ print *, 'No ALT field for only one vertical position'
+ else
+ print *,' The program adds the ALT 3Dfield to the netcdf file'
+ YGROUP_OLD=CGROUP(1:13)
+ CGROUP='ALT'
+ inetadd=inetadd+1
+ YFLAGWRITE='OLD'
+ ino_init_zoom=1
+ GO TO 77
+ endif
+ endif
+ if ( inetadd == 1 .AND. YOUTGRID(1:4) == 'CONF' )THEN
+ if (ivarideb /= ivarifin .AND. ivarjdeb /= ivarjfin ) THEN
+
+ print *,' The program adds the LAT 3Dfield to the netcdf file'
+ CGROUP='LAT'
+ inetadd=inetadd+1
+ ino_init_zoom=1
+ GO TO 77
+ else
+ print *, ' No LAT field for only one location', ivarideb,ivarifin,ivarjdeb,ivarjfin
+ endif
+ endif
+ if ( inetadd == 2 .AND. YOUTGRID(1:4) == 'CONF' )THEN
+ if (ivarideb /= ivarifin .AND. ivarjdeb /= ivarjfin ) THEN
+ print *,' The program adds the LON 3Dfield to the netcdf file'
+ CGROUP='LON'
+ inetadd=inetadd+1
+ ino_init_zoom=1
+ GO TO 77
+ else
+ print *, ' No LON field for only one location', ivarideb,ivarifin,ivarjdeb,ivarjfin
+ endif
+ endif
+ END SELECT
+ ENDIF
+ ! retour a XZZ pour NGRID a 4 (cf readvar)
+ CALL COMPCOORD_FORDIACHRO(4)
+ END SELECT
+ ! indiquera aux routines d ecriture que le fichier courant est deja ouvert
+ YFLAGWRITE='OLD'
+ !
+ ELSE ! iret /=0
+ print *, ' READVAR return= ',iret
+ ENDIF
+END DO ! boucle champ a traiter
+!
+!
+!---------------------------------------------------------------------------
+!
+!* 4. CLOSURE OF OUTPUT FILE
+! ----------------------
+!
+!pour clore le traitement meme si la liste des champs est non terminee par END
+88 CONTINUE
+!
+IF (ALLOCATED(ZNEWX)) DEALLOCATE(ZNEWX,ZNEWY)
+IF (ALLOCATED(ZNEWLAT)) DEALLOCATE(ZNEWLAT,ZNEWLON)
+IF (ALLOCATED(ZWORK2D)) DEALLOCATE(ZWORK2D,ZWORK2D2)
+!
+PRINT*, 'END -> Close the output file'
+YFLAGWRITE='CLO'
+SELECT CASE(YTYPEOUT(1:4))
+ CASE('DIAC')
+ CALL WRITEVAR(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ CGROUP,YFILEIN,YFLAGWRITE,'2 ',ilocverbia,iret)
+ CASE('LLHV','llhv','LLZV','llzv','LLPV','llpv')
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YTYPEOUT,ilocverbia,iret)
+ CASE('KCDL','ZCDL','PCDL')
+ CALL WRITECDL(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YOUTGRID,YSUFFIX_file, &
+ ilocverbia,iret,PGRIDX=XXX(:,IGRID),PGRIDY=XXY(:,IGRID))
+ CASE DEFAULT
+ PRINT*, 'Closure of output type ',YTYPEOUT ,' not coded'
+END SELECT
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. END
+! ---
+!
+99 CONTINUE
+PRINT*, 'Delete the links if necessary'
+YDUMMYFILE=''
+CALL CREATLINK(' ',YDUMMYFILE,'CLEAN',ILOCVERBIA)
+PRINT*, 'The file ',TRIM(YLUDIR),' stores all the input directives '
+PRINT*, ' you must give a new name to use it again'
+CLOSE(ILUDIR)
+!
+!-------------------------------------------------------------------------------
+!
+END PROGRAM EXTRACTDIA
+!
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/dd.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/dd.f90
new file mode 100644
index 0000000000000000000000000000000000000000..02f624477969c7f36f4bd965bf29a2464f00f3bf
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/dd.f90
@@ -0,0 +1,110 @@
+! ############################################################
+ MODULE MODI_DD
+! ############################################################
+!
+INTERFACE
+ SUBROUTINE DD(pu,pv,pddvent,kiskip,KGRID,PLON)
+!
+REAL , intent(in), dimension (:,:,:) :: pu,pv ! composantes u et v
+INTEGER , intent(in) :: kiskip ! nb points a sauter
+INTEGER , intent(in) :: KGRID ! grille des champs u et v
+REAL , intent(inout), dimension (:,:,:) :: pddvent ! direction vent
+REAL ,intent(in), dimension (:,:),OPTIONAL :: PLON ! tableau des lon
+!
+END SUBROUTINE DD
+END INTERFACE
+END MODULE MODI_DD
+!
+!------------------------------------------------------------------------------
+!
+! ################
+ SUBROUTINE DD(pu,pv,pddvent,kiskip,KGRID,PLON)
+! ################
+!
+!!**** *DD* -
+!!
+!!
+!! PURPOSE
+!! -------
+! calcul de la direction du vent par rapport au Nord geographique
+! 0=360 pour un vent venant du Nord
+!
+!!** METHOD
+! Appel de computedir niveau vertical par niveau vertical
+!!
+!! AUTHORS
+!! -------
+!! N. Asencio * CNRM*
+!!
+!! Copyright 2003, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! call to change_a_grid 15/04/2004 (I.Mallet)
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODI_CHANGE_A_GRID
+USE MODI_COMPUTEDIR
+IMPLICIT NONE
+!
+!* 0.1 Arguments d'appel
+!
+REAL , intent(in), dimension (:,:,:) :: pu,pv ! composantes u et v
+INTEGER , intent(in) :: kiskip ! nb points a sauter
+INTEGER , intent(in) :: KGRID ! grille des champs u et v
+REAL, intent(inout), dimension (:,:,:) :: pddvent ! direction vent
+REAL ,intent(in), dimension (:,:) , OPTIONAL :: PLON ! tableau des lon
+!
+!* 0.2 variables locales
+!
+INTEGER :: JK,IGRID
+REAL, allocatable , dimension (:,:) :: zwork2d
+REAL, allocatable , dimension (:,:,:) :: zwork3du
+!
+!-------------------------------------------------------------------------------
+!
+print *,'entree dd ',kiskip,SIZE(pu,3),SIZE(pu,1),SIZE(pu,2)
+!
+ALLOCATE(zwork3du(size(pu,1),size(pu,2),size(pu,3)))
+IF (KGRID /= 1 ) THEN
+ ! les 2 composantes sont dans les grilles U(2) et V(3) Mesonh
+ IGRID=2
+ CALL CHANGE_A_GRID(PU,IGRID,zwork3du)
+ IGRID=3
+ CALL CHANGE_A_GRID(PV,IGRID,pddvent)
+ELSE
+ zwork3du(:,:,:)=PU(:,:,:)
+ pddvent (:,:,:)=PV(:,:,:)
+ENDIF
+!
+! Tableau de travail : 2D pour computedir
+ALLOCATE(zwork2d(size(pu,1),size(pu,2)))
+!
+! Calcul niveau par niveau et stockage dans le tableau 3D
+!
+IF (PRESENT(PLON)) THEN
+ ! grille lon (passee en arg.) differente de celle de Mesonh
+ print *,' dd: grille lon utilisateur'
+ do JK=1,SIZE(pu,3)
+ zwork2d(:,:)=pddvent(:,:,JK)
+ CALL COMPUTEDIR (size(PU,1),size(PU,2),size(PV,1),size(PV,2), &
+ kiskip,zwork3du(:,:,JK),zwork2d(:,:), PLO=PLON )
+ pddvent(:,:,JK)=zwork2d(:,:)
+ end do
+ELSE
+ print *,' dd: grille lat lon mesonh'
+ ! computedir recalculera PLO en fonction de XXHAT et XYHAT
+ do JK=1,SIZE(pu,3)
+ zwork2d(:,:)=pddvent(:,:,JK)
+ CALL COMPUTEDIR (size(PU,1),size(PU,2),size(PV,1),size(PV,2), &
+ kiskip,zwork3du(:,:,JK),zwork2d(:,:) )
+ pddvent(:,:,JK)=zwork2d(:,:)
+ end do
+ENDIF
+DEALLOCATE(zwork2d,zwork3du)
+!
+END SUBROUTINE DD
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/exrwdia.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/exrwdia.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7b1d9026553d380dbce6b556dca9545f2da89e1a
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/exrwdia.f90
@@ -0,0 +1,702 @@
+ PROGRAM EXRWDIA
+! ###################
+!
+!!**** *EXRWDIA* - lecture d'enregistrements dans des fichiers diachroniques,
+! traitement,
+! ecriture (plusieurs types de format de fichier possibles)
+! DIAC= fichier diachronique utilisable via diaprog (appel à WRITEVAR)
+! LLHV= fichier ascii lon,lat,altitude,valeur (appel à WRITELLHV)
+! les sorties LLZV LLPV llzv llpv sont codées dans extractdia
+! conseil: sortir en format 'DIAC' puis utiliser extractdia
+! pour des sorties LLZV LLPV llzv llpv
+! KCDL= fichier netcdf (appel à WRITECDL)
+! les sorties ZCDL ou PCDL sont codées dans extractdia
+! conseil: sortir en format 'DIAC' puis utiliser extractdia
+! pour des sorties ZCDL ou PCDL
+! FREE= fichier ascii , l ecriture est à coder par l utilisateur
+!
+! CONTRAINTES:
+! Au maximum 50 fichiers ouverts simultanement
+! 50 = limite du module MODD_FILES_DIACHRO
+! Au max 44 fichiers simultanement ouverts par FMOPEN (c.a.d via
+! READVAR et WRITEVAR )
+!!
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+! Exemple de programme simple a adapter aux besoins
+! pour info supplementaires, voir le programme interactif extractdia.f90
+!
+! Rappel1: un fichier LFI diachronique (000 ou issu de conv2dia) contient
+! des champs stockes dans un tableau a 6 dimensions (XVAR passe
+! par module a toutes les routines de traitement)
+! le logiciel graphique diaprog interprete les dimensions ainsi:
+! XVAR( dimension1=i=grille horizontale selon x,
+! dimension2=j=grille horizontale selon y,
+! dimension3=k=grille verticale selon z,
+! dimension4=t=echeances temporelles,
+! dimension5=traj=masques des budgets ou trajectoires,
+! dimension6=p/proc=processus )
+!
+! Rappel2: les variables sont stockees sur 7 grilles differentes dans
+! les fichiers LFI ( 1=grille masse , 3=grille W...)
+! Voir le book3 de Mesonh pour traiter correctement ces differentes
+! localisations que peuvent representer 1/2deltax sur l horizontale et
+! 1/2 niveau selon la verticale
+! XVAR( i,j,k,:,:,:) pour U n est pas localise au meme lieu que
+! XVAR( i,j,k,:,:,:) pour V et XVAR( i,j,k,:,:,:) pour Theta
+!
+! Rappel3: les composantes U et V sont dans le plan de projection Mesonh
+! (cartesien ou conforme) et ne correspondent pas a Uzonal et Vmeridien.
+! Utiliser les routines DD, FF et UV_TO_ZONAL_AND_MERID pour changer de repere.
+!
+!!
+! READVAR : lit un champ et alimente un tableau XVAR + grille
+! et tous les parametres necessaires aux traitements futurs
+! transforme certaines unites pour des traitements plus corrects:
+! les dBz sont passees en Ze , les temp. de brillance en W
+! WRITEVAR, WRITECDL, WRITELLHV pour changer de format
+! les routines writevar,writecdl,writellh effectuent la
+! transformation inverse sur les unites avant ecriture
+! Voir les routines TO_COMPUTING_UNITS et FROM_COMPUTING_UNITS pour le
+! detail des variables traitees.
+!!
+!!
+!! REFERENCE
+!! ---------
+!! 'CREATION et EXPLOITATION de FICHIERS DIACHRONIQUES' J.Duron oct.2001
+!!
+!! AUTHORS
+!! -------
+!! I. Mallet et N. Asencio
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 17/03/2003
+!! Modifications 01/2005 : Nicole Asencio
+!! ajout de modules et des commentaires pour une utilisation sur
+!! des fichiers diachroniques 000
+!! 17/06/2005 : ajout de commentaires sur l utilisation de XZZ
+!! et de la routine MOYZ
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+! modules MesoNH
+USE MODD_PARAMETERS, ONLY: JPHEXT,JPVEXT,XUNDEF
+! NIMAX,NJMAX,NKMAX, NIINF, NISUP
+USE MODD_DIM1
+! grille : XXDXHAT(:,1:7) et XXX(:,1:7), XXZS(:,:,1:7)
+USE MODD_COORD
+! ref grille: XLON0,XLAT0,XBETA,XRPK
+USE MODD_GRID
+! descriptif grille: XXHAT(:) ,XLAT(:,:),XDXHAT(:),XMAP(:,:)
+! ,XZS(:,:),XZZ(:,:,:) ,XCOSSLOPE(:,:),XDIRCOSXW(:,:)
+USE MODD_GRID1
+!
+! modules DIACHRO
+USE MODN_NCAR, ONLY: XSPVAL
+USE MODD_ALLOC_FORDIACHRO, ONLY: XVAR, & ! XVAR(i,j,k,t,n,p)
+ XDATIME, & ! XDATIME(16,t)
+ CCOMMENT,& ! CCOMMENT(p)
+ CTITRE, CUNITE,&! CTITRE(p),CUNITE(p)
+ NGRIDIA,& ! NGRIDIA(p)
+ XTRAJT ! XTRAJT(t,n)
+USE MODD_RESOLVCAR, ONLY: CGROUP, NVERBIA, &
+ NNDIA, NPROCDIA, NBPROCDIA !pour appel a interp_grids
+USE MODD_COORD, ONLY: XXX,XXY,XXZS, & ! XXX(:,1:7), XXY(:,1:7), XXZS(:,:,1:7)
+ XXDXHAT,XXDYHAT ! XXDXHAT(:,1:7), XXDYHAT(:,1:7)
+USE MODD_PVT, ONLY: LPRESYT
+USE MODD_TYPE_AND_LH, ONLY: CTYPE,LICP,LJCP,LKCP
+!
+! modules tools
+USE MODI_CHANGE_A_GRID ! changement de grille dans les grilles mesonh
+USE MODI_ZINTER ! interpolation a Z=cst
+USE MODI_PINTER ! interpolation a P=cst
+USE MODI_ZMOY ! moyenne sur une couche verticale
+USE MODI_DD ! calcul dd ,ff a partir de U,V grille mesonh
+USE MODI_FF
+USE MODI_WRITELLHV ! routines
+USE MODI_WRITECDL !d
+USE MODI_WRITEVAR !ecriture
+USE MODI_FROM_COMPUTING_UNITS ! voir routine symetrique TO_COMPUTING_UNITS
+ !pour la liste des variables traitees
+USE MODI_HOR_INTERP_4PTS ! interpolation horizontale 4 points
+USE MODI_UV_TO_ZONAL_AND_MERID ! passage composantes vent Mesonh
+ !a Zonal+ Meridien
+USE MODI_LOW2UP ! conversion en Majuscules
+!
+! modules extractdia
+USE MODD_READLH ! domaine initialise par READVAR:
+ !NREADIL,NREADIH, NREADJL,NREADJH,
+ !NREADKL,NREADKH
+!
+IMPLICIT NONE
+!
+!* 0.1 Local variables
+!
+!
+INTEGER :: JI,JJ,JK,J4,J5,J6,ILECTTRAITE,NBLECTTRAITE
+INTEGER :: ilocverbia,iret,inbvertz,ikdebzint,IGRID,ISKIP
+! zoom recalculé en fonction des dimensions du champ traite
+INTEGER :: ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin
+INTEGER :: ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup
+REAL, ALLOCATABLE, DIMENSION(:,:,:) :: ZWORK3D,ZWORK3D2,ZVARZCST
+REAL, ALLOCATABLE, DIMENSION(:,:) :: ZWORK2D
+REAL, allocatable, dimension(:,:,:,:,:,:):: ZVARSAVE
+REAL :: ZMIN,ZMAX
+! **** la taille des variables caracteres contenant les noms
+! de fichiers est obligatoirement de 28 ****
+CHARACTER(LEN=28) :: YFILEIN
+! **** la longueur du nom ne doit pas depasser 13 car. si le fichier
+! contient des groupes a un seul PROCessus, ou 9 si plusieurs PROCessus ****
+CHARACTER(LEN=13) :: YCHAMP
+!
+CHARACTER(LEN=4) :: YTYPEOUT
+CHARACTER(LEN=3) :: YFLAGREADVAR ,YFLAGWRITE
+CHARACTER(LEN=3) :: YSUFFIX=''
+REAL , allocatable, dimension(:) :: zlistevert
+!
+CHARACTER(LEN=13) :: YCHAMP2
+CHARACTER(LEN=2), DIMENSION(15) :: LIST
+!-------------------------------------------------------------------------------
+!
+!* 1. INIT
+! ----
+!
+! active(1) ou desactive(0) les prints de controle dans les routines
+! READVAR et WRITEVAR
+ilocverbia=1
+! active(1) ou desactive(0) les prints de controle dans les routines diachro
+NVERBIA=0
+!
+XSPVAL=XUNDEF ! dans mesonh Xundef est utilise
+ ! dans les routines diachro XSPVAL est utilise
+!
+!
+!* 1.2 Init de parametres pour la lecture
+!
+! nom du fichier diachronique en supprimant .lfi
+YFILEIN='fichier diachronique en supprimant .lfi'
+! indique que le fichier lu doit etre ouvert dans READVAR
+!(initialisation des variables des modules documentés en debut de programme)
+! rq: si d autres fichiers traites dans ce programme, remettre 'OPE'
+!avant le 1er appel a READVAR pour chaque fichier
+YFLAGREADVAR='OPE'
+! type du format de sortie (DIAC/LLHV/FREE/KCDL)
+YTYPEOUT='DIAC'
+! ouverture du fichier et ecriture de l entete dans les routines WRITExxx
+YFLAGWRITE='NEW'
+! nom du champ a lire
+YCHAMP='THM'
+!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!Boucle lecture + traitement----------------------------------------------------
+!NBLECTTRAITE=3
+!DO ILECTTRAITE=1,NBLECTTRAITE
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. Lecture du champ YCHAMP et stockage dans XVAR
+! ----------------------
+!
+CALL READVAR(YCHAMP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+!
+!! apres cette lecture, les tableaux suivants sont disponibles:
+! a. si YFLAGREADVAR='OPE' lecture de l entete du fichier:
+! X,Y,Z-HAT(m) dans XXX,XXY,XXZ(:,1:7) ! (MODD_COORD)
+! topography altitude values(m):XXZS(:,:,1:7) ! (MODD_COORD)
+! meshsize values XXDXHAT,XXDYHAT(:,1:7) ! (MODD_COORD)
+! rq: derniere dimension (1-7) fait reference aux 7 grilles de MesoNH
+! (1: masse, 2: flux selon x, 3: flux selon y, 4: flux suivant z ,
+! 5:Vertical vorticity , 6:y-component vorticity, 7:x-component vorticity )
+! NIMAX,NJMAX,NKMAX, LCARTESIAN, LTHINSHELL,CSTORAGE_TYPE,
+! XXHAT(IIU),XYHAT(IJU),XZHAT(IKU))
+! XMAP(IIU,IJU) XLAT(IIU,IJU) XLON(IIU,IJU)
+! XDXHAT(IIU),XDYHAT(IJU)
+! XZS(IIU,IJU) , XZZ(IIU,IJU,IKU) avec XZZ=grille pour numéro de
+! grille=4 quelle que soit la grille de variable lue
+! CALL COMPCOORD_FORDIACHRO(IGRID_var) pour initialiser XZZ
+! avec la grille de la variable traitée
+! TDTMOD,TDTCUR,TDTEXP,TDTSEG,
+! NSTOP,NOUT_TIMES,NOUT_NUMB, XTSTEP,XSEGLEN,
+! b. variables relatives a l enregistrement demande:
+! XVAR(i,j,k,t,n,p)= champ
+! NGRIDIA(p)= indice de grille des p processus
+! CTYPE= CART/MASK/SPXY/SSOL/DRST/RSPL/RAPL
+! CTITRE(p)= titre des p processus UTILISE DANS XMIN_nom de diaprog
+! CUNITE(p)= unite des p processus
+! CCOMMENT(p)= commentaire des p processus
+! XDATIME(16,t)= dates relatives au champ
+! XDATIME(1,t)=TDTEXP%TDATE%YEAR; XDATIME(2,t)=TDTEXP%TDATE%MONTH
+! XDATIME(3,t)=TDTEXP%TDATE%DAY; XDATIME(4,t)=TDTEXP%TIME
+! XDATIME(5,t)=TDTSEG%TDATE%YEAR; XDATIME(6,t)=TDTSEG%TDATE%MONTH
+! XDATIME(7,t)=TDTSEG%TDATE%DAY; XDATIME(8,t)=TDTSEG%TIME
+! XDATIME(9,t)=TDTMOD%TDATE%YEAR; XDATIME(10,t)=TDTMOD%TDATE%MONTH
+! XDATIME(11,t)=TDTMOD%TDATE%DAY; XDATIME(12,t)=TDTMOD%TIME
+! XDATIME(13,t)=TDTCUR%TDATE%YEAR;XDATIME(14,t)=TDTCUR%TDATE%MONTH
+! XDATIME(15,t)=TDTCUR%TDATE%DAY; XDATIME(16,t)=TDTCUR%TIME
+! XTRAJT(t,n)= nombre de secondes depuis le debut de la simulation
+! optionnels suivant la valeur de CTYPE:
+!XTRAJX-Y-Z(k,t,n) XMASK(i,j,t,n)
+! rq: p=1 (nb de processus) si fichier pseudo-diachro sorti de conv2dia
+! rq: pour plus d infos sur la nature d un enregistrement dans un
+! fichier diachronique, voir 'CREATION et EXPLOITATION de FICHIERS
+! DIACHRONIQUES' (J. Duron, octobre 2001)
+!
+!!
+! la routine READVAR a modifie YFLAGREADVAR a 'NOP'
+!pour indiquer que le fichier courant est deja ouvert
+!(le prochain champ sera lu sans initialisation des modules relatifs a l entete)
+!
+! la routine READVAR a transforme certaines unites pour des traitements
+!plus corrects:
+! les dBz sont passees en Ze , les temp. de brillance en W
+!
+! les routines writevar,writecdl,writellh effectuent la transformation
+!inverse avant ecriture
+!
+! Definir le zoom a traiter dans les calculs:
+! valeurs par defaut:
+ ivarideb=NREADIL
+ ivarifin=NREADIH
+ ivarjdeb=NREADJL
+ ivarjfin=NREADJH
+ ivarkdeb=NREADKL
+ ivarkfin=NREADKH
+ ivartinf=1
+ ivartsup=size(XVAR,4)
+ ivartrajinf=1
+ ivartrajsup=size(XVAR,5)
+ ivarprocinf=1
+ ivarprocsup=size(XVAR,6)
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. EXEMPLES DE CALCUL activer les lignes de code en
+! !optionx en début de ligne
+! ------------------
+!
+!* 4.1 Interpolation sur la grille de masse Mesonh
+!
+! replace field at mass points
+!option1 ALLOCATE(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+!option1 ALLOCATE(ZWORK3D2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+!option1 DO J6=ivarprocinf,ivarprocsup
+!option1 IGRID=NGRIDIA(J6)
+!option1 IF(SIZE(XVAR,3)/=1 .OR. IGRID/=4) THEN
+!option1 ! pas d interpolation verticale pour champ 2D
+!option1 DO J5=ivartrajinf,ivartrajsup
+!option1 DO J4=ivartinf,ivartsup
+!option1 ZWORK3D(:,:,:)=XVAR(:,:,:,J4,J5,J6)
+!option1 CALL CHANGE_A_GRID(ZWORK3D,IGRID,ZWORK3D2)
+!option1 ! IGRID=1 en sortie de change_a_grid
+!option1 XVAR(:,:,:,J4,J5,J6)=ZWORK3D2(:,:,:)
+!option1 NGRIDIA(J6)=1
+!option1 ENDDO
+!option1 ENDDO
+!option1 ENDIF
+!option1 ENDDO
+!option1 DEALLOCATE(ZWORK3D,ZWORK3D2)
+!
+!* 4.2 Maximum du champ sur la verticale
+!
+!option2 ALLOCATE(ZWORK2D(SIZE(XVAR,1),SIZE(XVAR,2)))
+!option2 ZWORK2D=0.
+!option2 ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+!option2 size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+!option2 ZVARSAVE=XVAR
+!option2 DEALLOCATE(XVAR)
+!option2 ALLOCATE(XVAR(SIZE(ZVARSAVE,1),SIZE(ZVARSAVE,2),1, &
+!option2 size(ZVARSAVE,4),size(ZVARSAVE,5),size(ZVARSAVE,6)))
+!option2 DO J6=ivarprocinf,ivarprocsup
+!option2 DO J5=ivartrajinf,ivartrajsup
+!option2 DO J4=ivartinf,ivartsup
+!option2 DO JK=ivarkdeb,ivarkfin
+!option2 DO JJ=ivarjdeb,ivarjfin
+!option2 DO JI=ivarideb,ivarifin
+!option2 IF (ZVARSAVE(JI,JJ,JK,J4,J5,J6) .GT. ZWORK2D(JI,JJ) ) THEN
+!option2 ZWORK2D(JI,JJ)= ZVARSAVE(JI,JJ,JK,J4,J5,J6)
+!option2 ENDIF
+!option2 END DO
+!option2 END DO
+!option2 END DO
+!option2 XVAR(:,:,1,J4,J5,J6)=ZWORK2D(:,:)
+!option2 END DO
+!option2 END DO
+!option2 CTITRE(J6)='MAX'//ADJUSTL(TRIM(CTITRE(J6)))
+!option2 END DO
+!option2 DEALLOCATE(ZVARSAVE,ZWORK2D)
+!option2 YCHAMP='MAX'//ADJUSTL(TRIM(YCHAMP))
+!option2 CCOMMENT(ivarprocinf:ivarprocsup)=nouveau_comment
+!option2 CUNITE(ivarprocinf:ivarprocsup)=nouvelle_unite
+!
+!* 4.3 Interpolation sur des niveaux Z=cst ou P=cst
+!
+!option3! inbvertz=nombre de niveaux verticaux souhaite
+!option3! allocate ( zlistevert(inbvertz))
+!option3! zlistevert= tableau contenant les differentes valeurs de Z en metres
+!option3! P en hPa
+!option3! print * , ' interpolations sur ',inbvertz,' niveaux'
+!option3! print *, 'niveaux=',zlistevert
+!option3 YSUFFIX='zcl'
+!option3 IF (YSUFFIX == 'zcl' .AND. SIZE(XVAR,3) > 1 .AND. &
+!option3 SIZE(XVAR,2) > 1 .AND. SIZE(XVAR,1) > 1 ) THEN
+!option3 ! ALT ne passe pas cette partie car ses dimensions 1 et 2 =1
+!option3 if (ilocverbia >= 0 ) then
+!option3 print*,' interpolations sur Z=cst',inbvertz,' niveaux'
+!option3 endif
+!option3 if (ilocverbia >= 1 ) then
+!option3 print*,'niveaux= ',zlistevert
+!option3 endif
+!option3 ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+!option3 size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+!option3 ZVARSAVE=XVAR
+!option3 ALLOCATE(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+!option3 ALLOCATE(ZVARZCST(SIZE(XVAR,1),SIZE(XVAR,2),inbvertz))
+!option3 DEALLOCATE(XVAR)
+!option3 ALLOCATE(XVAR(SIZE(ZVARSAVE,1),SIZE(ZVARSAVE,2),SIZE(ZVARZCST,3),&
+!option3 size(ZVARSAVE,4),size(ZVARSAVE,5),size(ZVARSAVE,6)))
+!option3 DO J6=ivarprocinf,ivarprocsup
+!option3 IGRID=NGRIDIA(J6)
+!option3 ! init du tableau des altitudes XZZ pour la grille= IGRID
+!option3 CALL COMPCOORD_FORDIACHRO(IGRID)
+!option3 DO J5=ivartrajinf,ivartrajsup
+!option3 DO J4=ivartinf,ivartsup
+!option3 ZWORK3D(:,:,:)=ZVARSAVE(:,:,:,J4,J5,J6)
+!option3 ikdebzint=2
+!option3 CALL ZINTER(ZWORK3D,XZZ,ZVARZCST,zlistevert,ikdebzint,XSPVAL)
+!option3 ou bien a P=cst precede d un READVAR de ZPABS
+!option3 CALL PINTER(ZWORK3D,IGRID,XSPVAL,zlistevert,ZVARZCST,ZPABS)
+!option3 XVAR(:,:,:,J4,J5,J6)=ZVARZCST
+!option3 END DO
+!option3 END DO
+!option3 END DO
+!option3 DEALLOCATE(ZVARSAVE,ZVARZCST,ZWORK3D)
+!option3 ivarkdeb=1
+!option3 ivarkfin=inbvertz
+!option3 IF (ilocverbia >= 5 ) then
+!option3 print*,'ivarkdeb,ivarkfin= ',ivarkdeb,ivarkfin
+!option3 ENDIF
+!option3 ENDIF
+!
+!* 4.4 Moyenne verticale entre deux niveaux zmin et zmax
+! pour des variables lues sans prise en compte du volume
+! de chaque maille (*RHO les variables avant l appel si
+! nécessaire)
+!
+!option4! zmin=base
+!option4! zmax=sommet
+!option4 ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+!option4 size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+!option4 ZVARSAVE=XVAR
+!option4 ALLOCATE(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+!option4 ALLOCATE(ZWORK2D(SIZE(XVAR,1),SIZE(XVAR,2)))
+!option4 DEALLOCATE(XVAR)
+!option4 ALLOCATE(XVAR(SIZE(ZVARSAVE,1),SIZE(ZVARSAVE,2),1,&
+!option4 size(ZVARSAVE,4),size(ZVARSAVE,5),size(ZVARSAVE,6)))
+!option4 DO J6=ivarprocinf,ivarprocsup
+!option4 IGRID=NGRIDIA(J6)
+!option4 DO J5=ivartrajinf,ivartrajsup
+!option4 DO J4=ivartinf,ivartsup
+!option4 ZWORK3D(:,:,:)=ZVARSAVE(:,:,:,J4,J5,J6)
+!option4 ! JPVEXT, JPHEXT: points a exclure verticalement et horizontalement
+!option4 CALL ZMOY(ZWORK3D,IGRID,ZWORK2D,zmin,zmax,XSPVAL,JPVEXT,JPHEXT)
+!option4 XVAR(:,:,1,J4,J5,J6)=ZWORK2D(:,:)
+!option4 END DO
+!option4 END DO
+!option4 CTITRE(J6)='MEANZ'//ADJUSTL(TRIM(CTITRE(J6)))
+!option4 END DO
+!option4 DEALLOCATE(ZVARSAVE,ZWORK2D,ZWORK3D)
+!option4 YCHAMP='MEANZ'//ADJUSTL(TRIM(YCHAMP))
+!option4 !CCOMMENT(ivarprocinf:ivarprocsup)=nouveau_comment
+!option4 !CUNITE(ivarprocinf:ivarprocsup)=nouvelle_unite
+!
+! * 4.5 Calcul de la direction ou de la force du vent
+!
+!option5! lecture de la 1e composante du vent (UT ou UM ou LSUM ou UMxx ou UTxx)
+!option5!stockee dans ZVARSAVE
+!option5 ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+!option5 size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+!option5 ZVARSAVE=XVAR
+!option5 ! lecture de la 2e composante du vent (VT ou VM ou LSVM ou VMxx ou VTxx)
+!option5 !stockee dans XVAR
+!option5 ! YCHAMP='2e composante du vent'
+!option5 !CALL READVAR(YCHAMP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+!option5 !
+!option5 ALLOCATE(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+!option5 ZWORK3D=XSPVAL
+!option5 DO J6=ivarprocinf,ivarprocsup
+!option5 IGRID=NGRIDIA(J6)
+!option5 DO J5=ivartrajinf,ivartrajsup
+!option5 DO J4=ivartinf,ivartsup
+!option5 iskip=1 ! tous les points de grille
+!option5 CALL DD(ZVARSAVE(:,:,:,J4,J5,J6),XVAR(:,:,:,J4,J5,J6),ZWORK3D, &
+!option5 iskip,IGRID)
+!option5 !CALL FF(ZVARSAVE(:,:,:,J4,J5,J6),XVAR(:,:,:,J4,J5,J6),ZWORK3D, &
+!option5 ! JPVEXT,JPHEXT,IGRID)
+!option5 XVAR(:,:,:,J4,J5,J6)=ZWORK3D(:,:,:)
+!option5 END DO
+!option5 END DO
+!option5 NGRIDIA(J6)=1 ! resultat sur la grille de masse
+!option5 CUNITE(J6)='degrees' ! pour dd
+!option5 END DO
+!option5 DEALLOCATE(ZVARSAVE,ZWORK3D)
+!
+!
+! * 4.6 Compression de budgets 3D (equivalent au type
+! CART de MAINPROG=Model)
+!
+!option6 ! Sauvagerde la variable à traiter precedemment lue
+!option6 ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+!option6 size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+!option6 ZVARSAVE=XVAR
+!option6 ! récupère le champ représentant la densité
+!option6 ! RJS pour scalaires, RJX pour U, RJY pour V RJZ pour W
+!option6 CALL READVAR("RJS_0001", YFILEIN, YFLAGREADVAR,ilocverbia,iret)
+!option6 ALLOCATE(RHODJS(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+!option6 RHODJS(:,:,:)=XVAR(:,:,:,1,1,1)
+!option6 ! donc pour la partie calcul,la variable devient :
+!option6 WHERE(ZVARSAVE(:,:,:) /= XUNDEF) ZVARSAVE(:,:,:)= ZVARSAVE(:,:,:)* RHODJS(:,:,:)
+!option6
+!option6 ! exemple pour compression suivant Z
+!option6 ALLOCATE(ZWORK2D(SIZE(XVAR,1),SIZE(XVAR,2)))
+!option6 ALLOCATE(ZWORK2DRho(SIZE(XVAR,1),SIZE(XVAR,2)))
+!option6 ZWORK2D=0.
+!option6
+!option6 do J6=ivarprocinf, ivarprocsup
+!option6 do J5=ivartrajinf, ivartrajsup
+!option6 do J4=ivartinf, ivartsup
+!option6 ZWORK2D(:,:) = 0.0
+!option6 ZWORK2DRHo(:,:) = 0.0
+!option6 do JK=ivarkdeb, ivarkfin
+!option6 ZWORK2DRHo(:,:)=ZWORK2DRHo(:,:)+RHODJS(:,:,JK)
+!option6 ZWORK2D(:,:)=ZWORK2D(:,:) + ZVARSAVE(:,:,JK,J4,J5,J6))
+!option6 enddo !Loop on K
+!option6 ! stockage dans XVAR qui sera utilisé pour l ecriture
+!option6 ! pour le tracé ecriture de la variable/densité
+!option6 ! remq: pour 2 boites 1 et 2 :var*rho1+var*rho2/(rho1+rho2)
+!option6 WHERE(abs(ZWORK2DRho(:,:)).gt.0.0)
+!option6 XVAR(:,:,1,J4,J5,J6)=ZWORK2D(:,:)/ZWORK2DRHo(:,:)
+!option6 ELSEWHERE
+!option6 XVAR(:,:,1,J4,J5,J6)=XUNDEF
+!option6 ENDWHERE
+!option6 ENDDO
+!option6 ENDDO
+!option6 ENDDO
+!option6 ! nouvelles limites pour l ecriture
+!option6 ! si ce champ 2D = moyenne ou compression (trace sans relief)
+!option6 ! LJCP=.TRUE. si compresse selon j
+!option6 ! LICP=.TRUE. si compresse selon i
+!option6 ! LKCP=.TRUE. si compresse selon k
+!option6 ivarkdeb=1
+!option6 ivarkfin=1
+!option6 LKCP=.TRUE.
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. traitement perso
+! ----------------------
+! ----------------------
+! Si vous effectuez des calculs sur des variables "Rapport de melange"
+! ne pas oublier de *RHODREF si necessaire (hydrometeores, flux, ...)
+!
+! Préférer l utilisation d'un tableau de travail qui conserve les
+! dimensions de Xvar pour les dimensions 1,2 et 3 et définir ensuite
+! le zoom pour écrire un sous tableau via les variables ivar.deb et
+! ivar.fin
+!
+!
+! ..... code utilisateur .....
+!-------------------------------------------------------------------------------
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. Preparation de l ecriture
+! ----------------------
+!
+! XVAR contient le champ a ecrire (module MODD_ALLOC_FORDIACHRO):
+! vous pouvez modifier les variables suivantes si vous ne conservez pas les
+! valeurs lues par READVAR
+! YCHAMP=nouveau_nom EN MAJUSCULES
+! **** la longueur de YCHAMP ne doit pas depasser 13 car. si le fichier
+! contient des groupes à un seul PROCessus, ou 9 si plusieurs PROCessus ****
+! NGRIDIA(p)=nouvelle_grille
+! CTITRE(p)=nouveau_nom_p utilise dans les directives DIAPROG XISOLEV_
+! CCOMMENT(p)=nouveau_comment
+! CUNITE(p)=nouvelle_unite
+! XDATIME(1:16,t)= dates du fichier
+! XTRAJT(t,n)= nombre de secondes depuis le début de la simulation
+
+! VOUS DEVEZ MODIFIER LA TAILLE DE CES TABLEAUX si vous modifiez la
+! dimension 4 ou 5 ou 6 du tableau XVAR a ecrire
+!
+! fichier a creer par les routines d ecriture WRITEVAR, WRITELLHV, WRITECDL
+!(au premier appel de la routine)
+! nom du fichier de sortie= YFILEIN+suffixe (suffixe=2 par défaut) si writevar
+! +'LLHV'+suffixe si writellhv
+! +'d'+suffixe si writecdl
+! et +'h'+suffixe si writecdl
+!
+YFLAGWRITE='NEW'
+!
+YCHAMP= !nouveau_nom EN MAJUSCULES
+NGRIDIA(1:SIZE(XVAR,6))= !nouvelle_grille
+CTITRE(1:SIZE(XVAR,6))= !nouveau_nom_p pour XMIN XISOLEV diaprog
+CCOMMENT(1:SIZE(XVAR,6))= !nouveau_comment
+CUNITE(1:SIZE(XVAR,6))= !nouvelle_unite
+XDATIME(1:16,1:SIZE(XVAR,4))= ! nouvelles dates du fichier
+XTRAJT(1:SIZE(XVAR,4),1:SIZE(XVAR,5))= ! nouveaux timing des champs
+XVAR=tableau à ecrire ! passé par module aux routines write*
+!
+! Redefinir le zoom d ecriture si different du zoom de lecture
+! dans writevar, controle que ce nouveau zoom est inclus dans le zoom de lecture)
+! ivarideb=1
+! ivarifin=1
+! ivarjdeb=1
+! ivarjfin=1
+! ivarkdeb=1
+! ivarkfin=size(XVAR,3)
+! ivartinf=1
+! ivartsup=1
+! ivartrajinf=1
+! ivartrajsup=1
+! ivarprocinf=1
+! ivarprocsup=size(XVAR,6)
+!
+!-------------------------------------------------------------------------------
+!
+!* 7. ECRITURE
+! --------
+!
+SELECT CASE(YTYPEOUT(1:4))
+!
+ CASE('DIAC')
+ YSUFFIX ='2' ! fichier de sortie= fichier d entree + ysuffix
+ !
+ ! Traitement par diaprog des champs 2D de type X,Z et Y,Z:
+ ! si le champ 2D XZ correspond à la position j=jpos de la grille
+ !utiliser ivarjdeb=ivarjfin=jpos pour positionner ce champ
+ ! idem avec un champ 2D YZ et ipos
+ ! si ce champ 2D = moyenne ou compression (trace sans relief)
+ ! LJCP=.TRUE. si compresse selon j
+ ! LICP=.TRUE. si compresse selon i
+ ! LKCP=.TRUE. si compresse selon k
+ IF ( ivarprocinf /= ivarprocsup ) THEN
+ ! **** la longueur du nom ne doit pas depasser 9 caracteres si
+ ! plusieurs PROCessus car .PROCn sera ajouté ultérieurement****
+ YCHAMP(:)=YCHAMP(1:9)
+ ENDIF
+ IF ( SIZE(XVAR,6) /= SIZE(NGRIDIA,1))THEN
+ print * ,' *** erreur possible: la dimension6 de XVAR=',SIZE(XVAR,6) ,&
+ 'est differente de la dimension des tableaux NGRIDIA,CUNIT...'
+ ENDIF
+ print *,'LICP,LJCP,LKCP,YCHAMP:' , LICP,LJCP,LKCP,YCHAMP,'-'
+ print *,'YFLAGWRITE,YFILEIN,YSUFFIX',YFLAGWRITE,YFILEIN,YSUFFIX
+ CALL WRITEVAR(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ YCHAMP,YFILEIN,YFLAGWRITE,YSUFFIX,ilocverbia,iret)
+ print *, 'retour WRITEVAR=',iret
+!
+!* 7.2 Ecriture via writellhv
+! ---------------------
+!
+ CASE('LLHV')
+! si YTYPEOUT='LLHV'
+! fichier de sortie= fichier d entree + LLHV
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ YCHAMP,YFILEIN,YFLAGWRITE,YTYPEOUT,&
+ ilocverbia,iret)
+ print *, 'retour WRITELLHV=',iret
+!
+!* 7.3 Ecriture via writecdl
+! ---------------------
+!
+ CASE('KCDL')
+YSUFFIX='kcl' !fichier de sortie= fichier d entree + ysuffix
+ ! les sorties ZCDL ou PCDL sont codees dans extractdia
+ ! conseil: sortir en format 'DIAC' puis utiliser extractdia
+ ! pour des sorties ZCDL ou PCDL
+ CALL WRITECDL(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ YCHAMP,YFILEIN,YFLAGWRITE,'CONF',YSUFFIX,ilocverbia,iret,&
+ PGRIDX=XXX(:,IGRID),PGRIDY=XXY(:,IGRID) )
+ print *, 'retour WRITEDCL=',iret
+!
+!* 7.4 Ecriture format libre
+! ---------------------
+!
+ CASE('FREE')
+ ! retour aux unites initiales pour XVAR
+ CALL FROM_COMPUTING_UNITS(YCHAMP,CUNITE(1))
+ ! coder ici son write Fortran
+ print *, 'retour WRITE FREE a coder ='
+END SELECT
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. boucle possible
+! ..... reprise possible des etapes 2 a 8
+ ! pour changer de fichier en lecture : YFLAGREADVAR='OPE'
+ ! YFILEIN=' deuxieme fichier'
+ ! pour garder le meme fichier en lecture : YFLAGREADVAR='NOP'
+ ! YCHAMP='autre variable'
+YFLAGREADVAR='NOP'
+ ! pour changer de fichier en ecriture : YFLAGWRITE='NEW'
+ ! YSUFFIX='nouveau suffixe'
+ ! pour garder le meme fichier en ecriture : YFLAGWRITE='OLD'
+YFLAGWRITE='OLD'
+!
+ ! Pour liberer les unites et ne pas dépasser la limite de 44 fichiers
+ ! ouverts simultanement, executer ces 2 lignes des qu un fichier
+ ! n est plus utilise
+!YFLAGREADVAR='CLO'
+!CALL READVAR('',YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+!
+!END DO ! fin boucle lecture+traitement
+!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!
+!* 9. Fermeture fichiers : obligatoire
+! ------------------
+!
+ ! Au max 44 fichiers simultanement ouverts par FMOPEN (c.a.d via
+ ! READVAR et WRITEVAR )
+PRINT*, 'Fermeture du fichier d entree'
+YFLAGREADVAR='CLO'
+CALL READVAR('',YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+!
+PRINT*, 'Fermeture du fichier de sortie'
+YFLAGWRITE='CLO'
+SELECT CASE(YTYPEOUT(1:4))
+ CASE('DIAC')
+ CALL WRITEVAR(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ YCHAMP,YFILEIN,YFLAGWRITE,YSUFFIX,ilocverbia,iret)
+ CASE('LLHV')
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ YCHAMP,YFILEIN,YFLAGWRITE,YTYPEOUT,&
+ ilocverbia,iret)
+ CASE('KCDL')
+ CALL WRITECDL(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ YCHAMP,YFILEIN,YFLAGWRITE,'CONF',YSUFFIX,ilocverbia,iret, &
+ PGRIDX=XXX(:,IGRID),PGRIDY=XXY(:,IGRID) )
+ ! Remarque: le script "tonetcdf" est lance par writecdl pour obtenir
+ !le fichier au format "netcdf" et non au format intermediaire "cdl"
+ ! Verifiez que votre PATH donne acces a cette commande
+END SELECT
+!
+!-------------------------------------------------------------------------------
+END PROGRAM EXRWDIA
+!
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/extractdia.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/extractdia.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8f443df6907f3e4e322ca525dd8f64b38e5658a0
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/extractdia.f90
@@ -0,0 +1,1762 @@
+ PROGRAM EXTRACTDIA
+! ###################
+!
+!!**** *EXTRACTDIA* - lecture d'enregistrements dans fichier diachronique,
+! traitement,
+! ecriture (11 types de format de fichier possibles)
+!!
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+! Lecture en entree:
+! d'une liste de fichiers diachroniques
+! du format de sortie
+! d'une liste de champs a traiter pour chaque fichier diachronique
+! d'un zoom selon toutes les directions inclu dans le champ a traiter
+! ( seul le zoom selon i,j,k est possible pour le format DIAC)
+!
+! Ecriture en sortie:
+! d'un fichier au format fonction de TYPEOUT c.a.d
+! DIAC= type diachro (un seul fichier contenant toutes
+! les variables selectionnées)
+! LLHV= lon lat alt val (un seul fichier contenant toutes
+! les variables selectionnées)
+! llhv= lat lon alt val (un seul fichier contenant toutes
+! les variables selectionnées)
+! ll ou LL zv lon lat niveau Z val
+!
+! ll ou LL pv lon lat niveau P val
+!
+!----------------------
+! AJOUT NOVEMBRE 2009:
+!----------------------
+! IJHV= i j alt val (un seul fichier contenant toutes
+! les variables selectionnées)
+! jihv= j i alt val (un seul fichier contenant toutes
+! les variables selectionnées)
+! IJ ou ji zv lon lat niveau Z val
+!
+! IJ ou ji pv lon lat niveau P val
+!----------------------
+! FREE= format libre a choisir par l utilisateur (un fichier par variable)
+! KCDL ou ZCDL ou PCDL= format CDL (à convertir en netcdf via "tonetcdf")
+! (un seul fichier contenant toutes
+! les variables selectionnées)
+! KCDL si les niveaux verticaux sont les niveaux du modele
+! ZCDL si les niveaux verticaux sont des niveaux Z=constante donnes au programme
+! PCDL si les niveaux verticaux sont des niveaux P=constante donnes au programme
+!
+! pour les formats *CDL,*Z*,*P*, 2 types de grille horizontale sont possibles:
+! 'CONF' grille reguliere sur le plan de projection (conforme ou cartesien)
+! 'LALO' grille reguliere en lat-lon
+! dans ce cas les composantes du vent sont transformees
+! en composantes zonales et méridiennes.
+! sauf pour IJPV, IJZV, jipv, jizv : CONF obligatoire
+!!
+!! EXTERNAL
+!! --------
+!! FROM_COMPUTING_UNITS: retour aux unites initiales avant ecriture
+!! = passage inverse a celui realise par
+!! TO_COMPUTING_UNITS
+!! appele par writevar,writecdl,writellhv
+!! et par extractdia avant l ecriture au format FREE
+!! REFERENCE
+!! ---------
+!!
+!! AUTHORS
+!! -------
+!! I. Mallet , N. Asencio, J. Stein
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 17/03/2003
+! call to dd and ff routines
+! call to writeLLHV if LLHV
+! clean writevar to delete choice LLHV inside this routine
+! add PCDL,LLZV,llzv,LLPV,llpv cases
+! allow a zoom 0,0,jdeb,jfin or ideb,ifin,0,0 or 0,0,0,0 05/2005
+! add ALT 3Dfield if KCDL, add the LAT and LON 3Dfields if CONF and *CDL
+! 04/11/2009 (G. Tanguy) : add case IJHV,IJZV, IJPV , JIHV, JIZV, JIPV
+! 29/03/2011 (G. TANGUY) : add case ZGRB PGRB
+! 11/07/2014 (G. TANGUY) : correction pour les donnees LES de type SSOl
+! (vlev et field ne correspondaient pas suite à
+! mauvais zoom)
+! 16/12/2014 (G.DELAUTIER) : ajout cas LLAV llav : altitude au dessus du
+! sol
+! 18/02/2015 (G.DELAUTIER) : ajout cas AGRB : altitude au dessus du
+! sol
+! Avril 2015 (G.DELAUTIER) : ajout CFIXRESOL pour car GRIB +correction
+! pour FF10MAX
+! -----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+! modules MesoNH
+USE MODD_CONF, ONLY: NVERB,LCARTESIAN
+USE MODD_PARAMETERS, ONLY: JPHEXT,JPVEXT,XUNDEF,NUNDEF
+USE MODD_DIM1, ONLY: NIMAX,NJMAX,NKMAX
+USE MODD_GRID, ONLY: XLATORI,XLONORI
+USE MODD_GRID1, ONLY: XZS,XZZ,XLAT,XLON,XXHAT,XYHAT
+USE MODE_GRIDPROJ ! subroutines SM_XYHAT et SM_LATLON
+USE MODI_UV_TO_ZONAL_AND_MERID
+USE MODI_HOR_INTERP_4PTS
+USE MODI_ZINTER
+USE MODI_PINTER
+! modules DIACHRO
+USE MODD_FILES_DIACHRO
+USE MODN_NCAR, ONLY: XSPVAL
+USE MODD_ALLOC_FORDIACHRO, ONLY: XVAR, & ! XVAR(i,j,k,t,n,p)
+ XTRAJZ, & ! XTRAJZ(k,t,n)
+ XDATIME, & ! XDATIME(16,t)
+ CTITRE, CUNITE,&! CTITRE(p),CUNITE(p)
+ NGRIDIA, & ! NGRIDIA(p)
+ NGRID
+USE MODD_COORD, ONLY: XXX,XXY,XXZS, & ! XXX(:,1:7), XXY(:,1:7), XXZS(:,:,1:7)
+ XXDXHAT,XXDYHAT ! XXDXHAT(:,1:7), XXDYHAT(:,1:7)
+USE MODD_RESOLVCAR, ONLY: CGROUP, NVERBIA, &
+ NNDIA, NPROCDIA, NBPROCDIA !pour appel a interp_grids
+USE MODD_TYPE_AND_LH, ONLY: NIL,NIH,NJL,NJH,NKL,NKH,CTYPE,LICP,LJCP
+! modules tools
+USE MODI_CHANGE_A_GRID
+USE MODI_LOW2UP
+USE MODI_CREATLINK
+USE MODI_DD
+USE MODI_FF
+USE MODI_WRITEDIR
+USE MODI_WRITELLHV
+USE MODI_WRITEGRIB
+USE MODI_WRITECDL
+USE MODI_WRITEVAR
+USE MODI_FROM_COMPUTING_UNITS
+USE MODD_READLH
+USE MODI_INI2LALO
+USE MODI_INT2LALO
+!
+IMPLICIT NONE
+!
+!* 0.1 Local variables declarations
+!
+INTEGER :: I
+INTEGER :: ILUDIR,IRESP
+INTEGER :: JLOOP,JI,JJ,JK,J5,J6,J4,JA,JGR,ii
+! zoom lu pour les 6 dimensions possibles
+INTEGER :: iideb,iifin,ijdeb,ijfin,ikdeb,ikfin
+REAL :: zideb,zifin,zjdeb,zjfin
+INTEGER, dimension(2) :: iloc
+INTEGER :: itinf,itsup,itrajinf,itrajsup,iprocinf,iprocsup
+! zoom recalcule en fonction des dimensions du champ traite
+INTEGER :: ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin
+INTEGER :: ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup
+INTEGER :: ivarzmin,ivarzmax
+INTEGER :: inbvertz,IND_VERT,IND_LL,IND_IJ
+REAL , allocatable, dimension(:,:,:):: ZWORK3D,ZWORK3D2,zffvent,zdirvent
+REAL , allocatable, dimension(:,:) :: zwork2d,zwork2d2
+REAL , allocatable, dimension(:,:) :: ZLAT,ZLON
+REAL , allocatable, dimension(:,:) :: ZDIFFLON,ZDIFFLAT
+! pour traiter les champs budget deja zoomes
+REAL , allocatable, dimension(:,:,:,:,:,:):: ZVARSAVE
+! pour l interpolation verticale a P=cst : pinter
+REAL , allocatable, dimension(:,:,:) :: ZPABS
+! pour les interpolations verticales a P ou Z=cst
+REAL , allocatable, dimension(:,:,:) :: ZVARZCST
+REAL , allocatable, dimension(:) :: zlistevert
+INTEGER :: ikdebzint ! premier niveau a traiter
+! pour l interpolation sur grille reguliere lat lon
+REAL , allocatable, dimension(:,:) :: ZNEWLAT,ZNEWLON,ZNEWX,ZNEWY
+REAL :: ZDELTALAT,ZDELTALON
+REAL :: zmini,zmaxi
+INTEGER :: inetadd ! compteur de champs supp dans le fichier Netcdf
+INTEGER :: IFLAGzcst,IGRID
+INTEGER :: IDIM1,IDIM2,I1,I2,IZOOMIDEB,IZOOMIFIN,IZOOMJDEB,IZOOMJFIN
+INTEGER :: IAN,IMOIS,IJOUR,IHEURE,IMINUTE,ISECONDE
+!
+INTEGER :: ilocverbia,iret,iret2,iskip,ISAVENGRIDIA,iarg,INDX,IK
+CHARACTER(LEN=3) :: YK
+! flag pour initialiser/ne pas initialiser le zoom d
+! d ecriture :
+! ne pas initialiser quand ajout par le programme
+! des champs ALT LAT LON qui doivent conserver le
+! zoom de l utilisateur
+INTEGER :: ino_init_zoom
+! **** la taille des variables caracteres contenant les noms
+! de fichiers est obligatoirement de 28 ****
+CHARACTER(LEN=28) :: YFILEIN,YFILEOUT
+! **** la longueur du nom ne doit pas depasser 13 car. si le fichier
+! contient des groupes a un seul PROCessus, ou 9 si plusieurs PROCessus ****
+CHARACTER(LEN=13) :: YGROUP,YGROUP_OLD
+CHARACTER(LEN=20) :: YGROUP_SAVE
+CHARACTER(LEN=4) :: YTYPEOUT
+CHARACTER(LEN=1) :: YTYPEOUT3
+CHARACTER(LEN=3) :: YSUFFIX_file
+CHARACTER(LEN=250):: YFMTFREE ! format ecriture des champs si YTYPEOUT='FREE'
+CHARACTER(LEN=45) :: YFILEOUTFREE ! nom du fichier de sortie si YTYPEOUT='FREE'
+CHARACTER(LEN=5) :: YFLAGREADVAR ,YFLAGWRITE
+CHARACTER(LEN=4) :: YOUTGRID ! grille en sortie:
+ !CONF pour rester dans le plan conforme,
+ ! (le logiciel graphique devra réaliser la projection)
+ !LALO pour passer à lat,lon réguliers
+CHARACTER(LEN=28) :: YDUMMYFILE
+CHARACTER(LEN=11) :: YLUDIR ! Name of the dir file
+REAL , DIMENSION(:,:) ,ALLOCATABLE :: ZX,ZY
+! GRIB
+INTEGER :: IND_GRB
+INTEGER :: ICODCOD ! Parameter grib code
+INTEGER :: ICODLEV ! grib code for the Type of Level
+INTEGER :: ICODOLL ! bottom level if layer
+INTEGER :: ICODOLH ! level or top of level if layer
+CHARACTER(LEN=256):: YINPLINE ! input agregation line read from Namelist
+LOGICAL :: LVAR2D
+INTEGER :: ILEVEL2D ! en option : altitude du champ 2D à coder dans le fichier GRIB
+LOGICAL :: LLEVEL2D
+REAL,DIMENSION(4) :: ZLATLON
+INTEGER,DIMENSION(4) :: ILATLON
+INTEGER :: INX,INY
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: ZALT
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: zlistevert3D
+INTEGER :: IZLIST
+CHARACTER(LEN=1) :: CFIXRESOL
+REAL :: ZDX_GRB,ZDY_GRB,ZCONTROL
+!-------------------------------------------------------------------------------
+!
+!* 1. INIT
+! ----
+!
+!
+inetadd=0 !compteur de champs supp dans le fichier Netcdf
+!
+!Prints : 0=mini 1=debug mode in extractdia, readvar and writevar , writecdl, writellhv
+! 3=debug mode in routines diachro'
+! nverbia= controle des prints dans les routines diachro
+ilocverbia=0
+!
+! dans mesonh Xundef est utilise =999.
+! dans les routines diachro XSPVAL est utilisé
+XSPVAL=XUNDEF
+!
+! ouverture d un fichier dir ou vont s ecrire les entrees clavier
+YLUDIR='dirextract'
+CALL FMATTR(YLUDIR,YLUDIR,ILUDIR,IRESP)
+OPEN(UNIT=ILUDIR,FILE=YLUDIR,FORM='FORMATTED')
+!
+! Possibilite de definir un zoom d ecriture
+! definition locale du zoom pour extractdia et writevar, writecdl, writellhv
+iideb=0
+iifin=0
+ijdeb=0
+ijfin=0
+ikdeb=0
+ikfin=0
+itinf=0
+itsup=0
+itrajinf=0
+itrajsup=0
+iprocinf=0
+iprocsup=0
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. INPUT FILE AND FORMAT
+! ---------------------
+!
+!* 2.1 name of file and output format
+! ------------------------------
+!
+PRINT*, '- Name of the diachro file (without .lfi) ?'
+READ(5,'(A28)') YFILEIN
+CALL WRITEDIR(ILUDIR,YFILEIN)
+!
+PRINT*, '- type of the output file ?'
+PRINT*, '(DIAC/llhv/llzv/llpv/llav/LLHV/LLZV/LLPV/LLAV/IJHV/IJZV/IJPV/jihv/jizv/jipv/FREE/KCDL/ZCDL/PCDL/ZGRB/PGRB/AGRB)'
+READ(5,'(A4)')YTYPEOUT
+CALL WRITEDIR(ILUDIR,YTYPEOUT)
+PRINT*,'the file ',TRIM(YFILEIN),' will be converted in type ',YTYPEOUT
+!
+PRINT*, '- Prints : 0=mini 1=debug mode in extractdia'
+PRINT*, ' 3=debug mode in routines diachro'
+PRINT*, '?'
+READ(5,*)ilocverbia
+CALL WRITEDIR(ILUDIR,ilocverbia)
+PRINT*, ' output prints= ',ilocverbia
+if ( ilocverbia > 2) nverbia=ilocverbia ! verbosity of diachro routines
+NVERB=ilocverbia ! verbosity of mesonh routines
+!
+!* 2.2 other parameters
+! ----------------
+!
+SELECT CASE (YTYPEOUT)
+ CASE('LLHV','llhv','DIAC','FREE','KCDL','ZCDL','PCDL','llzv','LLZV',&
+ &'llpv','LLPV','IJHV','IJZV','IJPV','jihv','jizv','jipv','ZGRB','PGRB','AGRB',&
+ &'llav','LLAV') ! lecture des choix de l utilisateur
+ IF ( YTYPEOUT == 'FREE' ) THEN
+ PRINT*, '- format of writing for fields ? '
+ PRINT*, ' (fortran syntaxe of FMT in WRITE)'
+ PRINT*,'exemple: (10F9.3) or (8F0.3)'
+ PRINT*, '?'
+ READ(5,'(A)') YFMTFREE
+ CALL WRITEDIR(ILUDIR,YFMTFREE)
+ PRINT*, ' format=', TRIM(YFMTFREE)
+ ENDIF
+ ! lecture du zoom
+ IND_VERT= INDEX(YTYPEOUT(1:4),'Z') + INDEX(YTYPEOUT(1:4),'P') + &
+ INDEX(YTYPEOUT(1:4),'z') + INDEX(YTYPEOUT(1:4),'p') + &
+ INDEX(YTYPEOUT(1:4),'a') + INDEX(YTYPEOUT(1:4),'A')
+ IND_LL= INDEX(YTYPEOUT(1:2),'L') + INDEX(YTYPEOUT(1:2),'l')
+ IND_IJ= INDEX(YTYPEOUT(1:2),'IJ') + INDEX(YTYPEOUT(1:2),'ji')
+ IND_GRB=INDEX(YTYPEOUT(1:4),'GRB')
+print*,YTYPEOUT,IND_IJ
+ IF (IND_LL==0 .AND. IND_GRB==0) THEN
+ IF (IND_VERT/=0) THEN
+ ! cas 'ZCDL','PCDL','jizv','jipv','IJZV','IJPV'
+ PRINT*, '- zoom on the 2 first dimensions: '
+ PRINT*, ' ideb,ifin,jdeb,jfin'
+ PRINT*, '0,0,0,0 for the whole physical domain'
+ PRINT*, '-1,-1,-1,-1 for the whole domain'
+ PRINT*, '?'
+ READ(5,*) iideb,iifin,ijdeb,ijfin
+ CALL WRITEDIR(ILUDIR,iideb)
+ CALL WRITEDIR(ILUDIR,iifin)
+ CALL WRITEDIR(ILUDIR,ijdeb)
+ CALL WRITEDIR(ILUDIR,ijfin)
+ ELSE
+ ! cas 'DIAC','FREE','KCDL','IJHV','jihv'
+ PRINT*, '- zoom on the 3 first dimensions: '
+ PRINT*, ' ideb,ifin,jdeb,jfin,kdeb,kfin'
+ PRINT*, '0,0,0,0,0,0 for the whole physical domain'
+ PRINT*, '-1,-1,-1,-1,-1,-1 for the whole domain'
+ PRINT*, '?'
+ READ(5,*) iideb,iifin,ijdeb,ijfin,ikdeb,ikfin
+ CALL WRITEDIR(ILUDIR,iideb)
+ CALL WRITEDIR(ILUDIR,iifin)
+ CALL WRITEDIR(ILUDIR,ijdeb)
+ CALL WRITEDIR(ILUDIR,ijfin)
+ CALL WRITEDIR(ILUDIR,ikdeb)
+ CALL WRITEDIR(ILUDIR,ikfin)
+ END IF
+ ELSE
+ ! cas 'llzv','LLZV','llpv','LLPV','llhv','LLHV','llav' 'LLAV'
+ ! 'ZGRB','PGRB','AGRB'
+ PRINT*, '- zoom on the 2 first directions: '
+ PRINT*, ' lonmin,lonmax,latmin,latmax'
+ PRINT*, '0.,0.,0.,0. for the whole physical domain'
+ PRINT*, '-1.,-1.,-1.,-1. for the whole domain'
+ PRINT*, '?'
+ READ(5,*) zideb,zifin,zjdeb,zjfin
+ CALL WRITEDIR(ILUDIR,zideb)
+ CALL WRITEDIR(ILUDIR,zifin)
+ CALL WRITEDIR(ILUDIR,zjdeb)
+ CALL WRITEDIR(ILUDIR,zjfin)
+ if(zideb==0. .AND. zifin==0.) then
+ iideb=0 ; iifin=0
+ else if(zideb==-1. .AND. zifin==-1.) then
+ iideb=-1 ; iifin=-1
+ else
+ iideb=-2 ; iifin=-2
+ endif
+ if(zjdeb==0. .AND. zjfin==0.) then
+ ijdeb=0 ; ijfin=0
+ else if(zjdeb==-1. .AND. zjfin==-1.) then
+ ijdeb=-1 ; ijfin=-1
+ else
+ ijdeb=-2 ; ijfin=-2
+ endif
+ IF (IND_GRB/=0) THEN
+ PRINT*,'Do you want to fix resolution in x and y ? (y/n)'
+ PRINT*,'(only available with LALO)'
+ READ(5,*) CFIXRESOL
+ CALL WRITEDIR(ILUDIR,CFIXRESOL)
+ IF (CFIXRESOL=='y') THEN
+ PRINT*,'Enter x resolution (in millidegrees)'
+ READ(5,*) ZDX_GRB
+ PRINT*,'Enter y resolution (in millidegrees)'
+ READ(5,*) ZDY_GRB
+ CALL WRITEDIR(ILUDIR,ZDX_GRB)
+ CALL WRITEDIR(ILUDIR,ZDY_GRB)
+ ENDIF
+
+ ENDIF
+ IF (IND_VERT==0) THEN
+ ! cas 'llhv','LLHV'
+ PRINT*, '- zoom on the 3rd dimension: '
+ PRINT*, ' kdeb,kfin'
+ PRINT*, '0,0 for the whole physical domain'
+ PRINT*, '-1,-1 for the whole domain'
+ PRINT*, '?'
+ READ(5,*) ikdeb,ikfin
+ CALL WRITEDIR(ILUDIR,ikdeb)
+ CALL WRITEDIR(ILUDIR,ikfin)
+ END IF
+ END IF
+ PRINT*, '- zoom on the 3 last dimensions : '
+ PRINT*, ' itinf,itsup,itrajinf,itrajsup,iprocinf,iprocsup'
+ PRINT*, '0,0,0,0,0,0 for the whole last dimensions'
+ PRINT*, '?'
+ READ(5,*) itinf,itsup,itrajinf,itrajsup,iprocinf,iprocsup
+ CALL WRITEDIR(ILUDIR,itinf)
+ CALL WRITEDIR(ILUDIR,itsup)
+ CALL WRITEDIR(ILUDIR,itrajinf)
+ CALL WRITEDIR(ILUDIR,itrajsup)
+ CALL WRITEDIR(ILUDIR,iprocinf)
+ CALL WRITEDIR(ILUDIR,iprocsup)
+ IF ((iideb==-2) .AND. (ijdeb==-2)) THEN
+ PRINT'(A6,4(E10.4,X),2(I4,X),2(I5,X),4(I4,X))', ' zoom= ',zideb,zifin,zjdeb,zjfin,ikdeb,ikfin&
+ ,itinf,itsup,itrajinf,itrajsup,iprocinf,iprocsup
+ ELSE
+ PRINT'(A6,6(I4,X),2(I5,X),4(I4,X))', ' zoom= ',iideb,iifin,ijdeb,ijfin,ikdeb,ikfin&
+ ,itinf,itsup,itrajinf,itrajsup,iprocinf,iprocsup
+ END IF
+ IF (IND_VERT/=0) THEN
+ PRINT*, '- Number of vertical levels for ',YTYPEOUT(IND_VERT:IND_VERT),' interpolation ?'
+ READ(5,*) inbvertz
+ CALL WRITEDIR(ILUDIR,inbvertz)
+ PRINT*, '- Ordered list of these levels (in meters or in hPa): exemple 500 1500 ?'
+ allocate (zlistevert(inbvertz))
+ READ(5,*) zlistevert
+ DO JI=1,inbvertz
+ CALL WRITEDIR(ILUDIR,zlistevert(JI))
+ END DO
+ PRINT*, ' interpolation for the following ',YTYPEOUT(IND_VERT:IND_VERT),' levels='
+ PRINT*, zlistevert
+ ENDIF
+ YOUTGRID='CONF'
+ IF (YTYPEOUT/='DIAC' .AND. YTYPEOUT/='llhv' .AND. YTYPEOUT/='LLHV' .AND.&
+ & IND_IJ==0) THEN
+ PRINT *,'- Fields in regular LAt/LOn grid'
+ PRINT *,' or in regular grid on CONFormal plan (native MesoNH grid) ?'
+ PRINT *,'LALO/CONF ?'
+ READ(5,*) YOUTGRID
+ CALL WRITEDIR(ILUDIR,YOUTGRID)
+ PRINT*, ' Output grid= ', YOUTGRID
+ PRINT*, ''
+ YSUFFIX_file=YTYPEOUT(1:2)//YTYPEOUT(4:4)
+ IF ( YTYPEOUT(2:4) == 'CDL') THEN
+ PRINT*, '!!!!!!!! Warning !!!!!!!!'
+ PRINT*, 'For the CDL type, the dimensions are initialised'
+ PRINT*, ' with those of the first field:'
+ PRINT*, 'the values of the 6 dimensions must be the maximum that'
+ PRINT*, ' will be treated '
+ PRINT*, '!!!!!!!! Warning !!!!!!!!'
+ PRINT*, 'For the CDL type, the coordinates must be the same'
+ PRINT*, ' for all fields'
+ PRINT*, '(stored in the output file with LAT/LON/VLEV groups)'
+ PRINT*, '!!!!!!!!'
+ ENDIF
+ ELSE IF (IND_IJ/=0) THEN ! dans le cas des points de grille on prend les
+ ! coordonnees conformes
+ YOUTGRID='CONF'
+ ENDIF
+ CASE DEFAULT
+ PRINT*, 'Incorrect value for the output type:',YTYPEOUT
+ PRINT*, 'the following ones are currently available :'
+ PRINT*, 'DIAC,LLHV,llhv,FREE,KCDL,ZCDL,PCDL,llzv,LLZV,llpv,LLPV,llav,LLAV'
+ PRINT*, 'IJHV,IJZV,IJPV,jihv,jizv,jipv,ZGRB,PGRB,AGRB'
+ STOP
+END SELECT
+!
+!* 2.3 init for input file and output file
+! -----------------------------------
+! in READVAR, input file must be opened before reading
+YFLAGREADVAR='OPE'
+! in WRITE routine, output file is new
+YFLAGWRITE='NEW'
+!
+!* 2.4 lecture de la pression pour interpolation
+! -----------------------------------------
+IF (INDEX(YTYPEOUT(1:4),'p')/=0 .OR. INDEX(YTYPEOUT(1:4),'P')/=0 )THEN
+ CALL READVAR('PABST',YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print *, '- PABST not found, name of the pressure variable ? '
+ read *,YGROUP
+ CALL WRITEDIR(ILUDIR,YGROUP)
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print *,' interpolation at P=cst not possible because PABST and ',TRIM(YGROUP),' are not available'
+ STOP
+ ENDIF
+ ENDIF
+ ! stockage de ZPABS utilise par pinter
+ ALLOCATE ( ZPABS(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ZPABS(:,:,:)=XVAR(:,:,:,1,1,1)
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. LOOP ON GROUPS IN THE FILE
+! --------------------------
+!
+DO JGR=1,10000
+ !
+ !* 3.0 preparation pour la lecture du champ suivant
+ !
+ ino_init_zoom=0
+ IF (IND_GRB==0) THEN
+ PRINT*,'- Name of the group in upper case (13 characters max.)'
+ PRINT*,' (ex: THT or DD or FF or DD10 or FF10 or LAT or LON or VLEV)'
+ PRINT*,'(GROUP for the list of groups, END to stop)?'
+ READ(5,'(A13)',END=88) CGROUP
+ CALL WRITEDIR(ILUDIR,CGROUP)
+ CGROUP=ADJUSTL(CGROUP)
+ CALL LOW2UP(CGROUP)
+ ELSE ! CASE ZGRB or PGRB
+ LLEVEL2D=.FALSE.
+ LVAR2D=.FALSE.
+ PRINT*,'- Name of the group in upper case (13 characters max.)'
+ PRINT*,' MesoNH field name, grib parameter indicator'
+ PRINT*,' (ex: UT 131, VT 132, GROUP for the list of groups, END to stop)'
+ PRINT*,' optional : you can add FOR 2D FIELDS ONLY the altitude (in meters)'
+ PRINT*,' of the field after the grib parameter indicator exple : UT10 131 10'
+ READ(5,'(A)') YINPLINE
+ YINPLINE= TRIM(ADJUSTL(YINPLINE))
+ IF (LEN_TRIM(YINPLINE) == 0) CYCLE ! skip blank line
+ CALL WRITEDIR(ILUDIR,YINPLINE)
+ CALL TAB2SPACE(YINPLINE)
+ ! extract field name
+ INDX= INDEX(YINPLINE,' ')
+ CGROUP= YINPLINE(1:INDX-1)
+ IF (CGROUP=='END') GO TO 88
+ !
+ IF (CGROUP /='GROUP') THEN
+ ICODLEV=NUNDEF
+ ICODOLH=NUNDEF
+ ICODOLL=NUNDEF
+ YINPLINE= ADJUSTL(YINPLINE(INDX:))
+ INDX= INDEX(YINPLINE,' ')
+ IF (INDX == 1 ) THEN
+ PRINT*, ' Parameter indicator is missing. ',CGROUP,' not treated.'
+ CYCLE
+ END IF
+ READ(YINPLINE(1:INDX-1),*) ICODCOD
+ IF (NVERB>=5) print*, ' Parameter indicator: ',ICODCOD
+ YINPLINE= ADJUSTL(YINPLINE(INDX:))
+ INDX= INDEX(YINPLINE,' ')
+ IF (INDX /= 1 ) THEN
+ READ(YINPLINE(1:INDX-1),*) ILEVEL2D
+ PRINT*, 'Level found : ',ILEVEL2D
+ PRINT*, 'it will be only used if the field ',CGROUP,' is 2D'
+ LLEVEL2D=.TRUE.
+ END IF
+
+ ENDIF
+ ENDIF
+ IF (CGROUP=='END') GO TO 88
+ ! point de reprise pour forcer l ecriture des champs VLEV,LAT,LON
+ ! dans les fichiers netcdf
+77 CONTINUE
+ YGROUP_SAVE=CGROUP(1:13)
+ YK=''
+ INDX=INDEX(CGROUP,'_K_')
+ IF (INDX/=0) THEN
+ CGROUP=YGROUP_SAVE(1:INDX-1)
+ YK(1:3)=YGROUP_SAVE(INDX+3:INDX+5)
+ READ(YK,'(I3)') IK
+ END IF
+ IF (CGROUP(1:5)/='GROUP') &
+ PRINT*,'you asked for the following record: ',TRIM(CGROUP)
+ !
+ !* 3.1 Lecture et initialisation du tableau XVAR
+ ! passé en module MODD_ALLOC_FORDIACHRO
+ !
+ !
+ ! 3.1.1 Cas particulier pour le vent
+ !
+ IF ( CGROUP(1:2) == 'UT' .OR. &
+ CGROUP(1:2) == 'VT' .OR. &
+ CGROUP(1:2) == 'DD' .OR. &
+ CGROUP(1:2) == 'FF' .AND. CGROUP(1:7) /= 'FF10MAX' ) THEN
+ !
+ IF ( (CGROUP(1:2)=='UT'.OR.CGROUP(1:2)=='VT') .AND. &
+ YOUTGRID(1:4) /= 'LALO' ) THEN
+ ! Lecture du champ U ou V sans calcul
+ ! les composantes du vent restent dans le plan conforme
+ CALL READVAR(CGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ ELSE
+ ! Lecture des 2 composantes du vent : commence par UM...
+ !(stockees dans les tableaux ZWORK3D et ZWORK3D2)
+ ! max 13 car.
+ YGROUP='UT'//CGROUP(3:13)
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print *,TRIM(CGROUP),': ',TRIM(YGROUP),' not available'
+ ! echec , on tente UM....
+ YGROUP='UM'//CGROUP(3:13)
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret2)
+ IF ( iret2 /= 0 ) then
+ print *,'** no processing for ',TRIM(CGROUP), &
+ ' because UT and ',TRIM(YGROUP),' are not available'
+ CYCLE
+ ENDIF
+ ENDIF
+ ! allocation du tableau de stockage de la 1e composante du vent
+ ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+ size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+ ZVARSAVE=XVAR
+ !
+ ! deuxieme composante VT....
+ YGROUP='VT'//CGROUP(3:13)
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print *,TRIM(CGROUP),': ',TRIM(YGROUP),' not available'
+ ! echec , on tente VM....
+ YGROUP='VM'//CGROUP(3:13)
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret2)
+ IF ( iret2 /= 0 ) then
+ print *,'** no processing for ',TRIM(CGROUP), &
+ ' because VT and ',TRIM(YGROUP),' are not available'
+ CYCLE
+ ENDIF
+ iret=iret2
+ ENDIF
+ !
+ ! Calcul de ff
+ IF (CGROUP(1:2) == 'FF' ) THEN
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VENTFF'
+ ELSE IF (LEN(TRIM(CGROUP)) ==3) THEN
+ YGROUP='VENT'//CGROUP(3:3)//'FF'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='VENT'//CGROUP(3:4)//'FF'
+ ELSE
+ ! 13 car max
+ YGROUP='VENTFF'//CGROUP(3:9)
+ ENDIF
+ ! allocation du tableau de calcul
+ IF (allocated(ZWORK3D)) DEALLOCATE(ZWORK3D)
+ ALLOCATE(ZWORK3D(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ ZWORK3D(:,:,:)=XSPVAL
+ DO J6=1,SIZE(XVAR,6)
+ IGRID=NGRIDIA(J6)
+ DO J5=1,SIZE(XVAR,5)
+ DO J4=1,SIZE(XVAR,4)
+ CALL FF (ZVARSAVE(:,:,:,J4,J5,J6),XVAR(:,:,:,J4,J5,J6),ZWORK3D, &
+ JPVEXT,JPHEXT,IGRID)
+ XVAR(:,:,:,J4,J5,J6)=ZWORK3D(:,:,:)
+ END DO
+ END DO
+ ! initialisation des variables necessaires a l ecriture
+ CGROUP=YGROUP
+ CTITRE(J6)=YGROUP
+ NGRIDIA(J6)=1
+ END DO
+ DEALLOCATE(ZWORK3D)
+ ! Calcul de dd par rapport au Nord geographique
+ ELSE IF (CGROUP(1:2) == 'DD') THEN
+ IF (CTYPE=='CART' .OR. CTYPE=='MASK' .OR. CTYPE=='SPXY') THEN
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VENTDD'
+ ELSE IF (LEN(TRIM(CGROUP)) ==3) THEN
+ YGROUP='VENT'//CGROUP(3:3)//'DD'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='VENT'//CGROUP(3:4)//'DD'
+ ELSE
+ ! 13 car max
+ YGROUP='VENTDD'//CGROUP(3:9)
+ ENDIF
+ ! allocation du tableau de calcul
+ IF (allocated(ZWORK3D)) DEALLOCATE(ZWORK3D)
+ ALLOCATE(ZWORK3D(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ DO J6=1,SIZE(XVAR,6)
+ IGRID=NGRIDIA(J6)
+ DO J5=1,SIZE(XVAR,5)
+ DO J4=1,SIZE(XVAR,4)
+ iskip=1 ! tous les points de grille
+ CALL DD(ZVARSAVE(:,:,:,J4,J5,J6),XVAR(:,:,:,J4,J5,J6),ZWORK3D, &
+ iskip,IGRID,PLON=XLON(NIL:NIH,NJL:NJH))
+ XVAR(:,:,:,J4,J5,J6)=ZWORK3D(:,:,:)
+ END DO
+ END DO
+ ! initialisation des variables necessaires a l ecriture
+ CGROUP=YGROUP
+ CTITRE(J6)=YGROUP
+ CUNITE(J6)='degrees'
+ NGRIDIA(J6)=1
+ END DO
+ DEALLOCATE(ZWORK3D)
+ ELSE
+ print *,'** processing of ',TRIM(CGROUP),' is not performed for CTYPE= ',CTYPE
+ CYCLE
+ ENDIF
+ ELSE IF (CGROUP(1:2) == 'UT' .OR. CGROUP(1:2) == 'VT') THEN
+ IF (CTYPE=='CART' .OR. CTYPE=='MASK' .OR. CTYPE=='SPXY') THEN
+ ! Calcul des composantes zonale et meridienne
+ !(YOUTGRID(1:4) == 'LALO') avec la routine UV_TO_ZONAL_AND_MERID
+ print*,' Translate to meridional and zonal wind components'
+ ALLOCATE(ZWORK3D(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ ALLOCATE(ZWORK3D2(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ IF (ilocverbia >= 3 ) then
+ print *,'before UV_TO_ZONAL_AND_MERID KGRID=23'
+ print'(A31,3(I5,X))',' dimensions of the input arrays',size(ZVARSAVE,1),&
+ size(ZVARSAVE,2),size(ZVARSAVE,3)
+ print'(3(I5,X))',size(XVAR,1),size(XVAR,2),size(XVAR,3)
+ print'(A32,3(I5,X))',' dimensions of the output arrays',size(ZWORK3D,1),&
+ size(ZWORK3D,2),size(ZWORK3D,3)
+ print'(3(I5,X))',size(ZWORK3D2,1),size(ZWORK3D2,2),size(ZWORK3D2,3)
+ ENDIF
+ DO J6=1,SIZE(XVAR,6)
+ DO J5=1,SIZE(XVAR,5)
+ DO J4=1,SIZE(XVAR,4)
+ CALL UV_TO_ZONAL_AND_MERID(ZVARSAVE(:,:,:,J4,J5,J6), &
+ XVAR(:,:,:,J4,J5,J6), &
+ 23,PZC=ZWORK3D,PMC=ZWORK3D2)
+ IF (CGROUP(1:1) == 'U' ) THEN
+ XVAR(:,:,:,J4,J5,J6)=ZWORK3D(:,:,:)
+ ENDIF
+ IF (CGROUP(1:1) == 'V' ) THEN
+ XVAR(:,:,:,J4,J5,J6)=ZWORK3D2(:,:,:)
+ ENDIF
+ END DO
+ END DO
+ END DO
+ IF (ilocverbia >= 3 ) then
+ print *,'after UV_TO_ZONAL_AND_MERID KGRID=23'
+ END IF
+ ! Stockage dans le tableau XVAR qui est le tableau ecrit
+ ! de la composante souhaitée
+ IF (CGROUP(1:1) == 'U' ) THEN
+ print *, ' U zonal wind component'
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='UZON'
+ ELSE IF (LEN(TRIM(CGROUP)) ==3) THEN
+ YGROUP='U'//CGROUP(3:3)//'ZON'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='U'//CGROUP(3:4)//'ZON'
+ ELSE
+ ! 13 car max
+ YGROUP='UZON'//CGROUP(3:9)
+ ENDIF
+ CTITRE(:)='U zonal wind component'
+ ELSE IF (CGROUP(1:1) == 'V' ) THEN
+ print *, ' V meridian wind component'
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VMED'
+ ELSE IF (LEN(TRIM(CGROUP)) ==3) THEN
+ YGROUP='V'//CGROUP(3:3)//'MED'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='V'//CGROUP(3:4)//'MED'
+ ELSE
+ ! 13 car max
+ YGROUP='VZON'//CGROUP(3:9)
+ END IF
+ CTITRE(:)='V meridian wind component'
+ ENDIF
+ CGROUP=YGROUP
+ NGRIDIA(:)=1 ! UZON et VMED en grille de masse
+ DEALLOCATE(ZWORK3D,ZWORK3D2)
+ ELSE
+ print *,' No processing of UZON and VMED for CTYPE= ',CTYPE
+ CYCLE
+ ENDIF
+ ENDIF
+ DEALLOCATE(ZVARSAVE)
+ ENDIF
+ !
+ ! 3.1.2 LATitude ou LONgitude de chaque point de la grille conforme
+ !
+ ELSE IF (CGROUP(1:3)=='LAT' .OR. CGROUP(1:3)=='LON') THEN
+ print *, 'LAT/LON asked and YFLAGREADVAR=', YFLAGREADVAR
+ IF ( YFLAGREADVAR /= 'NOP') THEN
+ ! Lecture d un champ 2D quelconque pour initialiser XLAT et XLON
+ CALL READVAR('ZSBIS',YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ ! cas de fichier diachronique sans ZSBIS
+ print *, '- Name of one group in upper case '
+ read *,YGROUP
+ CALL WRITEDIR(ILUDIR,YGROUP)
+ CALL LOW2UP(YGROUP)
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print * ,'**group ', TRIM(YGROUP) , 'not found'
+ stop
+ ENDIF
+ ENDIF
+ ENDIF
+ ! init du tableau XVAR au champ souhaite
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(size(XLAT,1),size(XLAT,2),1,1,1,1) )
+ IF (CGROUP(1:3)=='LAT') THEN
+ XVAR(:,:,1,1,1,1)=XLAT(:,:)
+ CTITRE(1)='latitudes'
+ CUNITE(1)='degrees_north'
+ ELSE IF (CGROUP(1:3)=='LON') THEN
+ XVAR(:,:,1,1,1,1)=XLON(:,:)
+ CTITRE(1)='longitudes'
+ CUNITE(1)='degrees_east'
+ ENDIF
+ !
+ ! 3.1.3 Altitude de chaque point de la grille conforme
+ !
+ ELSE IF (CGROUP(1:4)=='VLEV') THEN
+ print *, 'VLEV asked and YFLAGREADVAR=', YFLAGREADVAR
+ IF(CTYPE=='SSOL'.OR.CTYPE=='DRST'.OR.CTYPE=='RAPL'.OR.CTYPE=='RSPL') THEN
+ IF ( YFLAGREADVAR == 'NOP') THEN
+ ! altitude des niveaux du groupe precedent dans XTRAJZ
+ print *,'warning, for CTYPE=',CTYPE,' Vertical LEVels of previous group (',TRIM(YGROUP_OLD),')'
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(1,1,size(XTRAJZ,1),1,1,1))
+ XVAR(1,1,:,1,1,1)=XTRAJZ(:,1,1)
+ ELSE
+ print*,'** no processing with VLEV at the first group'
+ GOTO 99
+ ENDIF
+ ELSE
+ IF ( YFLAGREADVAR /= 'NOP') THEN
+ ! Lecture d un champ 2D quelconque pour initialiser les tableaux XZZ
+ CALL READVAR('ZSBIS',YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ ! cas de fichier diachronique sans ZSBIS
+ print *, '- Name of one group in upper case '
+ read *,YGROUP
+ CALL WRITEDIR(ILUDIR,YGROUP)
+ CALL LOW2UP(YGROUP)
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print * ,'** group ', TRIM(YGROUP) , 'not found'
+ stop
+ ENDIF
+ ENDIF
+ ENDIF
+ ! init de XZZ a la grille de masse ( par defaut readvar
+ ! l initialise a la grille 4 des vitesse verticales W)
+ CALL COMPCOORD_FORDIACHRO(1)
+ ! init du tableau XVAR au champ souhaite
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(size(XZZ,1),size(XZZ,2),size(XZZ,3),1,1,1))
+ XVAR(:,:,:,1,1,1)=XZZ(:,:,:)
+ ! retour au XZZ grille 4
+ CALL COMPCOORD_FORDIACHRO(4)
+ ENDIF
+ CTITRE(1)='model levels altitudes ASL'
+ CUNITE(1)='meters'
+ !
+ ! 3.1.4 Default case
+ !
+ ELSE
+ !
+ ! Lecture du champ CGROUP et stockage dans XVAR
+ ! + Initialisation (si YFLAGREADVAR='OPE') des variables
+ ! des modules (cf USE en debut de programme)
+ ! Appel a menu_diachro pour la liste des groupes si CGROUP(1:5)=='GROUP'
+ CALL READVAR(CGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF (CGROUP(1:5)=='GROUP') CYCLE
+ !
+ ENDIF
+ !
+ IF ( iret == 0 ) THEN
+ zmini=MINVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ zmaxi=MAXVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ print * ,' After read, min,max of the variable ',TRIM(CGROUP),'=', zmini,zmaxi
+ !
+ !* 3.2 Init des bornes min max du zoom en fonction des
+ ! dimensions du tableau XVAR traite
+ !
+ IF ( ino_init_zoom == 0) THEN
+ IF (iideb == 0 .AND. iifin == 0 ) THEN
+ ivarideb=NREADIL ; ivarifin=NREADIH
+ IF (ivarideb/=ivarifin) THEN ! domI/=1
+ ivarideb=MAX(1+JPHEXT,NREADIL)
+ ivarifin=MIN(SIZE(XVAR,1)-JPHEXT,NREADIH)
+ ENDIF
+ ELSE IF (iideb == -1 .AND. iifin == -1 ) THEN
+ ivarideb=MAX(1,NREADIL)
+ ivarifin=MIN(SIZE(XVAR,1),NREADIH)
+ ELSE IF (iideb == -2 .AND. iifin == -2 ) THEN
+ ivarideb=-2
+ iideb=1+JPHEXT
+ IF (zideb >= minval(XLON)) THEN
+ DO JJ=1,SIZE(XLON,2)
+ ivarideb=MAX(MIN(COUNT(XLON(:,JJ)<zideb),SIZE(XLON,1)),iideb)
+ iideb=ivarideb
+ END DO
+ ENDIF
+ ivarifin=-2
+ iifin=1+JPHEXT
+ IF (zifin <= maxval(XLON)) THEN
+ DO JJ=1,SIZE(XLON,2)
+ ivarifin=MAX(MIN(COUNT(XLON(:,JJ)<zifin),SIZE(XLON,1)),iifin)
+ iifin=ivarifin
+ END DO
+ ENDIF
+ ELSE
+ ivarideb=max(iideb,NREADIL)
+ ivarifin=min(iifin,NREADIH)
+ ivarideb=min(ivarideb,ivarifin)
+ ENDIF
+ IF(ijdeb == 0 .AND. ijfin == 0) THEN
+ ivarjdeb=NREADJL ; ivarjfin=NREADJH
+ IF (ivarjdeb/=ivarjfin) THEN ! domJ/=1
+ ivarjdeb=MAX(1+JPHEXT,NREADJL)
+ ivarjfin=MIN(SIZE(XVAR,2)-JPHEXT,NREADJH)
+ ENDIF
+ ELSE IF (ijdeb == -1 .AND. ijfin == -1 ) THEN
+ ivarjdeb=MAX(1,NREADJL)
+ ivarjfin=MIN(SIZE(XVAR,2),NREADJH)
+ ELSE IF (ijdeb == -2 .AND. ijfin == -2 ) THEN
+ ivarjdeb=-2
+ ijdeb=1+JPHEXT
+ IF (zjdeb >= minval(XLAT)) THEN
+ DO JI=1,SIZE(XLAT,1)
+ ivarjdeb=MAX(MIN(COUNT(XLAT(JI,:)<zjdeb),SIZE(XLAT,2)),ijdeb)
+ ijdeb=ivarjdeb
+ END DO
+ ENDIF
+ ivarjfin=-2
+ ijfin=1+JPHEXT
+ IF (zjfin <= maxval(XLAT)) THEN
+ DO JI=1,SIZE(XLAT,1)
+ ivarjfin=MAX(MIN(COUNT(XLAT(JI,:)<zjfin),SIZE(XLAT,2)),ijfin)
+ ijfin=ivarjfin
+ END DO
+ ENDIF
+ ELSE
+ ivarjdeb=max(ijdeb,NREADJL)
+ ivarjfin=min(ijfin,NREADJH)
+ ivarjdeb=min(ivarjdeb,ivarjfin)
+ ENDIF
+ IF(ivarideb==-2 .OR. ivarifin==-2 .OR. ivarjdeb==-2 .OR. ivarjfin==-2) THEN
+ print *,'****zoom provided is not included in the FM-file grid'
+ print *,'LON (zoom: ',zideb,zifin,') (file: ',minval(XLON),maxval(XLON)
+ print *,'LAT (zoom: ',zjdeb,zjfin,') (file: ',minval(XLAT),maxval(XLAT)
+ GOTO 99
+ ENDIF
+ IF (IND_VERT/=0) THEN
+ ivarzmin=1 ; ivarzmax=inbvertz
+ ELSE
+ ivarzmin=MAX(1,NREADKL) ; ivarzmax=MIN(SIZE(XVAR,3),NREADKH)
+ inbvertz=ivarzmax-ivarzmin+1
+ ENDIF
+ IF (ikdeb == 0 .AND. ikfin == 0 ) THEN
+ ivarkdeb=NREADKL ; ivarkfin=NREADKH
+ IF (ivarkdeb/=ivarkfin .AND. CTYPE/='SSOL') THEN ! domK/=1
+ ivarkdeb=MAX(1+JPVEXT,NREADKL)
+ ivarkfin=min(ivarzmax,SIZE(XVAR,3)-JPVEXT)
+ ENDIF
+ ELSEIF (ikdeb == -1 .AND. ikfin ==-1 ) THEN
+ ivarkdeb=ivarzmin
+ ivarkfin=ivarzmax
+ ELSE
+ ivarkdeb=max(ikdeb,ivarzmin)
+ ivarkfin=min(ikfin,ivarzmax)
+ ivarkdeb=min(ivarkdeb,ivarkfin)
+ ENDIF
+ IF (INDX/=0) THEN
+ ivarkdeb=IK ; ivarkfin=IK
+ END IF
+ ENDIF
+
+ IF (itinf == 0 .AND. itsup == 0 ) THEN
+ ivartinf=1 ; ivartsup=SIZE(XVAR,4)
+ ELSE
+ ivartinf=max(itinf,1)
+ ivartsup=min(itsup,SIZE(XVAR,4))
+ ivartinf=min(ivartinf,ivartsup)
+ ENDIF
+ IF (itrajinf == 0 .AND. itrajsup == 0 ) THEN
+ ivartrajinf=1 ; ivartrajsup=SIZE(XVAR,5)
+ ELSE
+ ivartrajinf=max(itrajinf,1)
+ ivartrajsup=min(itrajsup,SIZE(XVAR,5))
+ ivartrajinf=min(ivartrajinf,ivartrajsup)
+ ENDIF
+ IF (iprocinf == 0 .AND. iprocsup == 0 ) THEN
+ ivarprocinf=1 ; ivarprocsup=SIZE(XVAR,6)
+ ELSE
+ ivarprocinf=max(iprocinf,1)
+ ivarprocsup=min(iprocsup,SIZE(XVAR,6))
+ ivarprocinf=min(ivarprocinf,ivarprocsup)
+ ENDIF
+ if (ilocverbia > 0 ) then
+ PRINT*,' Zoom limits initialized with:'
+ PRINT'(A53,6(I4,X))','ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin',&
+ ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin
+ PRINT'(A53,6(I4,X))','ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocfin',&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup
+ endif
+ !
+ !* 3.3 Ecriture du tableau XVAR (module MODD_ALLOC_FORDIACHRO)
+ !
+ print *,' Write with the format ', YTYPEOUT(1:4)
+ SELECT CASE(YTYPEOUT(1:4))
+ !
+ CASE('DIAC')
+ CALL WRITEVAR(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ CGROUP,YFILEIN,YFLAGWRITE,'2 ',ilocverbia,iret)
+ if (ilocverbia > 0 ) then
+ print'(A17,I2))','WRITEVAR return= ',iret
+ end if
+ !
+ CASE('FREE')
+ if (ilocverbia >= 0 ) then
+ print*,' format ',YTYPEOUT
+ print'(A53,X,A50,6(I4,X),2(I6,X),4(I4,X))',&
+ ' domaine for writting : ideb,ifin,jdeb,jfin,kdeb,kfin', &
+ ',itinf,itsup,itrajinf,itrajsup,iprocinf,iprocsup= ', &
+ ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup
+ endif
+ ! Retour aux unites initiales si necessaire
+ CALL FROM_COMPUTING_UNITS(CGROUP,CUNITE(1))
+ !
+ YFILEOUTFREE=ADJUSTL(ADJUSTR(YFILEIN)//'.'//ADJUSTL(ADJUSTR(CGROUP)))
+ OPEN (UNIT=7,STATUS='NEW',FORM='FORMATTED',FILE=YFILEOUTFREE)
+ ! a. Ecriture de l entete
+ !temps courant
+ IAN=XDATIME(13,1)
+ IMOIS=XDATIME(14,1)
+ IJOUR=XDATIME(15,1)
+ IHEURE=XDATIME(16,1)/3600
+ IMINUTE=(XDATIME(16,1)-(IHEURE*3600))/60
+ ISECONDE=ISECONDE-(IHEURE*3600)-(IMINUTE*60)
+ WRITE(7,FMT='(6(I4,X),2(I6,X),4(I4,X),4(I4,X),A42,A33)') ivarideb,&
+ ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ IAN,IMOIS,IJOUR,IHEURE,IMINUTE ,&
+ 'format ligne1= 12 Indices (.deb .fin) du ',&
+ 'tableau an mois jour hUTC minute'
+ ! b. ecriture des données au fmt choisi par l utilisateur
+ WRITE(7,FMT=YFMTFREE) &
+ XVAR(ivarideb:ivarifin,ivarjdeb:ivarjfin,ivarkdeb:ivarkfin,&
+ ivartinf:ivartsup,ivartrajinf:ivartrajsup,ivarprocinf:ivarprocsup)
+ PRINT*,'File ',TRIM(YFILEOUTFREE),' available'
+ CLOSE(7)
+ !
+ CASE('LLHV','llhv','IJHV','jihv')
+ IF (CTYPE == 'SSOL') THEN
+ ALLOCATE(ZALT(1,1,SIZE(XTRAJZ,1)))
+ ZALT(1,1,:)=XTRAJZ(:,1,1)
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YTYPEOUT,&
+ ilocverbia,iret,PALT=ZALT)
+ ELSE
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YTYPEOUT,&
+ ilocverbia,iret)
+ ENDIF
+ if (ilocverbia > 0 ) then
+ print*,' WRITELLHV return= ',iret
+ end if
+ !
+ CASE('KCDL','ZCDL','PCDL','LLZV','LLPV','llpv','llzv',&
+ & 'IJZV','jizv','IJPV','jipv','llav','LLAV')
+ ! replace field at mass points
+ IF ( CGROUP /= 'VLEV' ) THEN
+ If (ALLOCATED(ZWORK3D))DEALLOCATE(ZWORK3D)
+ If (ALLOCATED(ZWORK3D2))DEALLOCATE(ZWORK3D2)
+ ALLOCATE(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ALLOCATE(ZWORK3D2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ DO J6=ivarprocinf,ivarprocsup
+ IGRID=NGRIDIA(J6)
+ IF(SIZE(XVAR,3)/=1 .OR. IGRID/=4) THEN
+ ! pas d interpolation verticale pour champ 2D
+ DO J5=ivartrajinf,ivartrajsup
+ DO J4=ivartinf,ivartsup
+ ZWORK3D(:,:,:)=XVAR(:,:,:,J4,J5,J6)
+ print'(A29,3(X,I4))',' mass point grid for J4,J5,J6=',J4,J5,J6
+ CALL CHANGE_A_GRID(ZWORK3D,IGRID,ZWORK3D2)
+ NGRIDIA(J6)=IGRID
+ ! IGRID=1 en sortie de change_a_grid
+ XVAR(:,:,:,J4,J5,J6)=ZWORK3D2(:,:,:)
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+ DEALLOCATE(ZWORK3D,ZWORK3D2)
+ ENDIF
+ !
+ ! a. reinit avant ecriture de la grille verticale correspondant a la
+ !grille de masse sur laquelle le champ a ete interpole
+ IFLAGzcst=0
+ IF (IND_VERT/=0) THEN
+ IF ( CGROUP == 'VLEV' ) THEN
+ ! ecriture de la liste des niveaux verticaux
+ IFLAGzcst=1
+ DEALLOCATE(XVAR)
+ allocate(XVAR(1,1,inbvertz,1,1,1))
+ XVAR(1,1,:,1,1,1)=zlistevert
+ ivarideb=1 ; ivarifin=1
+ ivarjdeb=1 ; ivarjfin=1
+ ivarkdeb=1 ; ivarkfin=inbvertz
+ CTITRE(1)='vertical_levels'
+ CUNITE(1)='user choice'
+ IF ( YTYPEOUT(IND_VERT:IND_VERT) == 'z' .OR. YTYPEOUT(IND_VERT:IND_VERT) == 'Z' ) THEN
+ CUNITE(1)='km'
+ XVAR=XVAR*0.001
+ ENDIF
+ IF ( YTYPEOUT(IND_VERT:IND_VERT) == 'p' .OR. YTYPEOUT(IND_VERT:IND_VERT) == 'P' ) THEN
+ CUNITE(1)='hPa'
+ ENDIF
+ ENDIF
+ ! b. interpolation eventuelle selon la verticale
+ IF( SIZE(XVAR,3)>1 .AND. CGROUP /= 'VLEV' ) THEN
+ ! VLEV, LON, LAT et chps 2D ne passent pas cette partie
+ if (ilocverbia >= 0 ) then
+ print*,' Interpolations on ',inbvertz,' ', &
+ YTYPEOUT(IND_VERT:IND_VERT),'-levels'
+ endif
+ if (ilocverbia >= 1 .AND. IND_VERT/=0) THEN
+ print*,'levels= ',zlistevert
+ endif
+ ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+ size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+ ZVARSAVE=XVAR
+ ALLOCATE(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ALLOCATE(ZVARZCST(SIZE(XVAR,1),SIZE(XVAR,2),inbvertz))
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(SIZE(ZVARSAVE,1),SIZE(ZVARSAVE,2),SIZE(ZVARZCST,3),&
+ size(ZVARSAVE,4),size(ZVARSAVE,5),size(ZVARSAVE,6)))
+ DO J6=ivarprocinf,ivarprocsup
+ IGRID=NGRIDIA(J6)
+ ! init du tableau des altitudes XZZ pour la grille= IGRID
+ CALL COMPCOORD_FORDIACHRO(IGRID)
+ DO J5=ivartrajinf,ivartrajsup
+ DO J4=ivartinf,ivartsup
+ ZWORK3D(:,:,:)=ZVARSAVE(:,:,:,J4,J5,J6)
+ ikdebzint=2
+ IF (INDEX(YTYPEOUT(1:4),'Z')/=0 .OR. INDEX(YTYPEOUT(1:4),'z')/=0) THEN
+ CALL ZINTER(ZWORK3D,XZZ,ZVARZCST,zlistevert,ikdebzint,XSPVAL)
+ ELSE IF (INDEX(YTYPEOUT(1:4),'A')/=0 .OR. INDEX(YTYPEOUT(1:4),'a')/=0) THEN
+ IF (.NOT. ALLOCATED(zlistevert3D)) THEN
+ ALLOCATE(zlistevert3D(SIZE(XZS,1),SIZE(XZS,2),SIZE(zlistevert)))
+ DO IZLIST=1,SIZE(zlistevert)
+ zlistevert3D(:,:,IZLIST)=XZS(:,:)+zlistevert(IZLIST)
+ ENDDO
+ ENDIF
+ CALL SINTER(ZWORK3D,XZZ,ZVARZCST,zlistevert3D,ikdebzint,XSPVAL)
+ ELSE IF (INDEX(YTYPEOUT(1:4),'P')/=0 .OR. INDEX(YTYPEOUT(1:4),'p')/=0) THEN
+ CALL PINTER(ZWORK3D,0,XSPVAL,zlistevert,ZVARZCST,ZPABS)
+ ELSE IF (INDEX(YTYPEOUT(1:4),'H')/=0 .OR. INDEX(YTYPEOUT(1:4),'h')/=0) THEN
+ ZVARZCST(:,:,:)=ZWORK3D(:,:,:)
+ ELSE
+ print*,'** ERROR in vertical interpolations with ',YTYPEOUT
+ ENDIF
+ XVAR(:,:,:,J4,J5,J6)=ZVARZCST
+ END DO
+ END DO
+ END DO
+ DEALLOCATE(ZVARSAVE,ZVARZCST,ZWORK3D)
+ zmini=MINVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ zmaxi=MAXVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ print * ,' After vertical interpolation, min,max of the variable ',TRIM(CGROUP),'=', zmini,zmaxi
+ ivarkdeb=1
+ ivarkfin=inbvertz
+ IF (ilocverbia >= 5 ) then
+ print*,'ivarkdeb,ivarkfin= ',ivarkdeb,ivarkfin
+ ENDIF
+ ENDIF
+ ENDIF
+ ! c. interpolation eventuelle sur l horizontale
+ IF ( YOUTGRID(1:4) == 'LALO' ) THEN
+ if (ilocverbia >= 0 ) then
+ print *,'Translate to a regular lat lon grid '
+ end if
+ IF ( .NOT. ALLOCATED (ZNEWX) ) THEN
+ IF ( IFLAGzcst == 1 ) THEN
+ print*,'** no processing with VLEV at the first group'
+ GOTO 99
+ ELSE
+ ! c.1. creation de la grille réguliere en lat lon
+ if (ilocverbia >= 2 ) then
+ print *,'grid creation, size of XLON: ',SIZE(XLON,1),SIZE(XLON,2)
+ end if
+ ! calcul des coord X Y des points de la grille lat-lon reguliere
+ ! determine le maximum d espacement en lat et lon sur le zoom
+ ALLOCATE(ZDIFFLON(SIZE(XLON,1)-1,SIZE(XLON,2)))
+ ALLOCATE(ZDIFFLAT(SIZE(XLAT,1),SIZE(XLAT,2)-1))
+
+ DO ii=1,SIZE(XLON,1)-1
+ DO jj=1,SIZE(XLON,2)
+ ZDIFFLON(ii,jj)=XLON(ii+1,jj)-XLON(ii,jj)
+ END DO
+ END DO
+
+ DO ii=1,SIZE(XLAT,1)
+ DO jj=1,SIZE(XLAT,2)-1
+ ZDIFFLAT(ii,jj)=XLAT(ii,jj+1)-XLAT(ii,jj)
+ END DO
+ END DO
+! ZDELTALON=NINT(maxval(ZDIFFLON)*1000.)
+! ZDELTALAT=NINT(maxval(ZDIFFLAT)*1000.)
+ ZDELTALON=maxval(ZDIFFLON)
+ ZDELTALAT=maxval(ZDIFFLAT)
+ DEALLOCATE(ZDIFFLON)
+ DEALLOCATE(ZDIFFLAT)
+ if (ZDELTALON == 0 .OR. ZDELTALAT == 0 ) THEN
+ print *,' error during ZDELTALON,ZDELTALAT computation=', ZDELTALON,ZDELTALAT
+ print *,'XLON(ivarideb+1,ivarjdeb)-XLON(ivarideb,ivarjdeb)'&
+ ,'XLON(ivarifin,ivarjfin)-XLON(ivarifin-1,ivarjfin)'&
+ ,'XLAT(ivarideb,ivarjdeb+1)-XLAT(ivarideb,ivarjdeb)'&
+ ,'XLAT(ivarifin,ivarjfin)-XLAT(ivarifin,ivarjfin-1)'
+ print *,XLON(ivarideb+1,ivarjdeb)-XLON(ivarideb,ivarjdeb)&
+ ,XLON(ivarifin,ivarjfin)-XLON(ivarifin-1,ivarjfin)&
+ ,XLAT(ivarideb,ivarjdeb+1)-XLAT(ivarideb,ivarjdeb)&
+ ,XLAT(ivarifin,ivarjfin)-XLAT(ivarifin,ivarjfin-1)
+ print *, 'ivarideb+1,ivarjdeb,ivarifin-1,ivarjfin',ivarideb+1,ivarjdeb,ivarifin-1,ivarjfin
+ print *,'Verify the fields LAT LON of the FM file'
+ ALLOCATE(ZX(SIZE(XLAT,1),SIZE(XLAT,2)),ZY(SIZE(XLAT,1),SIZE(XLAT,2)))
+ ZX(1:SIZE(XZZ,1),1) = XXX(1:SIZE(XZZ,1),IGRID)
+ ZX(:,2:SIZE(XZZ,2)) = SPREAD(ZX(:,1),2,SIZE(XZZ,2)-1)
+ ZY(1,1:SIZE(XZZ,2)) = XXY(1:SIZE(XZZ,2),IGRID)
+ ZY(2:SIZE(XZZ,1),:) = SPREAD(ZY(1,:),1,SIZE(XZZ,1)-1)
+ CALL SM_LATLON(XLATORI,XLONORI,ZX,ZY,XLAT,XLON)
+ ZDELTALON=max(XLON(ivarideb+1,ivarjdeb)-XLON(ivarideb,ivarjdeb)&
+ ,XLON(ivarifin,ivarjfin)-XLON(ivarifin-1,ivarjfin))
+ ZDELTALAT=max(XLAT(ivarideb,ivarjdeb+1)-XLAT(ivarideb,ivarjdeb)&
+ ,XLAT(ivarifin,ivarjfin)-XLAT(ivarifin,ivarjfin-1))
+ print *,' After Model Grid computation: ZDELTALON,ZDELTALAT=', ZDELTALON,ZDELTALAT
+ endif
+ IDIM1=(maxval(XLON)-minval(XLON))/ZDELTALON
+ IDIM2=(maxval(XLAT)-minval(XLAT))/ZDELTALAT
+ ALLOCATE (ZNEWLAT(IDIM1,IDIM2),ZNEWLON(IDIM1,IDIM2) )
+ if (ilocverbia >= 1 ) then
+ print*,' ZDELTALON,ZDELTALAT= ',ZDELTALON,ZDELTALAT
+ endif
+ if (ilocverbia >= 2 ) then
+ print*,' IDIM1,IDIM2= ',IDIM1,IDIM2
+ endif
+ ! depart de la nouvelle grille : coin Sud Ouest
+ DO JI=1,IDIM1
+ ZNEWLON(JI,:)=minval(XLON) + (JI-1) *ZDELTALON
+ ENDDO
+ DO JJ=1,IDIM2
+ ZNEWLAT(:,JJ)=minval(XLAT) + (JJ-1) *ZDELTALAT
+ ENDDO
+ if (ilocverbia >= 4 ) then
+ print*, 'new lat lon grid=',ZNEWLAT(1,:)
+ print*, ZNEWLON(:,1)
+ endif
+
+ ALLOCATE (ZNEWX(IDIM1,IDIM2))
+ ALLOCATE (ZNEWY(IDIM1,IDIM2))
+ CALL SM_XYHAT(XLATORI,XLONORI,ZNEWLAT,ZNEWLON,ZNEWX,ZNEWY)
+ if (ilocverbia >= 4 ) then
+ ! XXX= XXHAT et XXY=XYHAT pour les 7 grilles
+ print*,' After SM_XYHAT old limits X: ', &
+ XXX(1,IGRID),XXX(SIZE(XVAR,1),IGRID)
+ print*,' new limits X: ', &
+ ZNEWX(1,1),ZNEWX(IDIM1,IDIM2)
+ print*,' old limits Y: ', &
+ XXY(1,IGRID),XXY(SIZE(XVAR,2),IGRID)
+ print*,' new limits Y: ', &
+ ZNEWY(1,1),ZNEWY(IDIM1,IDIM2)
+ endif
+ if (ilocverbia >= 5 ) then
+ DO JI= 1,SIZE(XVAR,1)
+ print*,'XXHAT ZNEWX',XXX(JI,IGRID),ZNEWX(JI,1),ZNEWX(JI,IDIM2)
+ ENDDO
+ DO JJ= 1,SIZE(XVAR,2)
+ print*,'XYHAT ZNEWY',XXY(JJ,IGRID),ZNEWY(1,JJ),ZNEWX(IDIM1,JJ)
+ ENDDO
+ endif
+ ! calcul de la section de tableau correspondant au zoom
+
+!===================================================================================================================
+ I1=(maxval(XLON(ivarideb:ivarifin,ivarjdeb:ivarjfin)) &
+ -minval(XLON(ivarideb:ivarifin,ivarjdeb:ivarjfin)) )/ZDELTALON
+ I2=(maxval(XLAT(ivarideb:ivarifin,ivarjdeb:ivarjfin)) &
+ -minval(XLAT(ivarideb:ivarifin,ivarjdeb:ivarjfin)) )/ZDELTALAT
+ IZOOMIDEB=MAX(MIN(COUNT(ZNEWLON(:,1)<minval(XLON(ivarideb:ivarifin,ivarjdeb:ivarjfin))),IDIM1),1)
+ IZOOMJDEB=MAX(MIN(COUNT(ZNEWLAT(1,:)<minval(XLAT(ivarideb:ivarifin,ivarjdeb:ivarjfin))),IDIM2),1)
+ IZOOMIFIN=MAX(MIN(COUNT(ZNEWLON(:,1)<maxval(XLON(ivarideb:ivarifin,ivarjdeb:ivarjfin))),IDIM1),1)
+ IZOOMJFIN=MAX(MIN(COUNT(ZNEWLAT(1,:)<maxval(XLAT(ivarideb:ivarifin,ivarjdeb:ivarjfin))),IDIM2),1)
+!=====================================================================================================================
+
+
+ if (ilocverbia >= 2 ) then
+ print*,' ZOOM along i in the LON-LAT grid: ', &
+ IZOOMIDEB,IZOOMIFIN,I1
+ print*,' j : ', &
+ IZOOMJDEB,IZOOMJFIN,I2
+ endif
+ ENDIF
+ ENDIF ! fin grille ZNEWX deja allouee
+ ! c.2. interpolation sur la nouvelle grille
+ IF( IFLAGzcst/= 1 .AND. (NREADIH-NREADIL)>0 .AND. (NREADJH-NREADJL)>0 )THEN
+ ! interpolation vers la nouvelle grille réguliere en lat lon
+ !sauf la grille verticale definie en niveaux Z et champs 1D
+ if (ilocverbia >= 1 ) then
+ print*,' interpolation for the variable ',trim(CGROUP)
+ end if
+ allocate(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ allocate(ZWORK3D2(IDIM1,IDIM2,SIZE(XVAR,3)))
+ ! stockage des champs interpoles dans la nouvelle grille
+ if (allocated (ZVARSAVE)) DEALLOCATE(ZVARSAVE)
+ allocate(ZVARSAVE(IDIM1,IDIM2,SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),SIZE(XVAR,6)))
+ ! boucle sur les dimensions 4 5 6
+ DO J6=ivarprocinf,ivarprocsup
+ DO J5=ivartrajinf,ivartrajsup
+ DO J4=ivartinf,ivartsup
+ ZWORK3D(:,:,:)=XVAR(:,:,:,J4,J5,J6)
+ if (ilocverbia >= 2 ) then
+ print *,'before HOR_INTERP_4PTS J4,J5,J6=', J4,J5,J6
+ end if
+ CALL HOR_INTERP_4PTS(XXX(:,IGRID),XXY(:,IGRID),ZWORK3D, &
+ ZNEWX,ZNEWY,ZWORK3D2)
+ ZVARSAVE(:,:,:,J4,J5,J6)=ZWORK3D2(:,:,:)
+ END DO
+ END DO
+ END DO
+ ! resultat dans XVAR passe en module
+ DEALLOCATE (XVAR)
+ ALLOCATE(XVAR(IDIM1,IDIM2,SIZE(ZVARSAVE,3),&
+ SIZE(ZVARSAVE,4),SIZE(ZVARSAVE,5),SIZE(ZVARSAVE,6)))
+ XVAR=XSPVAL
+ XVAR(:,:,:,ivartinf:ivartsup,ivartrajinf:ivartrajsup,ivarprocinf:ivarprocsup)= &
+ ZVARSAVE(:,:,:,ivartinf:ivartsup,ivartrajinf:ivartrajsup,ivarprocinf:ivarprocsup)
+ DEALLOCATE (ZVARSAVE)
+ zmini=MINVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ zmaxi=MAXVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ print * ,' After horizontal interpolation, min,max of the variable ',TRIM(CGROUP),'=', zmini,zmaxi
+ if (ilocverbia >= 2 ) then
+ print*, 'After HOR_INTERP_4PTS all the dim 4,5,6'
+ endif
+ IF (allocated(ZWORK3D)) DEALLOCATE(ZWORK3D)
+ IF (allocated(ZWORK3D2)) DEALLOCATE(ZWORK3D2)
+ ENDIF
+ ENDIF
+ ! d. ecriture des donnees au format cdl ou llz/llp
+ IF ( YOUTGRID(1:4) == 'LALO' ) THEN
+ IF ( IFLAGzcst /= 1 ) THEN
+ ivarideb=IZOOMIDEB
+ ivarifin=IZOOMIFIN
+ ivarjdeb=IZOOMJDEB
+ ivarjfin=IZOOMJFIN
+ ENDIF
+ SELECT CASE(YTYPEOUT(1:4))
+ CASE('LLZV','llzv','LLPV','llpv','LLAV','llav')
+ IF (allocated(ZWORK3D)) DEALLOCATE(ZWORK3D)
+ ALLOCATE(ZWORK3D(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ IF (SIZE(XVAR,3)==inbvertz) THEN
+ ZWORK3D(1,1,:)=zlistevert
+ ELSE
+ ZWORK3D(1,1,:)=XSPVAL
+ ENDIF
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YTYPEOUT,&
+ ilocverbia,iret,PLON=ZNEWLON,PLAT=ZNEWLAT,&
+ PALT=ZWORK3D)
+ if (ilocverbia > 0 ) then
+ print*,'WRITELLHV LALO return= ', YTYPEOUT,'= ',iret
+ end if
+ DEALLOCATE(ZWORK3D)
+ !
+ CASE('KCDL','ZCDL','PCDL')
+ YGROUP=ADJUSTL(ADJUSTR(CGROUP)//ADJUSTL(YK))
+ CALL WRITECDL(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ YGROUP,YFILEIN,YFLAGWRITE,YOUTGRID,YSUFFIX_file, &
+ ilocverbia,iret,PGRIDX=ZNEWLON(:,1),PGRIDY=ZNEWLAT(1,:))
+ IF (ilocverbia >= 1 ) print *,' counter of added fields=',inetadd
+ if ( inetadd == 0) then
+ IF( SIZE(XZZ,3)<=1 .OR. SIZE(XZZ,2)<=1 .OR. SIZE(XZZ,1)<=1 ) THEN
+ ! VLEV, LON, LAT et chps 2D ne passent pas cette partie
+ print *,' *****The program could not add the VLEV 3Dfield to the netcdf file****'
+ ELSE
+ print *,' The program adds the VLEV 3Dfield to the netcdf file'
+ YGROUP_OLD=CGROUP(1:13)
+ CGROUP='VLEV'
+ inetadd=inetadd+1
+ YFLAGWRITE='OLD'
+ ino_init_zoom=1
+ GO TO 77
+ ENDIF
+ endif
+ if ( inetadd == 1 .AND. YOUTGRID(1:4) == 'CONF' )THEN
+ print *,' The program adds the LAT 3Dfield to the netcdf file'
+ CGROUP='LAT'
+ inetadd=inetadd+1
+ YFLAGWRITE='OLD'
+ ino_init_zoom=1
+ GO TO 77
+ endif
+ if ( inetadd == 2 .AND. YOUTGRID(1:4) == 'CONF' )THEN
+ print *,' The program adds the LON 3Dfield to the netcdf file'
+ CGROUP='LON'
+ inetadd=inetadd+1
+ YFLAGWRITE='OLD'
+ ino_init_zoom=1
+ GO TO 77
+ endif
+
+ END SELECT
+ ELSE ! pas d interpolation horizontale
+ SELECT CASE(YTYPEOUT(1:4))
+ CASE('LLZV','llzv','LLPV','llpv','IJZV','jizv','IJPV','jipv','LLAV','llav')
+ IF (SIZE(XVAR,3)==inbvertz) THEN ! champ 3D
+ IF (allocated(ZWORK3D)) DEALLOCATE(ZWORK3D)
+ ALLOCATE(ZWORK3D(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ ZWORK3D(1,1,:)=zlistevert
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YTYPEOUT,&
+ ilocverbia,iret,&
+ PALT=ZWORK3D)
+ ELSE ! champ 2D
+ IF((YTYPEOUT(3:3)=='z').OR.(YTYPEOUT(3:3)=='p')) YTYPEOUT3='h'
+ IF((YTYPEOUT(3:3)=='Z').OR.(YTYPEOUT(3:3)=='P')) YTYPEOUT3='H'
+ IF((YTYPEOUT(3:3)=='a').OR.(YTYPEOUT(3:3)=='A')) YTYPEOUT3='H'
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ CGROUP,YFILEIN,YFLAGWRITE, &
+ YTYPEOUT(1:2)//YTYPEOUT3//YTYPEOUT(4:4), &
+ ilocverbia,iret)
+ ENDIF
+ if (ilocverbia > 0 ) then
+ print*,' WRITELLHV for ', YTYPEOUT,', return value= ',iret
+ end if
+ IF (allocated(ZWORK3D)) DEALLOCATE(ZWORK3D)
+ !
+ CASE('KCDL','ZCDL','PCDL')
+ YGROUP=ADJUSTL(ADJUSTR(CGROUP)//ADJUSTL(YK))
+ CALL WRITECDL(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ YGROUP,YFILEIN,YFLAGWRITE,YOUTGRID,YSUFFIX_file, &
+ ilocverbia,iret,PGRIDX=XXX(:,IGRID),PGRIDY=XXY(:,IGRID))
+ IF (ilocverbia >= 1 ) print *,' counter of added fields=',inetadd
+ if ( inetadd == 0) then
+ if (ivarkdeb == ivarkfin .AND. ivarkdeb == 1 ) THEN
+ print *, 'No VLEV field for only one vertical position'
+ else
+ print *,' The program adds the VLEV 3Dfield to the netcdf file'
+ YGROUP_OLD=CGROUP(1:13)
+ CGROUP='VLEV'
+ inetadd=inetadd+1
+ YFLAGWRITE='OLD'
+ ino_init_zoom=1
+ GO TO 77
+ endif
+ endif
+ if ( inetadd == 1 .AND. YOUTGRID(1:4) == 'CONF' )THEN
+ if (ivarideb /= ivarifin .AND. ivarjdeb /= ivarjfin ) THEN
+
+ print *,' The program adds the LAT 3Dfield to the netcdf file'
+ CGROUP='LAT'
+ inetadd=inetadd+1
+ ino_init_zoom=1
+ GO TO 77
+ else
+ print *, ' No LAT field for only one location', ivarideb,ivarifin,ivarjdeb,ivarjfin
+ endif
+ endif
+ if ( inetadd == 2 .AND. YOUTGRID(1:4) == 'CONF' )THEN
+ if (ivarideb /= ivarifin .AND. ivarjdeb /= ivarjfin ) THEN
+ print *,' The program adds the LON 3Dfield to the netcdf file'
+ CGROUP='LON'
+ inetadd=inetadd+1
+ ino_init_zoom=1
+ GO TO 77
+ else
+ print *, ' No LON field for only one location', ivarideb,ivarifin,ivarjdeb,ivarjfin
+ endif
+ endif
+ END SELECT
+ ENDIF
+ ! retour a XZZ pour NGRID a 4 (cf readvar)
+ CALL COMPCOORD_FORDIACHRO(4)
+!============================================
+ CASE('ZGRB','PGRB','AGRB')
+ IF(SIZE(XVAR,3)==1) THEN
+ LVAR2D=.TRUE.
+ ENDIF
+ ! replace field at mass points
+ IF ( CGROUP /= 'VLEV' ) THEN
+ If (ALLOCATED(ZWORK3D))DEALLOCATE(ZWORK3D)
+ If (ALLOCATED(ZWORK3D2))DEALLOCATE(ZWORK3D2)
+ ALLOCATE(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ALLOCATE(ZWORK3D2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ DO J6=ivarprocinf,ivarprocsup
+ IGRID=NGRIDIA(J6)
+ IF(SIZE(XVAR,3)/=1 .OR. IGRID/=4) THEN
+ ! pas d interpolation verticale pour champ 2D
+ DO J5=ivartrajinf,ivartrajsup
+ DO J4=ivartinf,ivartsup
+ ZWORK3D(:,:,:)=XVAR(:,:,:,J4,J5,J6)
+ print'(A29,3(X,I4))',' mass point grid for J4,J5,J6=',J4,J5,J6
+ CALL CHANGE_A_GRID(ZWORK3D,IGRID,ZWORK3D2)
+ ! IGRID=1 en sortie de change_a_grid
+ NGRIDIA(J6)=IGRID
+ XVAR(:,:,:,J4,J5,J6)=ZWORK3D2(:,:,:)
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDDO
+ DEALLOCATE(ZWORK3D,ZWORK3D2)
+ ENDIF
+ !
+ ! a. reinit avant ecriture de la grille verticale correspondant a la
+ !grille de masse sur laquelle le champ a ete interpole
+ IFLAGzcst=0
+ IF (IND_VERT/=0) THEN
+ ! b. interpolation eventuelle selon la verticale
+ IF( SIZE(XVAR,3)>1 .AND. SIZE(XVAR,2)>1 .AND. SIZE(XVAR,1)>1 ) THEN
+ ! VLEV, LON, LAT et chps 2D ne passent pas cette partie
+ if (ilocverbia >= 0 ) then
+ print*,' Interpolations on ',inbvertz,' ', &
+ YTYPEOUT(IND_VERT:IND_VERT),'-levels'
+ endif
+ if (ilocverbia >= 1 .AND. IND_VERT/=0) THEN
+ print*,'levels= ',zlistevert
+ endif
+ ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+ size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+ ZVARSAVE=XVAR
+ ALLOCATE(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ALLOCATE(ZVARZCST(SIZE(XVAR,1),SIZE(XVAR,2),inbvertz))
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(SIZE(ZVARSAVE,1),SIZE(ZVARSAVE,2),SIZE(ZVARZCST,3),&
+ size(ZVARSAVE,4),size(ZVARSAVE,5),size(ZVARSAVE,6)))
+ DO J6=ivarprocinf,ivarprocsup
+ IGRID=NGRIDIA(J6)
+ ! init du tableau des altitudes XZZ pour la grille= IGRID
+ CALL COMPCOORD_FORDIACHRO(IGRID)
+ DO J5=ivartrajinf,ivartrajsup
+ DO J4=ivartinf,ivartsup
+ ZWORK3D(:,:,:)=ZVARSAVE(:,:,:,J4,J5,J6)
+ ikdebzint=2
+ IF (INDEX(YTYPEOUT(1:4),'Z')/=0 .OR. INDEX(YTYPEOUT(1:4),'z')/=0) THEN
+ CALL ZINTER(ZWORK3D,XZZ,ZVARZCST,zlistevert,ikdebzint,XSPVAL)
+ ELSE IF (INDEX(YTYPEOUT(1:4),'A')/=0 .OR. INDEX(YTYPEOUT(1:4),'a')/=0) THEN
+ IF (.NOT. ALLOCATED(zlistevert3D)) THEN
+ ALLOCATE(zlistevert3D(SIZE(XZS,1),SIZE(XZS,2),SIZE(zlistevert)))
+ DO IZLIST=1,SIZE(zlistevert)
+ zlistevert3D(:,:,IZLIST)=XZS(:,:)+zlistevert(IZLIST)
+ ENDDO
+ ENDIF
+ CALL SINTER(ZWORK3D,XZZ,ZVARZCST,zlistevert3D,ikdebzint,XSPVAL)
+ ELSE IF (INDEX(YTYPEOUT(1:4),'P')/=0 .OR. INDEX(YTYPEOUT(1:4),'p')/=0) THEN
+ CALL PINTER(ZWORK3D,0,XSPVAL,zlistevert,ZVARZCST,ZPABS)
+ ELSE IF (INDEX(YTYPEOUT(1:4),'H')/=0 .OR. INDEX(YTYPEOUT(1:4),'h')/=0) THEN
+ ZVARZCST(:,:,:)=ZWORK3D(:,:,:)
+ ELSE
+ print*,'** ERROR in vertical interpolations with ',YTYPEOUT
+ ENDIF
+ XVAR(:,:,:,J4,J5,J6)=ZVARZCST
+ END DO
+ END DO
+ END DO
+ DEALLOCATE(ZVARSAVE,ZVARZCST,ZWORK3D)
+ zmini=MINVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ zmaxi=MAXVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ print * ,' After vertical interpolation, min,max of the variable ',TRIM(CGROUP),'=', zmini,zmaxi
+ ivarkdeb=1
+ ivarkfin=inbvertz
+ IF (ilocverbia >= 5 ) then
+ print*,'ivarkdeb,ivarkfin= ',ivarkdeb,ivarkfin
+ ENDIF
+ ENDIF
+ ENDIF
+ ! c. interpolation eventuelle sur l horizontale
+ IF ( YOUTGRID(1:4) == 'LALO' ) THEN
+ ZLATLON(1)=MAXVAL(XLAT)*1000.
+ ZLATLON(2)=MINVAL(XLAT)*1000.
+ ZLATLON(3)=MINVAL(XLON)*1000.
+ ZLATLON(4)=MAXVAL(XLON)*1000.
+
+ IF (ZJFIN /=0 .AND. ZJFIN/=-1) ZLATLON(1)=zjfin*1000.
+ IF (ZJDEB /=0 .AND. ZJDEB/=-1) ZLATLON(2)=zjdeb*1000.
+ IF (ZIDEB /=0 .AND. ZIDEB/=-1) ZLATLON(3)=zideb*1000.
+ IF (ZIFIN /=0 .AND. ZIFIN/=-1) ZLATLON(4)=zifin*1000.
+
+ ILATLON(:)=ZLATLON(:)
+
+ IF (ILATLON(1)> ZLATLON(1)) ILATLON(1)=ILATLON(1)-1
+ IF (ILATLON(2)< ZLATLON(2)) ILATLON(2)=ILATLON(2)+1
+ IF (ILATLON(3)< ZLATLON(3)) ILATLON(3)=ILATLON(3)+1
+ IF (ILATLON(4)> ZLATLON(4)) ILATLON(4)=ILATLON(4)-1
+
+ ZLATLON=ILATLON
+ IF (CFIXRESOL=="y") THEN
+ INX=(ZLATLON(4)-ZLATLON(3))/ZDX_GRB +1
+ INY=(ZLATLON(1)-ZLATLON(2))/ZDY_GRB +1
+ ZCONTROL=ZLATLON(3)+(INX-1)*ZDX_GRB
+ IF (ZCONTROL/=ZLATLON(4)) THEN
+ print*,"warning : need to change E longitude"
+ ZLATLON(4)=ZCONTROL
+ print*,"lon min" ,ZLATLON(3)
+ print*,"lon max" ,ZLATLON(4)
+ print*,"dx",ZDX_GRB
+ ENDIF
+ ZCONTROL=ZLATLON(2)+(INY-1)*ZDY_GRB
+ IF (ZCONTROL/=ZLATLON(1)) THEN
+ print*,"warning : need to change N latitude"
+ ZLATLON(1)=ZCONTROL
+ print*,"lat min" ,ZLATLON(2)
+ print*,"lat max" ,ZLATLON(1)
+ print*,"dy",ZDY_GRB
+ ENDIF
+ print*,INX,INY,ZLATLON,ZDX_GRB,ZDY_GRB
+ ELSE
+ CALL INI2LALO(ZLATLON,INX,INY)
+ ENDIF
+ ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+ size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+ ZVARSAVE=XVAR
+ ALLOCATE(ZWORK3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ALLOCATE(ZVARZCST(INX,INY,size(XVAR,3)))
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(INX,INY,SIZE(ZVARSAVE,3),&
+ size(ZVARSAVE,4),size(ZVARSAVE,5),size(ZVARSAVE,6)))
+
+ DO J6=ivarprocinf,ivarprocsup
+ DO J5=ivartrajinf,ivartrajsup
+ DO J4=ivartinf,ivartsup
+ ZWORK3D(:,:,:)=ZVARSAVE(:,:,:,J4,J5,J6)
+ CALL INT2LALO('BILI',ZWORK3D,ZLATLON,XSPVAL,ZVARZCST)
+ XVAR(:,:,:,J4,J5,J6)=ZVARZCST
+ END DO
+ END DO
+ END DO
+ DEALLOCATE(ZVARSAVE,ZVARZCST,ZWORK3D)
+ ENDIF
+ print*," ZLATLON apres INT2lalo",ZLATLON
+ ! d. ecriture des donnees au format GRIB
+ IF ( YOUTGRID(1:4) == 'LALO' ) THEN
+ IF ( IFLAGzcst /= 1 ) THEN
+ ivarideb=1
+ ivarifin=SIZE(XVAR,1)
+ ivarjdeb=1
+ ivarjfin=SIZE(XVAR,2)
+ ENDIF
+ IF (LLEVEL2D) THEN
+ CALL WRITEGRIB(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YOUTGRID,YTYPEOUT,&
+ ilocverbia,iret,ICODCOD,&
+ zlistevert,LVAR2D,KLEVEL2D=ILEVEL2D,PLATLON=ZLATLON)
+ ELSE
+ CALL WRITEGRIB(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YOUTGRID,YTYPEOUT,&
+ ilocverbia,iret,ICODCOD,&
+ zlistevert,LVAR2D,PLATLON=ZLATLON)
+ ENDIF
+ if (ilocverbia > 0 ) then
+ print*,'WRITEGRIB LALO return= ', YTYPEOUT,'= ',iret
+ end if
+ ELSE ! pas d interpolation horizontale (CONF)
+ IF (LCARTESIAN) THEN
+ PRINT*,"===================================="
+ PRINT*,"WARNING : WITH LCARTESIAN=TRUE PLEASE ASK LALO"
+ PRINT*,"===================================="
+ STOP
+ ENDIF
+ IF (LLEVEL2D) THEN
+ CALL WRITEGRIB(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YOUTGRID,YTYPEOUT,&
+ ilocverbia,iret,ICODCOD,zlistevert,LVAR2D,KLEVEL2D=ILEVEL2D)
+ ELSE
+ CALL WRITEGRIB(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YOUTGRID,YTYPEOUT,&
+ ilocverbia,iret,ICODCOD,zlistevert,LVAR2D)
+ ENDIF
+ if (ilocverbia > 0 ) then
+ print*,'WRITEGRIB CONF return= ', YTYPEOUT,'= ',iret
+ end if
+ ENDIF
+ ! retour a XZZ pour NGRID a 4 (cf readvar)
+ CALL COMPCOORD_FORDIACHRO(4)
+ END SELECT
+ ! indiquera aux routines d ecriture que le fichier courant est deja ouvert
+ YFLAGWRITE='OLD'
+ !
+ ELSE ! iret /=0
+ print *, ' READVAR return= ',iret
+ ENDIF
+END DO ! boucle champ a traiter
+!
+!
+!---------------------------------------------------------------------------
+!
+!* 4. CLOSURE OF OUTPUT FILE
+! ----------------------
+!
+!pour clore le traitement meme si la liste des champs est non terminee par END
+88 CONTINUE
+!
+IF (ALLOCATED(ZNEWX)) DEALLOCATE(ZNEWX,ZNEWY)
+IF (ALLOCATED(ZNEWLAT)) DEALLOCATE(ZNEWLAT,ZNEWLON)
+IF (ALLOCATED(ZWORK2D)) DEALLOCATE(ZWORK2D,ZWORK2D2)
+!
+PRINT*, 'END -> Close the output file'
+YFLAGWRITE='CLO'
+SELECT CASE(YTYPEOUT(1:4))
+ CASE('DIAC')
+ CALL WRITEVAR(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ CGROUP,YFILEIN,YFLAGWRITE,'2 ',ilocverbia,iret)
+ CASE('LLHV','llhv','LLZV','llzv','LLPV','llpv','LLAV','llav',&
+ 'IJHV','IJZV','IJPV','jihv','jizv','jipv')
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YTYPEOUT,ilocverbia,iret)
+ CASE('KCDL','ZCDL','PCDL')
+ CALL WRITECDL(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YOUTGRID,YSUFFIX_file, &
+ ilocverbia,iret,PGRIDX=XXX(:,IGRID),PGRIDY=XXY(:,IGRID))
+ CASE('ZGRB','PGRB','AGRB')
+ CALL WRITEGRIB(ivarideb,ivarifin,ivarjdeb,ivarjfin, &
+ ivarkdeb,ivarkfin,ivartinf,ivartsup, &
+ ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YOUTGRID,YTYPEOUT,&
+ ilocverbia,iret,ICODCOD,zlistevert,LVAR2D)
+ CASE DEFAULT
+ PRINT*, 'Closure of output type ',YTYPEOUT ,' not coded'
+END SELECT
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. END
+! ---
+!
+99 CONTINUE
+PRINT*, 'Delete the links if necessary'
+YDUMMYFILE=''
+CALL CREATLINK(' ',YDUMMYFILE,'CLEAN',ILOCVERBIA)
+PRINT*, 'The file ',TRIM(YLUDIR),' stores all the input directives '
+PRINT*, ' you must give a new name to use it again'
+CLOSE(ILUDIR)
+!
+!-------------------------------------------------------------------------------
+!
+CONTAINS
+!
+!------------------------------------------------------------------------------
+!
+SUBROUTINE TAB2SPACE(HTEXT)
+IMPLICIT NONE
+CHARACTER(len=*),INTENT(INOUT) :: HTEXT
+
+CHARACTER, PARAMETER :: YPTAB = CHAR(9) ! TAB character is ASCII : 9
+CHARACTER, PARAMETER :: YPCOM = CHAR(44)! COMma character is ASCII : 44
+INTEGER :: JI
+
+DO JI=1,LEN_TRIM(HTEXT)
+ IF (HTEXT(JI:JI)==YPTAB .OR. HTEXT(JI:JI)==YPCOM) HTEXT(JI:JI) = ' '
+END DO
+END SUBROUTINE TAB2SPACE
+!------------------------------------------------------------------------------
+
+END PROGRAM EXTRACTDIA
+!
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/ff.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/ff.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3de85bdb65edf5b89e1d17f6673dcb72b2ecf0e5
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/ff.f90
@@ -0,0 +1,105 @@
+! ############################################################
+ MODULE MODI_FF
+! ############################################################
+!
+INTERFACE
+ SUBROUTINE FF(PU,PV,PFFVENT,KVEXT,KHEXT,KGRID)
+!
+REAL, INTENT(IN), DIMENSION (:,:,:) :: PU,PV ! composantes u et V
+INTEGER, INTENT(IN) :: KVEXT,KHEXT ! points a exclure
+REAL, INTENT(INOUT), DIMENSION (:,:,:) :: PFFVENT ! module vent
+INTEGER, INTENT(IN) :: KGRID ! grille des champs PU,PV
+!
+END SUBROUTINE FF
+END INTERFACE
+END MODULE MODI_FF
+!
+!------------------------------------------------------------------------------
+!
+
+! ################
+ SUBROUTINE FF(PU,PV,PFFVENT,KVEXT,KHEXT,KGRID)
+! ################
+!
+!!**** *FF* -
+!!
+!!
+!! PURPOSE
+!! -------
+! calcul du module du vent
+!
+!!** METHOD
+!!
+!! AUTHORS
+!! -------
+!! N. Asencio * CNRM*
+!!
+!! Copyright 2003, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODN_NCAR, ONLY: XSPVAL
+!
+IMPLICIT NONE
+!
+!* 0.1 Arguments d'appel
+!
+REAL, INTENT(IN), DIMENSION (:,:,:) :: PU,PV ! composantes u et V
+INTEGER, INTENT(IN) :: KVEXT,KHEXT ! points a exclure
+REAL, INTENT(INOUT), DIMENSION (:,:,:) :: PFFVENT ! module vent
+INTEGER, INTENT(IN) :: KGRID ! grille des champs PU,PV
+!
+!* 0.2 variables locales
+!
+INTEGER :: JI,JJ,JK ! loop indexes
+INTEGER :: JK1,JK2
+!
+!-------------------------------------------------------------------------------
+!
+IF (SIZE(PU,3) == 1) THEN
+ JK1=1
+ JK2=1
+ELSE
+ JK1=1+KVEXT
+ JK2=SIZE(PU,3)-KVEXT
+ENDIF
+IF (KGRID == 1 ) THEN
+ ! les 2 composantes sont au point de masse UM10,VM10 ou colocalisées
+ ! apres interpolation horizontale
+ DO JK=JK1,JK2
+ DO JJ=1+KHEXT,SIZE(PU,2)-KHEXT
+ DO JI=1+KHEXT,SIZE(PU,1)-KHEXT
+ ! calcul de la force du vent
+ IF ( PU(JI,JJ,JK) /= XSPVAL .AND. PV(JI,JJ,JK) /= XSPVAL) then
+ PFFVENT(JI,JJ,JK)=sqrt( PU(JI,JJ,JK)**2+ PV(JI,JJ,JK)**2 )
+ ELSE
+ PFFVENT(JI,JJ,JK)=XSPVAL
+ ENDIF
+ end DO
+ end DO
+ end DO
+ELSE
+ ! les 2 composantes sont dans les grilles U et V Mesonh
+ DO JK=JK1,JK2
+ DO JJ=1+KHEXT,SIZE(PU,2)-KHEXT
+ DO JI=1+KHEXT,SIZE(PU,1)-KHEXT
+ ! calcul de la force du vent
+ IF (PU(JI,JJ,JK) /= XSPVAL .AND. PU(JI+1,JJ,JK) /= XSPVAL &
+ .AND. PV(JI,JJ,JK) /= XSPVAL .AND. PV(JI,JJ+1,JK) /= XSPVAL) then
+ PFFVENT(JI,JJ,JK) = sqrt(0.25*(PU(JI,JJ,JK)+PU(JI+1,JJ,JK))**2+ &
+ 0.25*(PV(JI,JJ,JK)+PV(JI,JJ+1,JK))**2 )
+ ELSE
+ PFFVENT(JI,JJ,JK) = XSPVAL
+ ENDIF
+ end DO
+ end DO
+ end DO
+ENDIF
+!
+END SUBROUTINE FF
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/from_computing_units.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/from_computing_units.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5ded067d5b30973d37afda26a5b73dd41f01bf24
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/from_computing_units.f90
@@ -0,0 +1,98 @@
+! ############################################################
+ MODULE MODI_FROM_COMPUTING_UNITS
+! ############################################################
+!
+INTERFACE
+ SUBROUTINE FROM_COMPUTING_UNITS(HCHAMP,HUNITS)
+!
+CHARACTER(LEN=*) , intent(in) :: HCHAMP ! Nom du champ
+CHARACTER(LEN=*) , intent(inout) :: HUNITS ! Unite
+!
+END SUBROUTINE FROM_COMPUTING_UNITS
+END INTERFACE
+END MODULE MODI_FROM_COMPUTING_UNITS
+!
+!------------------------------------------------------------------------------
+!
+! ################
+ SUBROUTINE FROM_COMPUTING_UNITS(HCHAMP,HUNITS)
+! ################
+!
+!!**** *FROM_COMPUTING_UNITS* -
+!!
+!!
+!! PURPOSE
+!! -------
+! Retour vers l'unite initiale apres un passage a une unite adaptee au calcul
+! dans la routine To_Computing_Units(YCHAMP,CUNIT)
+!
+!!** METHOD
+! mettre a jour suivant les variables Mesonh qui necessitent ce passage
+! AU 01/2005 : les reflectivités radarexprimees en dBz
+! les temperatures de brillance
+!!
+!! AUTHORS
+!! -------
+!! N. Asencio * CNRM*
+!!
+!! Copyright 2003, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 25/01/2005 (N. Asencio)
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS, ONLY:XUNDEF
+USE MODD_ALLOC_FORDIACHRO, ONLY: XVAR
+IMPLICIT NONE
+!
+!* 0.1 Arguments d'appel
+!
+CHARACTER(LEN=*) , intent(in) :: HCHAMP ! Nom du champ
+CHARACTER(LEN=*) , intent(inout) :: HUNITS ! Unite
+!
+!* 0.2 variables locales
+!
+!
+!-------------------------------------------------------------------------------
+!
+!print *,'entree FROM_COMPUTING_UNITS ',TRIM(HCHAMP),' ',TRIM(HUNITS)
+!
+!
+! Critère= Unite modifiee dans To_Computing_Units
+!
+SELECT CASE (HUNITS)
+ CASE ('Ze_to_DBZ','Ze_listOBS')
+ ! Reflectivités radar
+ WHERE ( XVAR <= 0. ) XVAR=XUNDEF
+ WHERE ( XVAR /= XUNDEF ) XVAR=10*alog10(XVAR)
+ ! Retour a l unite initiale
+ HUNITS='dBZ'
+ print *,'**** FROM_COMPUTING_UNITS:Passage Ze a DBZ avant ecriture ****'
+ CASE ('W_to_C')
+ ! finir les modd voulus et utiliser cet appel
+ ! Mesonh
+ ! passage rad -> temp brillance pour le satellite KGEO
+ ! call MAKE_RADSAT(KYEARF, KMONTHF, KDAYF, PSECF, &
+ ! KGEO, KLON, PRADB, PRADF)
+ ! Viviane
+ !ZOBS est en radiance, je la transforme en tempe de brillance
+ ! IF (ZRADMOY > 0. .AND. (ALOG(ZRADMOY)-PCOEFA) /= 0. ) THEN
+ ! ZOBS(JILOOP,JJLOOP)=PCOEFB/(ALOG(ZRADMOY)-PCOEFA)
+
+
+ !WHERE ( XVAR /= XUNDEF .AND. XVAR > 0. .AND. (ALOG(XVAR)-PCOEFA) /= 0.) &
+ !XVAR=PCOEFB/(ALOG(XVAR)-PCOEFA)
+ XVAR=XVAR
+ ! Retour à l unité initiale
+ HUNITS='C'
+ print *,'****FROM_COMPUTING_UNITS:Passage Radiance vers Temperature de Brillance avant ecriture ****'
+ print *, ' Ce passage est inactif pour l instant'
+
+END SELECT
+!
+END SUBROUTINE FROM_COMPUTING_UNITS
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/ini2lalo.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/ini2lalo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..dbeabfb27632e73459082252fc927b59f99e59da
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/ini2lalo.f90
@@ -0,0 +1,172 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:./s.ini2lalo.f90, Version:1.5, Date:03/06/05, Last modified:01/10/23
+!-----------------------------------------------------------------
+! ######spl
+MODULE MODI_INI2LALO
+!###################
+!
+INTERFACE
+ SUBROUTINE INI2LALO(PLATLON,KNX,KNY, &
+ KIDEB,KIFIN,KJDEB,KJFIN,PDLON,PDLAT)
+!
+REAL, DIMENSION(4), INTENT(INOUT) :: PLATLON ! NSWE target domain bounds (deg)
+INTEGER, INTENT(OUT) :: KNX,KNY ! NUMBER OF TARGET POINTS IN X,Y
+INTEGER, INTENT(IN), OPTIONAL :: KIDEB,KIFIN ! limites du
+INTEGER, INTENT(IN), OPTIONAL :: KJDEB,KJFIN !zoom eventuel
+REAL, INTENT(OUT),OPTIONAL :: PDLON,PDLAT ! resolutions in LOn-LAt computed
+!
+END SUBROUTINE INI2LALO
+END INTERFACE
+END MODULE MODI_INI2LALO
+! ########################################################
+ SUBROUTINE INI2LALO(PLATLON,KNX,KNY, &
+ KIDEB,KIFIN,KJDEB,KJFIN,PDLON,PDLAT)
+! ########################################################
+!
+!! PURPOSE
+!! -------
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CST, ONLY : XRADIUS,XPI
+USE MODD_PARAMETERS, ONLY : JPHEXT
+USE MODD_GRID, ONLY : XLAT0,XLATORI,XLONORI
+USE MODD_DIM1, ONLY : NIMAX,NJMAX
+USE MODD_GRID1, ONLY : XLAT,XMAP,XXHAT,XYHAT
+!
+USE MODE_GRIDPROJ
+!
+IMPLICIT NONE
+!
+!* 0.1 Arguments
+!
+REAL, DIMENSION(4), INTENT(INOUT) :: PLATLON ! NSWE target domain bounds (millideg)
+INTEGER, INTENT(OUT) :: KNX,KNY ! nb of target points
+INTEGER, INTENT(IN), OPTIONAL :: KIDEB,KIFIN ! limites du
+INTEGER, INTENT(IN), OPTIONAL :: KJDEB,KJFIN !zoom eventuel
+REAL , INTENT(OUT),OPTIONAL :: PDLON,PDLAT ! resolutions in LOn-LAt computed
+!
+!* 0.2 Local variables
+!
+REAL :: ZLONW,ZLONE,ZLATN,ZLATS ! LAT/LON rounded to nearest millidegree
+REAL :: ZDX,ZDY ! increments in LAT/LON
+REAL :: ZLATM ! extreme latitude of input domain
+REAL :: ZLA,ZLO,ZI,ZJ,ZXHAT,ZYHAT
+INTEGER, DIMENSION(2) :: IMAP
+INTEGER :: II,IJ,IIN
+INTEGER :: JX,JY
+!
+!------------------------------------------------------------------------------
+!
+!* 1. CHECK Lat/Lon DOMAIN
+! --------------------
+!
+ZLATN=PLATLON(1) ; ZLATS=PLATLON(2)
+ZLONW=PLATLON(3) ; ZLONE=PLATLON(4)
+!
+! round to nearest millidegree, longitudes in (0..360) interval
+ZLATN=REAL(NINT(ZLATN))
+ZLATS=REAL(NINT(ZLATS))
+ZLONW=MOD(ZLONW,360000.) ; ZLONE=MOD(ZLONE,360000.)
+ZLONW=REAL(NINT(ZLONW))
+ZLONE=REAL(NINT(ZLONE))
+PLATLON(1)=ZLATN
+PLATLON(2)=ZLATS
+PLATLON(3)=ZLONW
+PLATLON(4)=ZLONE
+!
+! check if domain is well-defined
+IF(ABS(ZLATN)>90000.) THEN
+ PRINT*, 'INI2LALO: Bad N latitude - abort: ZLATN=',ZLATN
+ STOP
+END IF
+IF(ABS(ZLATS)>90000) THEN
+ PRINT*, 'INI2LALO: Bad S latitude - abort: ZLATS=',ZLATS
+ STOP
+END IF
+IF(ZLATN<=ZLATS) THEN
+ PRINT*, 'Bad latitude interval - abort'
+ STOP
+END IF
+!
+! compute optimum resolution
+IF (PRESENT(KIDEB)) THEN
+ IMAP=MINLOC(XMAP(KIDEB:KIFIN,KJDEB:KJFIN))
+ELSE
+ IMAP=MINLOC(XMAP(:,:))
+END IF
+ZLATM=XLAT(IMAP(1),IMAP(2))
+ZDX=(XXHAT(3)-XXHAT(2))*180./XPI&
+ /(XRADIUS*COS(ZLATM*XPI/180.))
+ZDY=(XYHAT(3)-XYHAT(2))*180./XPI/XRADIUS
+print*, 'INI2LALO: equivalent resolution in lat ',ZLATM,IMAP
+print*, ' ',ZDX,ZDY
+WRITE(6,'(A,I4,1X,I4,A,F6.1,A)')'INI2LALO: point where map scale is minimum ', &
+ IMAP,' (lat ',ZLATM,')'
+PRINT*,'equivalent resolution in lon. and lat.: ' ,ZDX,ZDY
+!
+! compute number of points and
+! move E & S boundaries so that lon/lat increments are in millidegrees
+! (GRIB constraint)
+KNX=NINT( (ZLONE-ZLONW)/(1000*ZDX) +1)
+IF(KNX<0) KNX=NINT( (ZLONE-ZLONW+360000.)/(1000*ZDX) +1)
+IF(ZDX/=REAL(NINT(ZDX*1000.))/1000.) THEN ! need to fix longitude
+ ZDX=REAL(NINT(ZDX*1000.))
+ ZLONE=ZLONW+(KNX-1)*ZDX
+ IF(ZLONE>360000.) ZLONE=ZLONE-360000.
+ print*, 'INI2LALO: fixing E longitude to ',ZLONE
+ PLATLON(4)=ZLONE
+ ZDX=ZDX/1000.
+ENDIF
+!
+KNY=NINT( (ZLATN-ZLATS)/(1000*ZDY) +1)
+IF(ZDY/=REAL(NINT(ZDY*1000.))/1000.) THEN ! need to fix latitude
+ ZDY=REAL(NINT(ZDY*1000.))
+ ZLATS=ZLATN-(KNY-1)*ZDY
+ IF(ABS(ZLATS)>90000.) THEN
+ STOP "TOO BIG DOMAIN in LATITUDE"
+ END IF
+ print*, 'INI2LALO: fixing S latitude to ',ZLATS
+ PLATLON(2)=ZLATS
+ ZDY=ZDY/1000.
+ENDIF
+!
+IF(PRESENT(PDLON))THEN
+ PDLON=ZDX
+ PDLAT=ZDY
+END IF
+!
+print*, 'INI2LALO: number of points in lon. and lat. domain:', KNX,KNY
+IF (PRESENT(KIDEB)) THEN
+ PRINT*, 'number of points of input domain (i,j,i*j): ',(KIFIN-KIDEB+1),&
+ (KJFIN-KJDEB+1),(KIFIN-KIDEB+1)*(KJFIN-KJDEB+1)
+ELSE
+ PRINT*, 'number of points of input domain (i,j,i*j): ',NIMAX,NJMAX,NIMAX*NJMAX
+END IF
+PRINT*, 'number of points of lon.-lat. domain(x,y,x*y):', KNX,KNY,KNX*KNY
+!
+! check if target domain is inside file domain
+IIN=0
+DO JY=1,KNY ; DO JX=1,KNX
+ ZLO=MOD(ZLONW/1000.+ZDX*(JX-1),360.)
+ ZLA=ZLATN/1000.-ZDY*(JY-1) ! output has N->S scanning
+ CALL SM_XYHAT(XLATORI,XLONORI,ZLA,ZLO,ZXHAT,ZYHAT)
+ II=MAX(MIN(COUNT(XXHAT(:)<ZXHAT),NIMAX+JPHEXT),1+JPHEXT)
+ IJ=MAX(MIN(COUNT(XYHAT(:)<ZYHAT),NJMAX+JPHEXT),1+JPHEXT)
+ ZI=(ZXHAT-XXHAT(II))/(XXHAT(II+1)-XXHAT(II))+FLOAT(II)-1
+ ZJ=(ZYHAT-XYHAT(IJ))/(XYHAT(IJ+1)-XYHAT(IJ))+FLOAT(IJ)-1
+ !
+ IF ( (ZI>=1.) .AND. (ZI<=NIMAX) &
+ .AND. (ZJ>=1.) .AND. (ZJ<=NJMAX) ) THEN
+ IIN=IIN+1 ! points inside
+ ENDIF
+END DO ; END DO
+PRINT*, 'number of points of lon.-lat. domain inside input file one:', IIN
+!
+!
+END SUBROUTINE INI2LALO
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/int2lalo.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/int2lalo.f90
new file mode 100644
index 0000000000000000000000000000000000000000..49e837e20b0b3d0e99ec689e23d3e2bedc2fa828
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/int2lalo.f90
@@ -0,0 +1,175 @@
+!----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:./s.int2lalo.f90, Version:1.8, Date:03/06/05, Last modified:01/10/15
+!-----------------------------------------------------------------
+! ######spl
+MODULE MODI_INT2LALO
+!###################
+!
+INTERFACE
+ SUBROUTINE INT2LALO(HHORTYPE,P3D,PLATLON,PSVAL,PLALO)
+!
+CHARACTER(LEN=4), INTENT(IN) :: HHORTYPE ! type of horizontal interpolation
+REAL,DIMENSION(:,:,:),INTENT(IN) :: P3D ! input 3d array s->n, w->e
+REAL,DIMENSION(4), INTENT(IN) :: PLATLON ! NSWE target domain bounds (milliDEGS)
+REAL, INTENT(IN) :: PSVAL ! value for missing data
+REAL,DIMENSION(:,:,:),INTENT(OUT):: PLALO ! output interpolated LAT/LON field
+!
+END SUBROUTINE INT2LALO
+END INTERFACE
+END MODULE MODI_INT2LALO
+!
+!####################################################
+SUBROUTINE INT2LALO(HHORTYPE,P3D,PLATLON,PSVAL,PLALO)
+!####################################################
+!
+!! PURPOSE
+!! -------
+! Interpolates data from a conformal grid to a lat/lon grid
+!
+!!** METHOD
+!! ------
+!! Input is the conformal data (S->N scanning) and lat/lon domain
+!! definition.
+!! Output is the lat/lon data in N->S scanning (required).
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CST, ONLY : XRADIUS,XPI
+USE MODD_GRID, ONLY : XLONORI,XLATORI
+USE MODD_PARAMETERS, ONLY : XUNDEF,JPHEXT
+USE MODD_DIM1, ONLY : NIMAX,NJMAX,NKMAX
+USE MODD_GRID1, ONLY : XXHAT,XYHAT
+!
+USE MODE_GRIDPROJ
+!
+IMPLICIT NONE
+!
+!* 0.1 Arguments
+!
+CHARACTER(LEN=4), INTENT(IN) :: HHORTYPE ! type of horizontal interpolation
+REAL,DIMENSION(:,:,:),INTENT(IN) :: P3D ! input 3d array s->n, w->e
+REAL,DIMENSION(4), INTENT(IN) :: PLATLON ! NSWE target domain bounds (milliDEGS)
+REAL, INTENT(IN) :: PSVAL ! value for missing data
+REAL,DIMENSION(:,:,:),INTENT(OUT):: PLALO ! output interpolated LAT/LON field
+ !with N->S scanning
+!
+!* 0.2 Local variables
+!
+REAL :: ZLONW,ZLONE,ZLATN,ZLATS !(degres)
+REAL :: ZXHAT,ZYHAT
+REAL :: ZDX,ZDY ! TARGET INCREMENTS IN LAT/LON
+REAL :: ZLA,ZLO,ZAB,ZCD,ZI,ZJ,ZXR,ZYR
+REAL :: ZEPS
+INTEGER :: JX,JY,JK,INX,INY,II,IJ,IK,IM,IN
+!
+!------------------------------------------------------------------------------
+!
+!* 1. INITIALISATION
+! --------------
+!
+ZEPS=1.E-10
+PLALO(:,:,:)= PSVAL
+INX=SIZE(PLALO,1) ; INY=SIZE(PLALO,2) ; IK=SIZE(PLALO,3)
+ZLONW=PLATLON(3)/1000. ; ZLONE=PLATLON(4)/1000. ; ZLATN=PLATLON(1)/1000. ; ZLATS=PLATLON(2)/1000.
+!
+ZDX=(ZLONE-ZLONW)/(INX-1)
+IF (ZDX<0) ZDX=(ZLONE-ZLONW+360.)/(INX-1)
+ZDY=(ZLATN-ZLATS)/(INY-1)
+print*, 'INT2LALO: target increments:',ZDX,ZDY
+PRINT*, 'INT2LALO: target increments:',ZDX,ZDY
+!
+!------------------------------------------------------------------------------
+!
+!* 2. INTERPOLATION
+! -------------
+!
+!print*,'av interp.: ',minval(P3D),minloc(p3d),maxval(p3d),maxloc(p3d)
+DO JK=1,IK
+ DO JY=1,INY ; DO JX=1,INX
+ ZLO=MOD(ZLONW+ZDX*(JX-1),360.)
+ ZLA=ZLATN-ZDY*(JY-1) ! output has N->S scanning
+ ! print*,ZLO,ZLA,JX,JY
+ CALL SM_XYHAT(XLATORI,XLONORI,ZLA,ZLO,ZXHAT,ZYHAT)
+ II=MAX(MIN(COUNT(XXHAT(:)<ZXHAT),NIMAX+JPHEXT),1+JPHEXT)
+ IJ=MAX(MIN(COUNT(XYHAT(:)<ZYHAT),NJMAX+JPHEXT),1+JPHEXT)
+ ZI=(ZXHAT-XXHAT(II))/(XXHAT(II+1)-XXHAT(II))+FLOAT(II)
+ ZJ=(ZYHAT-XYHAT(IJ))/(XYHAT(IJ+1)-XYHAT(IJ))+FLOAT(IJ)
+ !
+!!!!!!!!!!!!!!! PLUSE DE DECALAGE D INDICES ENTRE P3D ET LE TABLEAUX MNH!!!!!!!!!
+ IM=II
+ IN=IJ
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ IF (HHORTYPE=='NEAR') THEN
+ ! NEARest neighbour method on conformal plane
+ IF ( (II>=1+JPHEXT) .AND. (II<=NIMAX+JPHEXT) &
+ .AND. (IJ>=1+JPHEXT) .AND. (IJ<=NJMAX+JPHEXT) ) THEN
+ PLALO(JX,JY,JK)=P3D(IM,IN,JK) ! take nearest-neighbour value
+ ENDIF
+ !
+ ELSEIF (HHORTYPE == 'BILI') THEN
+ ! LInear interpolation method on conformal plane
+ IF ( (ZI>=1+JPHEXT) .AND. (ZI<=NIMAX+JPHEXT) &
+ .AND. (ZJ>=1+JPHEXT) .AND. (ZJ<=NJMAX+JPHEXT) ) THEN
+ IF (ALL(ABS(P3D(IM:IM+1,IN:IN+1,JK)-XUNDEF)>=ZEPS) ) THEN
+ ! take the 4 surrounding values and apply bilinear interpolation
+ ZXR=ZI-REAL(II) ; ZYR=ZJ-REAL(IJ) ! coordinates inside rectangle
+ ZAB= (1.-ZXR)*P3D(IM, IN, JK) &
+ + ZXR *P3D(IM+1,IN, JK)
+ ZCD= (1.-ZXR)*P3D(IM, IN+1,JK) &
+ + ZXR *P3D(IM+1,IN+1,JK)
+ PLALO(JX,JY,JK)= (1.-ZYR)*ZAB + ZYR*ZCD
+ ENDIF
+ ENDIF
+ ELSE
+ print*, 'Horizontal type interpolation unknown ',HHORTYPE
+ ENDIF
+ ENDDO ; ENDDO
+ENDDO
+!
+!------------------------------------------------------------------------------
+!
+!* 3. EXTENSION
+! ---------
+!
+!IF (IK/=1) CALL EXTENDLAM
+!print*,'ap interp.: ',minval(Plalo),minloc(plalo),maxval(plalo),maxloc(plalo)
+!
+RETURN
+CONTAINS
+!-----------------------------
+SUBROUTINE EXTENDLAM
+! PURPOSE: EXTEND AN INTERPOLATED LAT/LON FIELD OUTSIDE THE kAl MODEL
+! DOMAIN BY REMOVING ALL ITS UNDEFINED VALUES.
+! METHOD: REPLACED ALL UNDEFINED VALUES BY AVERAGE OF DEFINED VALUES.
+!
+REAL ZS
+INTEGER IPOP,JI,JJ,JK
+!
+! COMPUTE AVERAGE OF DEFINED VALUES
+ZS=0. ; IPOP=0
+DO JK=1,IK
+ DO JJ=1,INY ; DO JI=1,INX
+ IF(PLALO(JI,JJ,JK)/=PSVAL)THEN
+ ZS=ZS+PLALO(JI,JJ,JK)
+ IPOP=IPOP+1
+ ENDIF
+ ENDDO ; ENDDO
+ENDDO
+ZS=ZS/(FLOAT(IPOP)+TINY(ZS))
+!
+! Replace ALL UNDEFINED VALUES BY THE AVERAGE
+DO JK=1,IK
+ DO JJ=1,INY ; DO JI=1,INX
+ IF(PLALO(JI,JJ,JK)==PSVAL) PLALO(JI,JJ,JK)=ZS
+ ENDDO ; ENDDO
+ENDDO
+!
+RETURN
+END SUBROUTINE EXTENDLAM
+
+END SUBROUTINE INT2LALO
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/mesonh2obs.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/mesonh2obs.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3ce63ccb334b7f0a4075a998f46dae665aa71b41
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/mesonh2obs.f90
@@ -0,0 +1,911 @@
+ PROGRAM MESONH2OBS
+! ###################
+!
+!!**** *MESONH2OBS* - Interpolation d un champ Mesonh sur les points
+! d'observation donnees en entree
+! en sortie un fichier ascii lon lat alt valeur_interpolee_modele
+!!
+!!
+!! PURPOSE
+!! -------
+!
+! Lecture en entree:
+! d'un fichier ascii contenant les localisations (lon,lat ou lat,lon)
+! d'un fichier diachronique a traiter (boucle sur les fichiers)
+! du champ modèle a interpoler (boucle sur les champs)
+!
+! Ecriture en sortie:
+! d'un fichier au format
+! lon lat alt new_val_modele avec alt=altitude d un niveau de modele
+! ou lat lon alt new_val_modele ou alt=Z constante
+! ou alt=P constante
+!
+!!** METHOD
+!! ------
+! 3.2.a Creation de la grille des obs en X, Y et Z
+! lecture du fichier de localisations
+! (LLHV:lon-lat, LLZV:lon-lat-alt(metres), LLPV:lon-lat-pres(hPa))
+! (llhv:lat-lon, llzv:lat-lon-alt(metres), llpv:lat-lon-pres(hPa)
+! calcul des X et Y correspondants
+! 3.2.b Interpolation verticale du champ (3D) MesoNH (LLZV ou LLPV)
+! 3.2.c Interpolation horizontale sur la grille des obs
+! c1 " " du champ MesoNH
+! c2 " " du tableau de grille vert.
+! (champ 2D ou champ 3D en LLHV)
+! 3.4. Ecriture par writellhv
+!
+!
+!!
+!! EXTERNAL
+!! --------
+!! CREATLINK : a l'ouverture du fichier, HFLAGFILE='OPE',
+!! creation d'un lien dans le directory local
+!! si le fichier existe sous $DIROBS
+!! DD et FF : calcul de dd et ff a partir des composantes U et V
+!! READVAR : lecture d unchamp du fichier diachronique
+!! WRITELLHV : ecriture format lon lat alt val
+!! SYSTEM : renommer le fichier de sortie avec un nom > 28 carateres
+!! zinter : interpolation verticale en Z=cst
+!! pinter : interpolation verticale en P=cst
+!! hor_interp_4pts : interpolation horizontale
+!! SM_XYHAT : creation de la grille des Obs
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHORS
+!! -------
+!! N. Asencio
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 17/09/2003
+! 09/10/2003 use XXX(:,NGRID) et XXY(:,NGRID) for hor_interp4pts
+! and SM_XYHAT calls
+! 04/05/2005 add a control for the min and max of the field before
+! and after interpolation(s)
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+#ifdef NAGf95
+USE F90_UNIX ! for FLUSH
+USE F90_UNIX_PROC ! for SYSTEM
+#endif
+! modules MesoNH
+USE MODD_CST
+USE MODD_PARAMETERS, ONLY:JPHEXT,JPVEXT,XUNDEF
+USE MODD_DIM1, ONLY:NIMAX,NJMAX,NKMAX, NIINF, NISUP ,NJINF,NJSUP
+USE MODD_GRID, ONLY: XLATORI,XLONORI
+USE MODD_GRID1, ONLY: XXHAT,XYHAT,XZZ
+USE MODE_GRIDPROJ ! subroutine SM_XYHAT
+! modules DIACHRO
+USE MODN_NCAR, ONLY: XSPVAL
+USE MODD_COORD
+! XVAR(i,j,k,,,), XMASK,XTRAJ ,XDATIME(16,t)
+! et NGRIDIA , NGRIDIAM ( appel interp_grids)
+USE MODD_ALLOC_FORDIACHRO
+! nverbia, CGROUP
+USE MODD_RESOLVCAR
+!
+! modules tools
+USE MODI_HOR_INTERP_4PTS
+USE MODI_ZINTER
+USE MODI_PINTER
+USE MODI_WRITELLHV
+USE MODI_DD
+USE MODI_FF
+USE MODI_UV_TO_ZONAL_AND_MERID
+USE MODI_CREATLINK
+USE MODI_LOW2UP
+USE MODI_WRITEDIR
+! modules extractdia
+USE MODD_READLH ! domaine initialise par READVAR:
+ !NREADIL,NREADIH, NREADJL,NREADJH,
+ !NREADKL,NREADKH
+!
+IMPLICIT NONE
+!
+!* 0.1 Local variables declarations
+!
+! indices de boucle
+INTEGER :: JILOOP,JLOOPFILE,JGR,JNobsLOOPsite,JNobsLOOPz,JNobsLOOPtriplet
+! zoom suivant les 6 dimensions des champs diachro
+INTEGER :: ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin
+INTEGER :: ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup
+REAL , allocatable, dimension(:,:,:) :: ZVAR3D
+REAL , allocatable, dimension(:,:) :: ZDATIME
+! pour l interpolation horizontale
+REAL , allocatable, dimension(:,:) :: ZOBSLAT,ZOBSLON,ZOBSX,ZOBSY
+REAL , allocatable, dimension(:) :: ZOBSALT
+REAL , allocatable, dimension(:) :: ZOBSLATlu,ZOBSLONlu,ZOBSALTlu
+REAL , allocatable, dimension(:,:,:) :: ZVARNEWH
+! pour l interpolation verticale: zinter
+REAL , allocatable, dimension(:,:,:) :: ZVARZCST
+INTEGER :: ikdebzint ! premier niveau a traiter
+! pour l appel a WRITELLHV
+REAL , allocatable, dimension(:,:,:) :: ZALT
+! calcul dd ff
+REAL , allocatable, dimension(:,:,:) :: zwork3d,zwork3d2,zffvent,zdirvent
+! pour pinter : interpolation a P=cst
+REAL , allocatable, dimension(:,:,:) :: zpabs
+INTEGER :: iskip,IGRID,IGRIDOUT,ILUDIR
+REAL :: zmini,zmaxi
+!
+INTEGER :: iret,iret2,ilocverbia,inbvalxy,idimlonlat,inbvalz,inbvalxyz, &
+ inbvalz3d,inbvalxyz3d
+!! **** la taille des variables caracteres contenant les noms
+!! de fichiers est obligatoirement de 28 ****
+!! pour toutes les routines diachro
+CHARACTER(LEN=28) :: YFILEIN,YFILEIN2,YDUMMYFILE
+CHARACTER(LEN=100):: YFILEOBS, YSAVEFILEOBS
+! **** la longueur du nom ne doit pas depasser 13 car. si le fichier
+! contient des groupes a un seul PROCessus, ou 9 si plusieurs PROCessus ****
+CHARACTER(LEN=13) :: YGROUP
+CHARACTER(LEN=4) :: YTYPEOUT
+CHARACTER(LEN=5) :: YFLAGREADVAR,YFLAGWRITE
+CHARACTER(LEN=9) :: ygrillevert ! type de grille verticale selon
+ ! champ2D/3D et YTYPEOUT
+CHARACTER(LEN=36) :: YFILEOUT
+CHARACTER(LEN=3) :: YREP
+CHARACTER(LEN=100):: ycommand
+CHARACTER(LEN=11) :: YLUDIR ! Name of the dir file
+!-------------------------------------------------------------------------------
+!
+!* 1. Init
+! ----
+!
+YFILEIN2=''
+! active(1) ou desactive(0) les prints de controle dans les routines
+! READVAR et WRITE
+ilocverbia=3
+!
+! dans mesonh Xundef est utilise
+! dans les routines diachro XSPVAL est utilise
+ XSPVAL=XUNDEF
+!
+! ouverture d un fichier dir ou vont s ecrire les entrees clavier
+YLUDIR='dirmnh2obs'
+CALL FMATTR(YLUDIR,YLUDIR,ILUDIR,iret)
+OPEN(UNIT=ILUDIR,FILE=YLUDIR,FORM='FORMATTED')
+!
+!
+PRINT*, '- Format of the output file: '
+PRINT*, ' (and of the input observation file with positions)'
+PRINT*, ' Lon-Lat-Height(MNH)-Value= LLHV'
+PRINT*, ' lat-lon-height(MNH)-value= llhv'
+PRINT*, ' Lon-Lat-Z(m)-Value = LLZV'
+PRINT*, ' lat-lon-Z(m)-value = llzv'
+PRINT*, ' Lon-Lat-P(hPa)-Value = LLPV'
+PRINT*, ' lat-lon-P(hPa)-value = llpv'
+PRINT*, '?'
+READ(5,'(A)')YTYPEOUT
+CALL WRITEDIR(ILUDIR,YTYPEOUT)
+!
+SELECT CASE (YTYPEOUT(1:2)) ! type de coordonnées lon,lat ou lat,lon
+ CASE('LL')
+ PRINT*,'-> positions in the observation file are given in lon lat'
+ CASE('ll')
+ PRINT*,'-> positions in the observation file are given in lat lon'
+END SELECT
+ inbvalz=1
+SELECT CASE (YTYPEOUT(3:3))
+ CASE('Z','z','P','p')
+ PRINT*,'- Are the vertical levels included in the input observation file ?'
+ PRINT*,' Y= format of the obs file=coord1 coord2 level'
+ PRINT*,' N= format of the obs file=coord1 coord2 '
+ PRINT*,' and levels provided interactively '
+ READ(5,'(A)') YREP
+ CALL WRITEDIR(ILUDIR,YREP)
+ YREP=ADJUSTL(YREP)
+ SELECT CASE (YREP(1:1))
+ CASE('O','o','Y','y')
+ inbvalz=0
+ CASE DEFAULT
+ PRINT*, '- Number of vertical levels for the interpolation ', YTYPEOUT(3:3),' ?'
+ READ(5,*) inbvalz
+ CALL WRITEDIR(ILUDIR,inbvalz)
+ PRINT*, '- List of these levels (in meters or in hPa): exemple 500 1500 ?'
+ allocate (ZOBSALTlu(inbvalz))
+ READ(5,*) ZOBSALTlu
+ DO JILOOP=1,inbvalz
+ CALL WRITEDIR(ILUDIR,ZOBSALTlu(JILOOP))
+ END DO
+ PRINT*, ' interpolation for the following levels ',YTYPEOUT(3:3),'='
+ PRINT*, ZOBSALTlu
+ END SELECT
+ CASE('H','h')
+ PRINT*,'-> the vertical levels will be the same as in the model'
+END SELECT
+!
+PRINT*, '- Name of the file which contains the localisation of the obs ?'
+READ(5,'(A)',END=99) YFILEOBS
+CALL WRITEDIR(ILUDIR,YFILEOBS)
+!
+PRINT*, '- Prints : 0= mini 1=mode debug in mesonh2obs'
+PRINT*, ' 3=debug mode in dichro routines'
+PRINT*, '?'
+READ(5,*)ilocverbia
+CALL WRITEDIR(ILUDIR,ilocverbia)
+PRINT*, ' output prints= ',ilocverbia
+IF (ilocverbia >2) nverbia=ilocverbia
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. Boucle sur les fichiers a traiter
+! ---------------------
+DO JLOOPFILE=1,100000
+ !
+ !* 2.1 Lecture Nom de fichier et type de sortie
+ ! ----------------------
+ PRINT*, '- Name of the diachro file (without .lfi) (END to stop) ?'
+ IF (LEN_TRIM(YFILEIN2)/=0) PRINT*, ' other than ',TRIM(YFILEIN2)
+ READ(5,'(A28)',END=99) YFILEIN
+ CALL WRITEDIR(ILUDIR,YFILEIN)
+ IF ( YFILEIN(1:3) == 'END' .OR. YFILEIN(1:3) == 'end' ) GO TO 99
+ !
+ ! indique que le fichier d entree lu doit etre ouvert dans READVAR
+ YFLAGREADVAR='OPE'
+ ! indique que le fichier de sortie doit etre ouvert dans WRITELLHV
+ ! et que l entete sera ecrite uniquement lors de la premiere ecriture
+ YFLAGWRITE='NEW1H'
+ !
+ IF (YTYPEOUT(1:4)=='LLPV' .OR. YTYPEOUT(1:4)=='llpv') THEN
+ CALL READVAR('PABST',YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print *, '- PABST not found, name of the pressure variable ?'
+ read *,YGROUP
+ CALL WRITEDIR(ILUDIR,YGROUP)
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print *,' interpolation at P=cst not possible because PABST and ',TRIM(YGROUP), ' are not available'
+ STOP
+ ENDIF
+ ENDIF
+ ! stockage de ZPABS utilise par pinter
+ ALLOCATE ( ZPABS(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ZPABS(:,:,:)=XVAR(:,:,:,1,1,1)
+ END IF
+ PRINT*, 'Input file: ', TRIM(YFILEIN), ', type of output is: ',YTYPEOUT
+ !
+ NIINF=0
+ NISUP=0
+ NJINF=0
+ NJSUP=0
+ !
+ !* 3. Boucle sur les champs a traiter dans le fichier
+ ! ----------------------
+ !
+ DO JGR=1,10000
+ !
+ PRINT*, '- Name of the group in upper case (13 characters max.)'
+ PRINT*, ' (ex: THT ou DD ou FF ou DD10 ou FF10 )'
+ PRINT*, '(GROUP for the list of groups, END to stop)?'
+ READ(5,'(A13)',END=88) CGROUP
+ CALL WRITEDIR(ILUDIR,CGROUP)
+ CGROUP=ADJUSTL(CGROUP)
+ CALL LOW2UP(CGROUP)
+ IF (CGROUP=='END') GO TO 88
+ IF (CGROUP(1:5)/='GROUP') &
+ PRINT*,'you asked for the following record: ',TRIM(CGROUP)
+ !
+ IGRIDOUT=-1
+ !
+ !* 3.1 Lecture et initialisation de XVAR (MODD_ALLOC_FORDIACHRO)
+ !
+ SELECT CASE (CGROUP(1:2))
+ !
+ CASE('DD','FF','UM','VM','UT','VT')
+ !
+ ! Lecture du champ UM et VM apres traitement de UM (voir en 3.2)
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='UT'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='UT'//CGROUP(3:4)
+ ELSE
+ print*,'** problem with the name of group: ',CGROUP
+ CYCLE
+ ENDIF
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF ( iret /= 0 ) then
+ print *,TRIM(CGROUP),': ',TRIM(YGROUP),' not available'
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='UM'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='UM'//CGROUP(3:4)
+ ENDIF
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret2)
+ IF ( iret2 /= 0 ) then
+ print *,'** no processing for ',TRIM(CGROUP), &
+ ' because UT and ',TRIM(YGROUP),' not available'
+ CYCLE
+ ENDIF
+ iret=iret2
+ ENDIF
+ IGRIDOUT=1 ! le champ DD,FF,UZON ou VMED sera en grille masse
+ !
+ ! 3.1.1 traitement sup du tableau XVAR si DD ou FF ou UM ou VM
+ !
+ ! Allocation des tableaux de stockage de la premiere composante
+ ALLOCATE(zwork3d(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ zwork3d(:,:,:)=XVAR(:,:,:,1,1,1)
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VT'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='VT'//CGROUP(3:4)
+ ENDIF
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ if ( iret /= 0 ) then
+ print *,TRIM(CGROUP),': ',TRIM(YGROUP),' not available'
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VM'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='VM'//CGROUP(3:4)
+ ENDIF
+ CALL READVAR(YGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret2)
+ IF ( iret2 /= 0 ) then
+ print *,'** traitement of ',TRIM(CGROUP), &
+ ' not possible because VT and ',TRIM(YGROUP), &
+ ' are not available'
+ CYCLE
+ ENDIF
+ iret=iret2
+! CYCLE
+ endif
+ ! Allocation des tableaux de calcul
+ ALLOCATE(zffvent(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ ALLOCATE(zdirvent(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ zffvent=XSPVAL
+ zdirvent=XSPVAL
+ !
+ ! Calcul de dd ff
+ !
+ IF (CGROUP(1:2) == 'FF' .OR. CGROUP(1:2) == 'DD') THEN
+ ! call ff (zwork3d,zwork3d2,zffvent,kvext,khext,kgrid)
+ !!CALL FF(zwork3d(:,:,:),XVAR(:,:,:,1,1,1),zffvent,0,0,3)
+ IGRID=NGRIDIA(SIZE(XVAR,6))
+ print *,'avant ff dd:JPVEXT,JPHEXT,IGRID', JPVEXT,JPHEXT,IGRID
+ CALL FF(zwork3d(:,:,:),XVAR(:,:,:,1,1,1),zffvent,JPVEXT,JPHEXT,IGRID)
+ ! tous les points de grille: iskip=1
+ iskip=1
+ ! call dd(zwork3d,zwork3d2,zdirvent,iskip,kgrid,PLON=ZOBSLON)
+ CALL DD(zwork3d(:,:,:),XVAR(:,:,:,1,1,1),zdirvent,iskip,3)
+ print *,' End of computation of dd and ff'
+ !
+ ! Stockage dans le tableau XVAR qui est le tableau ecrit
+ !
+ IF (CGROUP(1:2) == 'FF' ) THEN
+ XVAR(:,:,:,1,1,1)=zffvent
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VENTFF'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='VENT'//CGROUP(3:4)//'FF'
+ ENDIF
+ ELSE IF (CGROUP(1:2) == 'DD') THEN
+ XVAR(:,:,:,1,1,1)=zdirvent
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VENTDD'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='VENT'//CGROUP(3:4)//'DD'
+ ENDIF
+ CUNITE(1)='degrees'
+ ENDIF
+ CGROUP=YGROUP
+ CTITRE(1)=YGROUP
+ NGRIDIA(1)=IGRIDOUT ! dd et ff en grille de masse
+ !
+ ! Calcul des composantes zonale et meridienne
+ !
+ ELSE IF (CGROUP(1:2) == 'UM' .OR. CGROUP(1:2) == 'VM' .OR. &
+ CGROUP(1:2) == 'UT' .OR. CGROUP(1:2) == 'VT' ) THEN
+ CALL UV_TO_ZONAL_AND_MERID(zwork3d(:,:,:), &
+ XVAR(:,:,:,1,1,1), &
+ 23,PZC=zffvent,PMC=zdirvent)
+ IF (CGROUP(1:1) == 'U' ) THEN
+ XVAR(:,:,:,1,1,1)=zffvent(:,:,:)
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='UZON'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='U'//CGROUP(3:4)//'ZON'
+ ENDIF
+ CTITRE(1)='U zonal wind component'
+ ELSE IF (CGROUP(1:1) == 'V' ) THEN
+ XVAR(:,:,:,1,1,1)=zdirvent(:,:,:)
+ IF (LEN(TRIM(CGROUP)) ==2) THEN
+ YGROUP='VMED'
+ ELSE IF (LEN(TRIM(CGROUP)) ==4) THEN
+ YGROUP='V'//CGROUP(3:4)//'MED'
+ END IF
+ CTITRE(1)='V meridian wind component'
+ ENDIF
+ CGROUP=YGROUP
+ NGRIDIA(1)=IGRIDOUT ! UZON et VMED en grille de masse
+ ENDIF
+ DEALLOCATE(zwork3d)
+ DEALLOCATE(zffvent,zdirvent)
+ !
+ CASE default
+ !
+ ! Lecture du champ CGROUP et stockage dans XVAR
+ ! + Initialisation (si YFLAGREADVAR='OPE') des variables
+ ! des modules (cf USE en debut de programme)
+ !
+ CALL READVAR(CGROUP,YFILEIN,YFLAGREADVAR,ilocverbia,iret)
+ IF (CGROUP(1:5)=='GROUP') CYCLE
+ END SELECT
+ !
+ IF ( iret == 0 ) THEN
+ IF(SIZE(NGRIDIA,1)/=1) THEN
+ print *,'** no processing for ',TRIM(CGROUP), &
+ ' because several processus'
+ CYCLE
+ ENDIF
+ IGRID=NGRIDIA(1)
+ IF(IGRIDOUT==-1) IGRIDOUT=NGRIDIA(1)
+ !
+ zmini=MINVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ zmaxi=MAXVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ print * ,' After reading, min,max of the field ',TRIM(CGROUP),'=', zmini,zmaxi
+ if (ilocverbia >= 0 ) then
+ print *,' Size of array read= ',SIZE(XVAR,1),SIZE(XVAR,2),&
+ SIZE(XVAR,3),SIZE(XVAR,4),SIZE(XVAR,5),SIZE(XVAR,6)
+ PRINT*, 'NIINF,NISUP,NJINF,NJSUP', NIINF,NISUP,NJINF,NJSUP
+ endif
+ !
+ IF (NIMAX==1 .AND. NJMAX==1) THEN
+ PRINT *,'** 1D group: use rather extractdia since the observation file will not be taken into account'
+ CYCLE
+ ENDIF
+ !
+ !* 3.2 Traitement du tableau XVAR sur les points lat lon
+ ! --------------------------------------------------
+ !
+ ! 3.2.a Creation de la grille des obs en X et Y et Z
+ !
+ IF ( .NOT. ALLOCATED ( ZOBSX) ) THEN
+ ! creation de la grille des obs en X et Y
+ ! realisee apres la premiere lecture d un champ modele
+ ! pour avoir les tableaux XXX XXY initialises
+ print *,' Creation of the X Y grid of the obs'
+ !
+ ! Lecture des sites lon lat
+ YSAVEFILEOBS=YFILEOBS
+ CALL CREATLINK('DIROBS',YFILEOBS,'CREAT',ilocverbia)
+ OPEN(UNIT=8,FILE=TRIM(ADJUSTL(YFILEOBS)),STATUS='OLD',&
+ FORM='FORMATTED')
+ idimlonlat=SIZE(XVAR,1)*SIZE(XVAR,2)
+ ALLOCATE ( ZOBSLATlu(idimlonlat) )
+ ALLOCATE ( ZOBSLONlu(idimlonlat) )
+ IF (.NOT.ALLOCATED (ZOBSALTlu)) THEN
+ ALLOCATE ( ZOBSALTlu(idimlonlat) )
+ ZOBSALTlu=0.
+ ENDIF
+ inbvalxy=0
+ DO JILOOP=1,idimlonlat
+ SELECT CASE ( YTYPEOUT(1:4))
+ CASE ('LLZV','LLPV')
+ IF ( inbvalz == 0) THEN
+ READ (8,*,END=888) &
+ ZOBSLONlu(JILOOP),ZOBSLATlu(JILOOP),ZOBSALTlu(JILOOP)
+ ELSE
+ ! niveaux vert. deja lus en interactif
+ READ (8,*,END=888) &
+ ZOBSLONlu(JILOOP),ZOBSLATlu(JILOOP)
+ ENDIF
+ CASE ('llzv','llpv')
+ IF ( inbvalz == 0) THEN
+ READ (8,*,END=888) &
+ ZOBSLATlu(JILOOP),ZOBSLONlu(JILOOP),ZOBSALTlu(JILOOP)
+ ELSE
+ ! niveaux vert. deja lus en interactif
+ READ (8,*,END=888) &
+ ZOBSLATlu(JILOOP),ZOBSLONlu(JILOOP)
+ ENDIF
+ CASE ('LLHV')
+ READ (8,*,END=888) &
+ ZOBSLONlu(JILOOP),ZOBSLATlu(JILOOP)
+ inbvalz=SIZE(XVAR,3)
+ CASE ('llhv')
+ READ (8,*,END=888) &
+ ZOBSLATlu(JILOOP),ZOBSLONlu(JILOOP)
+ inbvalz=SIZE(XVAR,3)
+ END SELECT
+ inbvalxy=inbvalxy+1
+ ENDDO
+ print *,' The program can take into account ', idimlonlat,' positions at the maximum'
+ print *,' next values of the file ',TRIM(YFILEOBS) ,' will not be read'
+ 888 CONTINUE
+ print *, ' End of reading of the observations localisation file ',TRIM(YFILEOBS)
+ CALL CREATLINK('DIROBS',YFILEOBS,'CLEAN',ilocverbia)
+ !
+ IF ( inbvalz == 0) THEN
+ ! niveaux vert. lus avec les coordonnees
+ inbvalz=inbvalxy
+ ! nombre de triplets= nombre de valeurs lues
+ inbvalxyz=inbvalxy
+ ELSE
+ ! nombre de triplets= coordonnées lues * niveaux vert. interactifs
+ inbvalxyz=inbvalxy*inbvalz
+ ENDIF
+ print *, ' Number of positions = ', inbvalxy
+ print *, ' Number of vertical levels = ', inbvalz
+ if (ilocverbia >= 4 ) then
+ print *, 'lon, lat read :'
+ print *,ZOBSLONlu,ZOBSLATlu
+ endif
+ !
+ ! preparation des arguments pour SM_XYHAT : tableaux 2D
+ ALLOCATE ( ZOBSLAT(inbvalxy,1), ZOBSLON(inbvalxy,1), ZOBSALT(inbvalz) )
+ ZOBSLAT(1:inbvalxy,1)=ZOBSLATlu(1:inbvalxy)
+ ZOBSLON(1:inbvalxy,1)=ZOBSLONlu(1:inbvalxy)
+ ZOBSALT(1:inbvalz) =ZOBSALTlu(1:inbvalz)
+ DEALLOCATE (ZOBSLATlu,ZOBSLONlu,ZOBSALTlu)
+ ALLOCATE ( ZOBSX(size(ZOBSLAT,1),size(ZOBSLAT,2)) )
+ ALLOCATE ( ZOBSY(size(ZOBSLAT,1),size(ZOBSLAT,2)) )
+ ! les 2 premiers arg. doivent etre XXHAT et XYHAT (pas XXX et XXY)
+ !! peu importe en masdev4_6 car plus utilises..
+ !CALL SM_XYHAT(XXHAT,XYHAT,XLATORI,XLONORI,&
+ !! XXHAT,XYHAT supprimes en masdev4_7
+ CALL SM_XYHAT(XLATORI,XLONORI,&
+ ZOBSLAT,ZOBSLON,ZOBSX,ZOBSY)
+ if (ilocverbia >= 4 ) then
+ ! XXX= XXHAT et XXY=XYHAT pour les 7 grilles
+ print *, ' after SM_XYHAT, old limits X ',XXX(1,IGRID), XXX(SIZE(XVAR,1),IGRID)
+ print *, 'new limits X ',ZOBSX(1,1),ZOBSX(inbvalxy,1)
+ print *, 'old limits Y ',XXY(1,IGRID), XXY(SIZE(XVAR,2),IGRID)
+ print *, 'new limits Y ',ZOBSY(1,1),ZOBSY(inbvalxy,1)
+ DO JILOOP= 1,SIZE(XVAR,1)
+ print *, 'XXHAT ZOBSX ',XXX(JILOOP,IGRID),ZOBSX(JILOOP,1)
+ ENDDO
+ DO JILOOP= 1,SIZE(XVAR,2)
+ print *, 'XYHAT ZOBSY ',XXY(JILOOP,IGRID),ZOBSY(1,JILOOP)
+ ENDDO
+ endif
+ ENDIF ! fin grille ZOBSX deja allouee
+ !
+ ! 777 = debut du traitement du tableau XVAR : utilise si DD ou FF
+ ! pour reprise du traitement sur la deuxieme composante
+777 CONTINUE
+ !
+ ! 3.2.b interpolation selon la verticale du champ Mesonh
+ ! --------------------------------------------------
+ ! cette interpolation verticale est realisee avant tout
+ ! changement de la grille horizontale par l interpolation horizontale
+ IF ( SIZE(XVAR,3)>1 .AND. SIZE(XVAR,2)>1 .AND. SIZE(XVAR,1)>1 ) THEN
+ ! champ 3D
+ IF ( IGRID /=4 ) THEN
+ print * , ' init of the model altitudes XZZ for NGRID=',IGRID
+ ! init de XZZ pour cette grille
+ ! car la routine readvar initialise XZZ pour NGRID=4
+ CALL COMPCOORD_FORDIACHRO(IGRID)
+ ENDIF
+ SELECT CASE ( YTYPEOUT(1:4))
+ CASE ('LLZV','llzv','LLPV','llpv')
+ ! interpolation selon la verticale
+ print*,' Interpolation on ',YTYPEOUT(3:3),'=cst ',inbvalz,' levels'
+ if (ilocverbia >= 1 ) then
+ print *, 'levels= ',ZOBSALT
+ endif
+ ALLOCATE (ZVARZCST(SIZE(XVAR,1),SIZE(XVAR,2),inbvalz))
+ ALLOCATE (ZVAR3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ikdebzint=2
+ ZVAR3D(:,:,:)=XVAR(:,:,:,1,1,1)
+ IF ( YTYPEOUT(1:4)=='LLZV' .OR. YTYPEOUT(1:4)=='llzv' ) THEN
+ CALL ZINTER(ZVAR3D,XZZ,ZVARZCST,ZOBSALT,ikdebzint,XSPVAL)
+ ELSE IF ( YTYPEOUT(1:4)=='LLPV' .OR. YTYPEOUT(1:4)=='llpv' ) THEN
+ CALL PINTER(ZVAR3D,IGRID,XSPVAL,ZOBSALT,ZVARZCST,ZPABS)
+ ENDIF
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(SIZE(ZVARZCST,1),SIZE(ZVARZCST,2),SIZE(ZVARZCST,3),1,1,1))
+ XVAR(:,:,:,1,1,1)=ZVARZCST
+ zmini=MINVAL(XVAR(:,:,:,1,1,1),MASK=XVAR(:,:,:,1,1,1)/=XSPVAL)
+ zmaxi=MAXVAL(XVAR(:,:,:,1,1,1),MASK=XVAR(:,:,:,1,1,1)/=XSPVAL)
+ print * ,' After vertical interpolation, min,max of the field ',TRIM(CGROUP),'=', zmini,zmaxi
+ DEALLOCATE(ZVARZCST,ZVAR3D)
+ !
+ ! ZOBSALT = grille verticale, tableau 1D passe en argument a zinter
+ ! mise a jour du tableau 3D ZALT passe en argument de WRITELLHV
+ if ( ALLOCATED(ZALT) ) DEALLOCATE (ZALT)
+ ALLOCATE ( ZALT(1,1,size(ZOBSALT,1)) )
+ ZALT(1,1,:)=ZOBSALT
+ ygrillevert='listevert'
+ !
+ CASE ('LLHV','llhv')
+ ! pas d interpolation verticale (h=grille modele)
+ ygrillevert='XZZ'
+ inbvalz=SIZE(XVAR,3)
+ inbvalxyz=inbvalxy*inbvalz
+ ! l interpolation horizontale sera faite apres l init de
+ ! la nouvelle grille horizontale
+ END SELECT
+ !
+ ELSE
+ ! champ 2D : pas d interpolation verticale
+ ! la grille verticale utilisee est XXZS (i,j,NGRID)
+ ygrillevert='XXZS'
+ inbvalz3d=inbvalz ! sauvegarde du nombre de niveaux verticaux
+ inbvalxyz3d=inbvalxyz ! sauvegarde du nombre de triplets
+ inbvalz=1
+ inbvalxyz=inbvalxy*inbvalz
+ ! l interpolation horizontale sera faite apres l init de
+ ! la nouvelle grille horizontale
+ ENDIF
+ !
+ ! 3.2.c interp. horizontale sur la nouvelle grille XY des obs
+ ! ----------------------------------------------------
+ !
+ ! 3.2.c.1 interpolation horizontale du champ Mesonh
+ !
+ print *,' Interpolation to the new lat-lon grid of the field ',TRIM(CGROUP)
+ ALLOCATE ( ZVAR3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)))
+ ZVAR3D(:,:,:)=XVAR(:,:,:,1,1,1)
+ ALLOCATE ( ZVARNEWH(size(ZOBSX,1),size(ZOBSX,2),SIZE(XVAR,3)) )
+ if (ilocverbia >= 1 ) then
+ print *, ' before HOR_INTERP_4PTS'
+ endif
+ CALL HOR_INTERP_4PTS (XXX(:,IGRID),XXY(:,IGRID),ZVAR3D,ZOBSX,ZOBSY,ZVARNEWH)
+ DEALLOCATE(XVAR)
+ ALLOCATE( XVAR(size(ZVARNEWH,1),size(ZVARNEWH,2),SIZE(ZVARNEWH,3),1,1,1) )
+ XVAR(:,:,:,1,1,1)=ZVARNEWH(:,:,:)
+ DEALLOCATE(ZVARNEWH,ZVAR3D)
+ if (ilocverbia >= 1 ) then
+ print *, ' after HOR_INTERP_4PTS'
+ endif
+ zmini=MINVAL(XVAR(:,:,:,1,1,1),MASK=XVAR(:,:,:,1,1,1)/=XSPVAL)
+ zmaxi=MAXVAL(XVAR(:,:,:,1,1,1),MASK=XVAR(:,:,:,1,1,1)/=XSPVAL)
+ print * ,'after horizontal interpolation, min,max of the field ',TRIM(CGROUP),'=', zmini,zmaxi
+ !
+ ! 3.2.c.2 interpolation horizontale du tableau 3D de grille verticale
+ SELECT CASE (ygrillevert (1:3))
+ CASE ('XXZ') ! champs 2D
+ print *, ' Horizontal interpolation of XXZS for NGRID=',IGRID
+ ALLOCATE ( ZVAR3D(SIZE(XXZS,1),SIZE(XXZS,2),1 ))
+ ZVAR3D(:,:,1)=XXZS(:,:,IGRID)
+ zmini=MINVAL(ZVAR3D(:,:,1),MASK=ZVAR3D(:,:,1)/=XSPVAL)
+ zmaxi=MAXVAL(ZVAR3D(:,:,1),MASK=ZVAR3D(:,:,1)/=XSPVAL)
+ print * ,'min,max of the vertical grid XXZS=', zmini,zmaxi
+ ALLOCATE ( ZVARNEWH(size(ZOBSX,1),size(ZOBSX,2),1) )
+ if (ilocverbia >= 1 ) then
+ print *, ' before HOR_INTERP_4PTS'
+ endif
+ CALL HOR_INTERP_4PTS (XXX(:,IGRID),XXY(:,IGRID),ZVAR3D,ZOBSX,ZOBSY,ZVARNEWH)
+ if ( ALLOCATED(ZALT) ) DEALLOCATE (ZALT)
+ ALLOCATE( ZALT(size(ZVARNEWH,1),size(ZVARNEWH,2),IGRIDOUT) )
+ ZALT(:,:,IGRIDOUT)=ZVARNEWH(:,:,1)
+ DEALLOCATE(ZVARNEWH,ZVAR3D)
+ zmini=MINVAL(ZALT(:,:,IGRIDOUT),MASK=ZALT(:,:,IGRIDOUT)/=XSPVAL)
+ zmaxi=MAXVAL(ZALT(:,:,IGRIDOUT),MASK=ZALT(:,:,IGRIDOUT)/=XSPVAL)
+ print * ,'after horizontal interpolation, min,max of the vertical grid =', zmini,zmaxi
+ CASE ('XZZ') ! champs 3D (LLHV)
+ print *, ' Horizontal interpolation of XZZ'
+ ALLOCATE ( ZVAR3D(SIZE(XZZ,1),SIZE(XZZ,2),SIZE(XZZ,3)))
+ ZVAR3D(:,:,:)=XZZ(:,:,:)
+ zmini=MINVAL(ZVAR3D(:,:,:),MASK=ZVAR3D(:,:,:)/=XSPVAL)
+ zmaxi=MAXVAL(ZVAR3D(:,:,:),MASK=ZVAR3D(:,:,:)/=XSPVAL)
+ print * ,'min,max of the vertical grid XZZ=', zmini,zmaxi
+ ALLOCATE ( ZVARNEWH(size(ZOBSX,1),size(ZOBSX,2),SIZE(XZZ,3)) )
+ if (ilocverbia >= 1 ) then
+ print *,' before HOR_INTERP_4PTS'
+ endif
+ CALL HOR_INTERP_4PTS (XXX(:,IGRID),XXY(:,IGRID),ZVAR3D,ZOBSX,ZOBSY,ZVARNEWH)
+ IF ( ALLOCATED(ZALT) ) DEALLOCATE (ZALT)
+ ALLOCATE( ZALT(size(ZVARNEWH,1),size(ZVARNEWH,2),SIZE(ZVARNEWH,3)) )
+ ZALT(:,:,:)=ZVARNEWH(:,:,:)
+ DEALLOCATE(ZVARNEWH,ZVAR3D)
+ zmini=MINVAL(ZALT(:,:,:),MASK=ZALT(:,:,:)/=XSPVAL)
+ zmaxi=MAXVAL(ZALT(:,:,:),MASK=ZALT(:,:,:)/=XSPVAL)
+ print * ,'after horizontal interpolation, min,max of the vertical grid =', zmini,zmaxi
+ CASE ('lis') ! champs 3D (LLZV,LLPV)
+ ! Pas d interpolation horizontale du tableau
+ !contenant la liste des niveaux verticaux
+ CASE DEFAULT
+ print *,'** type of vertical grid= ',TRIM(ygrillevert),' not correct'
+ STOP
+ END SELECT
+ !
+ !* 3.4 traitement sup si pluies cumulees
+ ! -------------------------
+ !
+ IF (INDEX(CGROUP,'AC') /=0 ) THEN
+ IF (.NOT.ALLOCATED(zwork3d)) THEN
+ PRINT*, '- ACcumulated rain, do you want to make difference with a previous instant (o/O/y/Y/n/N) ?'
+ READ(5,'(A1)')YREP
+ CALL WRITEDIR(ILUDIR,YREP)
+ CALL LOW2UP(YREP)
+ IF (YREP=='Y' .OR. YREP=='O')THEN
+ PRINT*, '- Name of diachro file (without .lfi) ?'
+ READ(5,'(A28)',END=99) YFILEIN2
+ CALL WRITEDIR(ILUDIR,YFILEIN2)
+ ALLOCATE(zwork3d(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ zwork3d(:,:,:)=XVAR(:,:,:,1,1,1)
+ ALLOCATE(ZDATIME(16,SIZE(XDATIME,2)))
+ ZDATIME(:,:)=XDATIME(:,:)
+ YFLAGREADVAR='OPE'
+ CALL READVAR(CGROUP,YFILEIN2,YFLAGREADVAR,ilocverbia,iret)
+ if ( iret /= 0 ) then
+ print *,TRIM(CGROUP),' not available'
+ YFLAGREADVAR='CLO'
+ CALL READVAR(CGROUP,YFILEIN2,YFLAGREADVAR,ilocverbia,iret2)
+ YFLAGREADVAR='NOP'
+ CYCLE
+ endif
+ ! pour traiter le deuxieme champ
+ GO TO 777
+ ENDIF
+ ENDIF
+ IF (ALLOCATED(zwork3d) .AND. .NOT.ALLOCATED(zwork3d2)) THEN
+ ALLOCATE(zwork3d2(size(XVAR,1),size(XVAR,2),size(XVAR,3)))
+ zwork3d2=XVAR(:,:,:,1,1,1)
+ ! Stockage dans le tableau XVAR qui est le tableau ecrit
+ XVAR(:,:,:,1,1,1)=XUNDEF
+ WHERE( zwork3d(:,:,:) /= XUNDEF .AND. zwork3d2(:,:,:) /= XUNDEF) &
+ XVAR(:,:,:,1,1,1)=zwork3d(:,:,:)-zwork3d2(:,:,:)
+ ! sauvegarde de la valeur de CGROUP
+ YGROUP=CGROUP
+ CGROUP=ADJUSTL( ADJUSTR(CGROUP)//'diff')
+ ! pour avoir le temps du 1er fichier
+ XDATIME(:,:)=ZDATIME(:,:)
+ DEALLOCATE(zwork3d,ZDATIME)
+ ENDIF
+ ENDIF
+ !
+ !* 3.5 Ecriture du tableau XVAR (module MODD_ALLOC_FORDIACHRO)
+ ! -------------------------
+ !
+ print *,' Format of writing= ', YTYPEOUT(1:4)
+ print *,'size of XVAR ',SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)
+ ivarideb=NREADIL
+ ivarifin=NREADIH
+ ivarjdeb=NREADJL
+ ivarjfin=NREADJH
+ ivarkdeb=NREADKL
+ ivarkfin=NREADKH
+ ivartinf=1
+ ivartsup=1
+ ivartrajinf=1
+ ivartrajsup=1
+ ivarprocinf=1
+ ivarprocsup=1
+ if (ilocverbia >= 1 ) then
+ print *,'size of ZALT ',SIZE(ZALT,1),SIZE(ZALT,2),SIZE(ZALT,3)
+ IF(SIZE(ZALT,3)<=10)THEN
+ print *,ZALT(1:SIZE(ZALT,1),1:SIZE(ZALT,2),1:SIZE(ZALT,3))
+ ELSE
+ print *,ZALT(:,:,1:10)
+ ENDIF
+ endif
+ !
+ ! Ecriture triplet par triplet lat,lon,alt traites
+ !
+ print *,' number of triplets taken into account =',inbvalxyz
+ IF ( inbvalxyz == inbvalxy*inbvalz) THEN
+ ! cas fichier d obs contient seulement les coordonnees
+ ! les niveaux sont passes en interactif: double boucle sites
+ ! puis niveaux
+ DO JNobsLOOPsite=1,inbvalxy
+ DO JNobsLOOPz=1,inbvalz
+ if (ilocverbia >= 0 ) then
+ print *,' obs ',JNobsLOOPsite,' lat lon alt',ZOBSLAT(JNobsLOOPsite:JNobsLOOPsite,1),&
+ ZOBSLON(JNobsLOOPsite:JNobsLOOPsite,1),ZALT(1,1,JNobsLOOPz:JNobsLOOPz)
+ if (ilocverbia >= 1 ) then
+ print *,' size XVAR', SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)
+ endif
+ endif
+ CALL WRITELLHV(JNobsLOOPsite,JNobsLOOPsite,1,1,JNobsLOOPz,JNobsLOOPz,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YTYPEOUT,ilocverbia,iret,&
+ HFILENAME_SUP='obs',&
+ PLON=ZOBSLON,PLAT=ZOBSLAT,PALT=ZALT)
+ print *, ' WRITELLHV, return value=',iret
+ ! indiquera a WRITELLHV que le fichier courant en ecriture est
+ ! deja ouvert et de ne pas ecrire l entete
+ YFLAGWRITE='OLDNH'
+ ENDDO
+ IF ( inbvalz == 1) THEN
+ ! une seule valeur par site donc pas d entete entre 2 sites
+ YFLAGWRITE='OLDNH'
+ ELSE
+ ! nouvelle entete pour le site suivant
+ YFLAGWRITE='OLD1H'
+ ENDIF
+ ENDDO
+ !
+ ELSE
+ ! cas fichier d obs contient les coordonnees et les altitudes
+ ! simple boucle sur le nombre de triplets
+ DO JNobsLOOPtriplet=1,inbvalxy
+ if (ilocverbia >= 0 ) then
+ print *,' obs ',JNobsLOOPtriplet,'lat lon alt',ZOBSLAT(JNobsLOOPtriplet:JNobsLOOPtriplet,1),&
+ ZOBSLON(JNobsLOOPtriplet:JNobsLOOPtriplet,1),ZALT(1,1,JNobsLOOPtriplet:JNobsLOOPtriplet)
+ if (ilocverbia >= 1 ) then
+ print *,' size XVAR', SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3)
+ endif
+ endif
+ CALL WRITELLHV(JNobsLOOPtriplet,JNobsLOOPtriplet,1,1,JNobsLOOPtriplet,JNobsLOOPtriplet,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YTYPEOUT,ilocverbia,iret,&
+ HFILENAME_SUP='obs',&
+ PLON=ZOBSLON,PLAT=ZOBSLAT,PALT=ZALT)
+ print *, ' WRITELLHV, return value=',iret
+ ! indiquera a WRITELLHV que le fichier courant en ecriture est
+ ! deja ouvert et de ne pas ecrire l entete
+ YFLAGWRITE='OLDNH'
+ ENDDO
+ ENDIF
+ ! restore le nombre de niveaux verticaux et de triplets
+ IF (ygrillevert=='XXZS') THEN
+ inbvalz=inbvalz3d
+ inbvalxyz=inbvalxyz3d
+ END IF
+ ! fermeture du 2e fichier ouvert pour diff de pluie cumulee
+ IF (INDEX(CGROUP,'AC') /=0 .AND. ALLOCATED(zwork3d2)) THEN
+ DEALLOCATE(zwork3d2)
+ !CALL READVAR(YGROUP,YFILEIN2,'CLO',ilocverbia,iret2)
+ ! il faut close avec un champ forcement present mais
+ ! pas AC...diff donc avec YGROUP qui memorise le nom de groupe
+ ! existant sans diff
+ ! ce close fait planter le prog: erreur non trouvée apres
+ ! 1/j de recherche
+ ! de toute facon la fermeture se fera avec la fin de programme
+ ENDIF
+ ELSE ! iret /=0
+ print *, ' READVAR, return value=',iret
+ ENDIF
+ ! Pour indiquer l ecriture de l entete pour la variable suivante
+ YFLAGWRITE='OLD1H'
+ ENDDO ! boucle champ a traiter
+ ! pour clore le traitement meme si la liste des champs est
+ ! incomplete ( non terminee par END)
+ 88 CONTINUE
+ CGROUP='END'
+!
+!---------------------------------------------------------------------------
+!
+!* 4. Fermeture fichiers
+! ------------------
+!
+ IF ( CGROUP(1:3) == 'END' .AND. YFLAGWRITE(1:3)/='NEW') THEN
+ PRINT*, 'END -> Close the output file'
+ YFLAGWRITE='CLOSE'
+ ! dans cet appel seul l argument YFLAGWRITE est pris en compte, tous
+ ! les autres arguments sont ignores
+ SELECT CASE(YTYPEOUT(1:4))
+ CASE('LLHV','llhv','LLPV','llpv','LLZV','llzv')
+ CALL WRITELLHV(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ CGROUP,YFILEIN,YFLAGWRITE,YTYPEOUT,ilocverbia,iret,&
+ HFILENAME_SUP='obs')
+ CASE DEFAULT
+ PRINT*, 'Closure of output type ',YTYPEOUT ,' not coded'
+ END SELECT
+ ! renomme le fichier de sortie en ajoutant le nom du fichier d obs
+ ! effectue en fin de traitement car pour les routines FM, les noms de fichiers
+ !sont limites a 28 caracteres
+ YFILEOUT=ADJUSTR(YFILEIN)//ADJUSTL(YTYPEOUT(1:4))
+ YFILEOUT=ADJUSTL( ADJUSTR(YFILEOUT)//'_obs')
+ ycommand='mv '//TRIM(YFILEOUT)//' '//TRIM(TRIM(YSAVEFILEOBS)//'_'//TRIM(YFILEOUT))
+ print *,'command= ',ycommand
+ call SYSTEM ( TRIM(ycommand) )
+ ENDIF
+!
+ENDDO ! fin boucle des fichiers a traiter
+!-------------------------------------------------------------------------------
+!
+!* 5. Fin de boucle sur les fichiers
+! ------------------
+!
+99 CONTINUE
+!
+! Suppression de tous les liens eventuellemnet crees
+YDUMMYFILE=''
+CALL CREATLINK(' ',YDUMMYFILE,'CLEAN',ilocverbia)
+PRINT*, 'The file ',TRIM(YLUDIR),' stores all the input directives'
+PRINT*, ' you must give a new name to use it again'
+CLOSE(ILUDIR)
+!
+IF ( YFLAGWRITE(1:3)/='NEW') THEN
+ PRINT*, 'Output files ',TRIM(YSAVEFILEOBS),'*obs are available'
+END IF
+!
+END PROGRAM MESONH2OBS
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/modd_readlh.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/modd_readlh.f90
new file mode 100644
index 0000000000000000000000000000000000000000..97e20fb0b24bccc34b57c338fe1ddef6900bd661
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/modd_readlh.f90
@@ -0,0 +1,39 @@
+! ######spl
+ MODULE MODD_READLH
+! #######################
+!
+!!**** *MODD_READLH* -
+!!
+!! PURPOSE
+!! -------
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!! N. Asencio *Meteo-France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 01/03/05
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+INTEGER, SAVE :: NREADKL, NREADKH ! lowest and highest K indice values
+
+INTEGER, SAVE :: NREADIL, NREADIH ! lowest and highest I indice values
+
+INTEGER, SAVE :: NREADJL, NREADJH ! lowest and highest J indice values
+
+END MODULE MODD_READLH
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/modn_outfile.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/modn_outfile.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c29102cbfd51d97ed0d72f15a621cbfa75cb9456
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/modn_outfile.f90
@@ -0,0 +1,73 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:./s.modn_outfile.f90, Version:1.3, Date:03/06/05, Last modified:01/10/19
+!-----------------------------------------------------------------
+! ####################
+ MODULE MODN_OUTFILE
+! ####################
+!
+!!**** *MODN_OUTFILE* - defines the three namelists controling conversion
+!!
+!! PURPOSE
+!! -------
+! This declarative module defines the NAM_OUTFILE, NAM_OUTHOR, NAM_OUTVER
+! namelists, which contains the parameters controling the grib or Vis5D
+! coding of fields.
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. Ducrocq
+!!
+!! MODIFICATIONS
+!! -------------
+!! original 20/03/97
+!! modifications 20/02/01 (I.Mallet) merge with JPChaboureau Vis5D files
+!! modifications 20/10/01 ( " ) split in 3 namelists, add horizontal interpolation
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+USE MODD_CONF, ONLY : NVERB
+IMPLICIT NONE
+!
+CHARACTER(LEN=28) :: CMNHFILE ! Name of the input FM file
+CHARACTER(LEN=3) :: COUTFILETYPE ! Type of the outfile (GRB or V5D)
+! Common characteristics
+LOGICAL:: LAGRID !If T., fields are interpolated on an arakawa A-grid
+ ! (mass grid) else they are on the mesonh grids
+CHARACTER(LEN=4) :: CHORTYPE ! Type of horizontal grid
+ ! NONE: MesoNH grid
+ ! NEAR: nearest-neighbour interpolation
+ ! BILI: bilinear interpolation
+REAL,DIMENSION(4) :: XLATLON ! NSWE target domain bounds (in degrees)
+CHARACTER(LEN=1) :: CLEVTYPE ! Type of vertical levels in output file
+ ! GRB: P=pressure levels, K=native coordinate of MESO-NH
+ ! V5D: P=pressure levels, Z=z levels, K=native coordinate of lowest point
+CHARACTER(LEN=6) :: CLEVLIST ! How vertical levels are specified
+ ! 'MANUAL' list of levels in free format
+ ! 'FUNCTN' list of levels in next 3 variables
+REAL :: XVLMIN,XVLMAX,XVLINT ! minimum, maximum and increment values
+ ! for the vertical grid
+ ! (used only if CLEVTYPE='P' or 'Z')
+! Grib characteristics
+LOGICAL :: LLMULTI !If .T., a multigrib file is produced, else monogrib files
+!
+!* 0.1 Namelist NAM_OUTFILE
+!
+NAMELIST/NAM_OUTFILE/CMNHFILE,COUTFILETYPE, &
+ NVERB,LLMULTI
+NAMELIST/NAM_OUTHOR/LAGRID,CHORTYPE,XLATLON
+NAMELIST/NAM_OUTVER/CLEVTYPE,CLEVLIST, &
+ XVLMIN,XVLMAX,XVLINT
+!
+END MODULE MODN_OUTFILE
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/obs2mesonh.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/obs2mesonh.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bf57f2615c96a5f60f5003c25b09584287f45309
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/obs2mesonh.f90
@@ -0,0 +1,827 @@
+! ###################
+ PROGRAM OBS2MESONH
+! ###################
+!
+!!**** *OBS2MESONH* - Interpolation d une liste de valeurs observées
+! sur la grille Mesonh
+! en entrée un fichier ASCII au format [ ] pour optionnel
+! [YYYMMJJHHMMSS]
+! lon lat [alt] valeur_obs
+! ou lat lon [alt] valeur_obs
+! en sortie un fichier diachronique
+!!
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+! Lecture en entree:
+! d un fichier ascii contenant les localisations (lon,lat alt,valeur) a traiter
+! d un fichier modele pour recuperer la grille XYZ
+! Pour chaque obs lue, 1) recherche du point de grille xy la contenant,
+! 2) recherche sur la verticale du niveau K la contenant
+! Si plusieurs obs sont contenues dans un meme point de grille, calcul de la moyenne des ces obs
+! Pour certaines variables (unite dBz, nom de champ_WVBT ou _IRBT),
+! passage a des unites plus pertinentes pour effectuer les moyennes
+! et retour aux unites d origine avant ecriture (voir les 2 routines
+! symetriques To_computing_units et From_computing_units)
+! Mise a XSPVAL des points de grille ne contenant pas d'obs
+!
+! Ecriture en sortie:
+! d un fichier diachronique ( utiliser LSPOT=T dans diaprog pour visualiser
+! toutes les points grilles non XSPVAL)
+!
+!!
+!! EXTERNAL
+!! --------
+!! CREATLINK : à l'ouverture du fichier, HYFLAGFILE='OPE',
+!! création d'un lien dans le directory local
+!! si le fichier existe sous $DIROBS
+!! READVAR : lecture d unchamp du fichier diachronique
+!! WRITEVAR : ecriture format lon lat alt val
+!! SM_XYHAT : création de la grille des Obs
+!! TO_COMPUTING_UNITS: passage unites vers unites plus pertinentes
+!! pour effectuer des calculs
+!! FROM_COMPUTING_UNITS: passage inverse avant ecriture
+!! (appele par writevar)
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHORS
+!! -------
+!! N. Asencio and J. Stein
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 04/11/2003
+!! Fev 2005: ajout de champs diachroniques ALT_champ N_champ
+!! changement de grille pour le vent (zonal,meridien->
+!! grille Mesonh)
+!! 04/05/2005 add a control for the min and max of the field before
+! and after interpolation(s)
+! observations outside the mesonh domain are rejected
+! 19/09/2005 G.Jaubert CNRM
+! 1) Nom du fichier .lfi en output demande
+! 2) l'enregistrement peut ne pas contenir alt si champ 2D
+! 3) si le fichier de donnees commence par une date,
+! reinitialisation de la date dans le lfi de sortie
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+#ifdef NAGf95
+USE F90_UNIX ! for FLUSH
+USE F90_UNIX_PROC ! for SYSTEM
+#endif
+! modules MesoNH
+USE MODD_CST
+USE MODD_PARAMETERS, ONLY:JPHEXT,JPVEXT,XUNDEF
+USE MODD_DIM1, ONLY:NIMAX,NJMAX,NKMAX, NIINF, NISUP ,NJINF,NJSUP
+USE MODD_GRID, ONLY: XLON0,XLAT0,XLONORI,XLATORI
+USE MODD_GRID1, ONLY: XXHAT,XYHAT,XZZ
+USE MODE_GRIDPROJ ! subroutine SM_XYHAT
+! modules DIACHRO
+USE MODN_NCAR, ONLY: XSPVAL
+USE MODD_COORD
+! XVAR(i,j,k,,,), XMASK,XTRAJ ,XDATIME(16,t)
+! et NGRIDIA , NGRIDIAM ( appel interp_grids)
+USE MODD_ALLOC_FORDIACHRO
+! nverbia, CGROUP
+USE MODD_RESOLVCAR
+USE MODD_READLH !NREADIL,IH,...
+!
+!
+USE MODI_WRITEVAR
+USE MODI_CREATLINK
+USE MODI_LOW2UP
+USE MODI_WRITEDIR
+USE MODI_UV_TO_ZONAL_AND_MERID
+USE MODI_TO_COMPUTING_UNITS
+!
+IMPLICIT NONE
+!
+!* 0.1 Local variables declaration
+!
+!! indices de boucle
+INTEGER :: JILOOP,JOBS
+! zoom suivant les 6 dimensions des champs diachro
+INTEGER :: ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin
+INTEGER :: ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup
+INTEGER :: IL ! indice de positionnement dans yligne
+INTEGER :: IIMNH,IJMNH,IKMNH,IKMAX,IGRID
+!
+INTEGER :: IAN, IMOIS, IJOUR, IHEUR, IMINU, ISEC ! date observation
+REAL :: XSEC ! heure observation en secondes
+!
+! stockage
+REAL, allocatable, dimension(:,:,:) :: ZOBSinMNH,ZALTOBS
+INTEGER , allocatable, dimension(:,:,:) :: ICPTOBSinMNH
+REAL :: ZXOBS,ZYOBS,ZOBSLONLU,ZOBSLATLU,ZOBSALTLU,ZVALOBS
+! pour le passage composantes meridienne,zonale a la grille Mesonh
+REAL, allocatable, dimension(:,:,:,:,:,:):: ZVENTSAVE
+REAL, allocatable, dimension(:,:,:) :: ZWORK3D,ZWORK3D2
+!
+REAL :: zmini,zmaxi
+REAL :: ZVAR1, ZVAR2, ZVAR3
+LOGICAL :: galtobs
+INTEGER :: ILUDIR,iret,ilocverbia,inbval,inbvalrej,IKM1
+!! **** la taille des variables caracteres contenant les noms
+!! de fichiers est obligatoirement de 28 ****
+!! pour toutes les routines diachro
+CHARACTER(LEN=28) :: YFILEGRID,YDUMMYFILE , YFILEOUTNAME
+CHARACTER(LEN=100):: YFILEOBS
+CHARACTER(LEN=3) :: YFLAGREADVAR ,YFLAGWRITE
+CHARACTER (LEN=10):: YUNITE,YUNITEMAJ
+CHARACTER (LEN=3) :: YSTOCK,YFILEOUTSUFFIX
+CHARACTER (LEN=4) :: YLL
+CHARACTER(LEN=11) :: YLUDIR ! Name of the dir file
+CHARACTER(LEN=14) :: YDATEOBS ! observation date (YYYYMMDDHHMISS)
+CHARACTER(LEN=100) :: YLIGNE !
+!-------------------------------------------------------------------------------
+!
+!* 1. Init
+! ----
+!
+! active(1) ou desactive(0) les prints de controle dans les routines
+! READVAR et WRITEVAR
+ilocverbia=0
+!
+! dans mesonh Xundef est utilise
+! dans les routines diachro XSPVAL est utilisé
+ XSPVAL=XUNDEF
+!
+! ouverture d un fichier dir ou vont s ecrire les entrees clavier
+YLUDIR='dirobs2mnh'
+CALL FMATTR(YLUDIR,YLUDIR,ILUDIR,iret)
+OPEN(UNIT=ILUDIR,FILE=YLUDIR,FORM='FORMATTED')
+!
+NIINF=0
+NISUP=0
+NJINF=0
+NJSUP=0
+iret=0
+!
+!* 2. Lecture et initialisation des modules Mesonh
+! ----------------------------
+
+PRINT*, '- Name of the diachro file to read the grid '&
+ ,'(without .lfi) ?'
+READ(5,'(A)',END=99) YFILEGRID
+YFILEGRID=ADJUSTL(YFILEGRID)
+CALL WRITEDIR(ILUDIR,YFILEGRID)
+!
+PRINT*, '- Prints : 0= mini 1=debug mode in obs2mesonh'
+PRINT*, ' 2= print of input values'
+PRINT*, ' 3=debug mode in diachro routines'
+PRINT*, '?'
+READ(5,*)ilocverbia
+CALL WRITEDIR(ILUDIR,ilocverbia)
+PRINT*, ' output prints= ',ilocverbia
+IF (ilocverbia >2) nverbia=ilocverbia
+!
+! Lecture du champ ZSBIS pour obtenir
+! l Initialisation des variables
+! des modules (cf USE en debut de programme)
+!
+! indique que le fichier lu doit etre ouvert dans READVAR
+YFLAGREADVAR='OPE'
+CALL READVAR('ZSBIS',YFILEGRID,YFLAGREADVAR,ilocverbia,iret)
+print *, 'READVAR(zsbis), return value= ',iret
+IF ( iret /= 0 ) THEN
+ print *,'** Error when reading the grid in the FM diachro file: ',TRIM(YFILEGRID)
+ STOP
+ENDIF
+!
+if (ilocverbia >= 0 ) then
+ print *,' Size of input array(zs)= ',SIZE(XVAR,1),SIZE(XVAR,2),&
+ SIZE(XVAR,3),SIZE(XVAR,4),SIZE(XVAR,5),SIZE(XVAR,6)
+ PRINT*, 'NIINF,NISUP,NJINF,NJSUP', NIINF,NISUP,NJINF,NJSUP
+ PRINT*, 'LATORI,LONORI ', XLATORI,XLONORI
+ zmini= 0.5 * (XXHAT(1)+XXHAT(2))
+ zmaxi= 0.5 * (XYHAT(1)+XYHAT(2))
+ CALL SM_LATLON(XLATORI,XLONORI,zmini,zmaxi,ZVAR1,ZVAR2)
+ PRINT*, 'LATOR,LONOR ', ZVAR1,ZVAR2
+endif
+!
+!
+PRINT*,'- Name of the output file ? (the default [CR or empty line], "obs" will be added to the input FM file'
+READ(5,'(A28)',END=88) YFILEOUTNAME
+YFILEOUTNAME=ADJUSTL(YFILEOUTNAME)
+CALL WRITEDIR(ILUDIR,YFILEOUTNAME)
+IF (YFILEOUTNAME(1:2) == 'll' .OR. YFILEOUTNAME(1:2) == 'LL' ) THEN
+ print * ,'** OBS2MESONH: the format of the input file was modified Oct2005'
+ print * ,' the 3rd line is for the name of the output file'
+ print * ,'instead of the format of the input file: modify your directives'
+ STOP
+ELSE
+ ! input phase avec obs2mesonh post Oct2005
+ IF (LEN_TRIM(YFILEOUTNAME) == 0) THEN
+ YFILEOUTSUFFIX='obs'
+ YFILEOUTNAME=YFILEGRID
+ ELSE
+ YFILEOUTSUFFIX='NEN'
+ PRINT*,'Output file name=', TRIM(YFILEOUTNAME)
+ ENDIF
+ENDIF
+!
+! fichier a creer dans WRITEvar
+YFLAGWRITE='NEW'
+! ecriture de ZSBIS dans FILEOUT
+CALL WRITEVAR(NREADIL,NREADIH,NREADJL,NREADJH,NREADKL,NREADKL,&
+ 1,SIZE(XVAR,4),1,SIZE(XVAR,5),1,SIZE(XVAR,6), &
+ 'ZSBIS',YFILEOUTNAME,YFLAGWRITE,YFILEOUTSUFFIX,ilocverbia,iret)
+! indiquera a WRITEVAR que le fichier courant en ecriture est deja ouvert
+YFLAGWRITE='OLD'
+!-------------------------------------------------------------------------------
+!
+!* 3. LOOP on obs files
+! -----------------
+!
+PRINT*,' Loop on the observation files:'
+DO JOBS=1,10000
+ 777 CONTINUE ! Point de reprise pour le traitement de la 2e composante vent
+ !
+ PRINT*,'- Format of the input observation file:'
+ PRINT*,' LL= n lines Lon,Lat,val '
+ PRINT*,' ll= n lines lat,lon,val '
+ PRINT*,' DLL= date (YYYYMMDDHHMISS) then n lines Lon,Lat,val '
+ PRINT*,' Dll= date (YYYYMMDDHHMISS) then n lines lat,lon,val '
+ PRINT*,' LLa= n lines Lon,Lat,alt(m),val'
+ PRINT*,' lla= n lines lat,lon,alt(m),val'
+ PRINT*,' DLLa= date (YYYYMMDDHHMISS) then n lines Lon,Lat,alt(m),val'
+ PRINT*,' Dlla= date (YYYYMMDDHHMISS) then n lines lat,lon,alt(m),val'
+ PRINT*,'(END to stop)?'
+ READ(5,'(A)',END=88) YLL
+ YLL=ADJUSTL(YLL)
+ CALL WRITEDIR(ILUDIR,YLL)
+ IF (YLL(1:3)=='end' .OR. YLL(1:3)=='END') GO TO 88
+ IF (YLL(1:3)=='LLa') THEN
+ print*, 'format Lon,Lat,alt(m),value'
+ galtobs=.true.
+ ELSE IF (YLL(1:3)=='lla') THEN
+ print*, 'format lat,lon,alt(m),value'
+ galtobs=.true.
+ ELSE IF (YLL(1:4)=='DLLa') THEN
+ print*, 'format Date then Lon,Lat,alt(m),valeur'
+ galtobs=.true.
+ ELSE IF (YLL(1:4)=='Dlla') THEN
+ print*, 'format Date then lat,lon,alt(m),valeur'
+ galtobs=.true.
+ ELSE IF (YLL(1:2)=='LL') THEN
+ print*, 'format Lon,Lat,valeur'
+ galtobs=.false.
+ ELSE IF (YLL(1:2)=='ll') THEN
+ print*, 'format lat,lon,valeur'
+ galtobs=.false.
+ ELSE IF (YLL(1:3)=='DLL') THEN
+ print*, 'format Date then Lon,Lat,value'
+ galtobs=.false.
+ ELSE IF (YLL(1:3)=='Dll') THEN
+ print*, 'format Date then lat,lon,value'
+ galtobs=.false.
+ ELSE
+ print*, '** incorrect format ',YLL
+ CYCLE
+ ENDIF
+ PRINT*,'- Name of the input observation file ?'
+ READ(5,'(A)',END=88) YFILEOBS
+ YFILEOBS=ADJUSTL(YFILEOBS)
+ CALL WRITEDIR(ILUDIR,YFILEOBS)
+ !
+ !* 3.1 Lecture du fichier d obs a traiter
+ ! ----------------------
+ PRINT*, '- Name of the new field to be created:'
+ PRINT*, '(if it is a wind field you have to name the field : '
+ PRINT*, ' WTxx: the field is localised at vertical flux points, ',&
+ 'otherwise at mass points (example : WT10) '
+ PRINT*, ' UTxx: the field (U-component for zonal) will be converted to ',&
+ 'MesoNH wind components'
+ PRINT*, 'the V-component must be provided immediately after with VTxx'
+ PRINT*, '?'
+ READ(5,'(A9)',END=88) CGROUP
+ CGROUP=ADJUSTL(CGROUP)
+ CALL WRITEDIR(ILUDIR,CGROUP)
+ CALL LOW2UP(CGROUP)
+ PRINT*, '- Unit of the new field ?'
+ READ(5,'(A)') YUNITE
+ YUNITE=ADJUSTL(YUNITE)
+ CALL WRITEDIR(ILUDIR,YUNITE)
+ PRINT*, '- Profil of the new field :'
+ PRINT*, ' 3D=XYZ '
+ PRINT*, ' 2D=XY (obs altitudes not taken into account)'
+ PRINT*, ' 1D=Z (vertical profil (_PV_ for diaprog) localised at ',&
+ 'lat-lon of the 1st obs'
+ PRINT*, ' 1D/2D/3D ?'
+ READ(5,'(A)') YSTOCK
+ YSTOCK=ADJUSTL(YSTOCK)
+ CALL WRITEDIR(ILUDIR,YSTOCK)
+ IF ( (YSTOCK == '3D' .OR. YSTOCK == '1D') .AND. .NOT.(galtobs) ) THEN
+ print * ,'** It is not possible to store ',TRIM(YSTOCK),' profil ',&
+ 'because no altitude was provided in the input obs file'
+ print *, ' change your inputs:', TRIM(YLL)
+ STOP
+ ENDIF
+ ! tableau de stockage des valeurs des obs et compteur de ces valeurs stockees
+ IF(ALLOCATED(ZOBSinMNH)) DEALLOCATE(ZOBSinMNH)
+ IF(ALLOCATED(ZALTOBS)) DEALLOCATE(ZALTOBS)
+ IF(ALLOCATED(ICPTOBSinMNH)) DEALLOCATE(ICPTOBSinMNH)
+ ! XVAR = futur tableau a ecrire via writevar
+ IF(ALLOCATED(XVAR)) DEALLOCATE(XVAR)
+ IF ( YSTOCK == '3D' .OR. YSTOCK == '1D' ) THEN
+ ALLOCATE(XVAR( SIZE(XZZ,1),SIZE(XZZ,2),SIZE(XZZ,3),1,1,1))
+ ALLOCATE(ZOBSinMNH( SIZE(XZZ,1),SIZE(XZZ,2),SIZE(XZZ,3)))
+ ALLOCATE(ZALTOBS( SIZE(XZZ,1),SIZE(XZZ,2),SIZE(XZZ,3)))
+ ALLOCATE(ICPTOBSinMNH( SIZE(XZZ,1),SIZE(XZZ,2),SIZE(XZZ,3)))
+ ELSE
+ ALLOCATE(XVAR( SIZE(XZZ,1),SIZE(XZZ,2),1,1,1,1))
+ ALLOCATE(ZOBSinMNH( SIZE(XZZ,1),SIZE(XZZ,2),1))
+ ALLOCATE(ZALTOBS( SIZE(XZZ,1),SIZE(XZZ,2),1))
+ ALLOCATE(ICPTOBSinMNH( SIZE(XZZ,1),SIZE(XZZ,2),1))
+ END IF
+ !
+ PRINT*, 'Mesonh field to be created: ', TRIM(CGROUP),' ',TRIM(YUNITE),' ',TRIM(YSTOCK)
+ ! init de la grille verticale Mesonh suivant le nom de variable
+ SELECT CASE (CGROUP(1:1))
+ CASE ('W')
+ IGRID=4 ! champ d obs sur la grille W
+ ! init du tableau des altitudes XZZ pour la grille masse
+ CALL COMPCOORD_FORDIACHRO(1)
+ if (ilocverbia > 0 ) then
+ print *,' after COMPCOORD_FORDIACHRO (mass grid for W field)'
+ endif
+ ! -----------XZZ(k) grille masse
+ ! x W(k)
+ ! -----------XZZ(k-1) grille masse
+ CASE default
+ IGRID=1 ! champ d obs sur la grille de masse
+ ! init du tableau des altitudes XZZ pour la grille W
+ CALL COMPCOORD_FORDIACHRO(4)
+ if (ilocverbia > 0 ) then
+ print *,' after COMPCOORD_FORDIACHRO (W grid for mass field)'
+ endif
+ ! -----------XZZ(k+1) grille W
+ ! x T(k)
+ ! -----------XZZ(k) grille W
+ END SELECT
+ !
+ !* 3.2. pour chaque obs lue, recherche de la maille mesonh
+ ! contenant cette obs : cumul dans cette maille
+ ! mis a jour du compteur d obs par maille
+ ! ----------------------
+ !
+ print *,'YFILEOBS=', TRIM(YFILEOBS)
+ CALL CREATLINK('DIROBS',YFILEOBS,'CREAT',ilocverbia)
+ OPEN (UNIT=8,FILE=TRIM(ADJUSTL(YFILEOBS)),STATUS='OLD',FORM='FORMATTED')
+ !
+ ZOBSINMNH(:,:,:)=0.
+ ICPTOBSinMNH(:,:,:)=0
+ IKMAX=1
+ !
+ inbval=0
+ inbvalrej=0
+ if (ilocverbia >= 2 ) print *, 'before reading of input obs file'
+ IF (YLL(1:1)=='D' ) THEN
+ ! lecture de la date
+ READ (8,'(A14)',ERR=886) YDATEOBS
+ YDATEOBS=ADJUSTL(YDATEOBS)
+ ! verification YDATEOBS est une date
+ IF (YDATEOBS(1:4)<='1900' .OR. YDATEOBS(1:4)>='2020' &
+ .OR. YDATEOBS(5:6)<'01' .OR. YDATEOBS(5:6)>'12' &
+ .OR. YDATEOBS(7:8)<'01' .OR. YDATEOBS(7:8)>'31' &
+ .OR. YDATEOBS(9:10)<'00' .OR. YDATEOBS(9:10)>'23' &
+ .OR. YDATEOBS(11:12)<'00' .OR. YDATEOBS(11:12)>'59' &
+ .OR. YDATEOBS(13:14)<'00' .OR. YDATEOBS(13:14)>'59' ) GO TO 887
+ ! Pourquoi cette init ? voir GJ iret=1
+ ! reinitialisation de XDATIME
+ READ(YDATEOBS,'(i4,5I2)') IAN, IMOIS, IJOUR, IHEUR, IMINU, ISEC
+ XSEC=IHEUR*3600.+IMINU*60.+ISEC
+ DO JILOOP=1,13,4
+ XDATIME(JILOOP,1)=IAN
+ XDATIME(JILOOP+1,1)=IMOIS
+ XDATIME(JILOOP+2,1)=IJOUR
+ XDATIME(JILOOP+3,1)=XSEC
+ END DO
+ if (ilocverbia >= 2 ) print *,'XDATIME initialised to:',XDATIME(1:4,1)
+ ENDIF
+ ! lecture de la position et valeur des observations
+ ! boucle infinie : arret sur fin de fichier
+ ! init de la position à -999
+ IIMNH=-999
+ IJMNH=-999
+! modif GJ deduction format JILOOP=0
+ DO
+! modif GJ deduction format IF ( JILOOP == 0 .AND. YSTOCK =='2D' ) THEN
+! modif GJ deduction format ! le format de donnees peut ne pas contenir alt
+! modif GJ deduction format ! lecture du premier enregistrement en caracteres puis decodage
+! modif GJ deduction format if (ilocverbia >= 2 ) print *,'Recherche du nombre de variables dans un enregistrement'
+! modif GJ deduction format READ (8,'(A100)') YLIGNE
+! modif GJ deduction format YLIGNE=ADJUSTL(YLIGNE)
+! modif GJ deduction format il=index(YLIGNE,' ')-1
+! modif GJ deduction format READ(Yligne(1:il),*) ZVAR1
+! modif GJ deduction format YLIGNE=ADJUSTL(YLIGNE(il+1:))
+! modif GJ deduction format il=index(YLIGNE,' ')-1
+! modif GJ deduction format READ(Yligne(1:il),*) ZVAR2
+! modif GJ deduction format IF (TRIM(YLL)=='LL' .or. TRIM(YLL)=='DLL') THEN
+! modif GJ deduction format ZOBSLONlu=ZVAR1
+! modif GJ deduction format ZOBSLATlu=ZVAR2
+! modif GJ deduction format ELSE IF (YLL(1:2)=='ll' .or. YLL(1:3)=='Dll') THEN
+! modif GJ deduction format ZOBSLATlu=ZVAR1
+! modif GJ deduction format ZOBSLONlu=ZVAR2
+! modif GJ deduction format ENDIF
+! modif GJ deduction format YLIGNE=ADJUSTL(YLIGNE(il+1:))
+! modif GJ deduction format il=index(YLIGNE,' ')-1
+! modif GJ deduction format READ(Yligne(1:il),*) ZVAR3
+! modif GJ deduction format IF ( LEN_TRIM(YLIGNE(il+1:)) == 0 ) THEN
+! modif GJ deduction format print *,' Champ 2D avec enregistrement sans altitude'
+! modif GJ deduction format ZOBSALTlu=-999
+! modif GJ deduction format ZVALOBS=ZVAR3
+! modif GJ deduction format YLL(LEN_TRIM(YLL):LEN_TRIM(YLL))='A'
+! modif GJ deduction format ELSE
+! modif GJ deduction format ZOBSALTlu=ZVAR3
+! modif GJ deduction format YLIGNE=ADJUSTL(YLIGNE(il+1:))
+! modif GJ deduction format READ(Yligne,*) ZVALOBS
+! modif GJ deduction format ENDIF
+! modif GJ deduction format if (ilocverbia >= 2 ) THEN
+! modif GJ deduction format print *,'1er enregistrement: lat=',ZOBSLATlu,' lon=',ZOBSLONlu
+! modif GJ deduction format print *,' alt=',ZOBSALTlu,' var=',ZVALOBS
+! modif GJ deduction format endif
+! modif GJ deduction format ELSE
+! modif GJ deduction format ! lecture d'un enregistrement
+! modif GJ deduction format IF (TRIM(YLL)=='LL' .or. TRIM(YLL)=='DLL') THEN
+! modif GJ deduction format READ (8,*,ERR=887,END=888) ZOBSLONlu,ZOBSLATlu,ZOBSALTlu,ZVALOBS
+! modif GJ deduction format ELSE IF (YLL(1:2)=='ll' .or. YLL(1:3)=='Dll') THEN
+! modif GJ deduction format READ (8,*,ERR=887,END=888) ZOBSLATlu,ZOBSLONlu,ZOBSALTlu,ZVALOBS
+! modif GJ deduction format ELSE IF (TRIM(YLL)=='LA' .or. TRIM(YLL)=='DLA') THEN
+! modif GJ deduction format READ (8,*,ERR=887,END=888) ZOBSLONlu,ZOBSLATlu,ZVALOBS
+! modif GJ deduction format ZOBSALTlu=-999
+! modif GJ deduction format ELSE IF (YLL(1:2)=='lA' .or. YLL(1:3)=='DlA') THEN
+! modif GJ deduction format READ (8,*,ERR=887,END=888) ZOBSLATlu,ZOBSLONlu,ZVALOBS
+! modif GJ deduction format ZOBSALTlu=-999
+! modif GJ deduction format ELSE
+! modif GJ deduction format print * ,' Format des obs =',YLL(1:4),' valeur incorrecte'
+! modif GJ deduction format print *, 'valeurs possibles: ll ou LL ou Dll ou DLL ou llh ou LLh ou Dllh ou DLLh'
+! modif GJ deduction format STOP
+! modif GJ deduction format ENDIF
+! modif GJ deduction format ENDIF
+! modif GJ deduction format JILOOP=1
+ IF (YLL(1:3)=='LLa' .OR. YLL(1:4)=='DLLa') THEN
+ READ (8,*,END=888) ZOBSLONlu,ZOBSLATlu,ZOBSALTlu,ZVALOBS
+ ELSE IF (YLL(1:3)=='lla'.OR. YLL(1:4)=='Dlla' ) THEN
+ READ (8,*,END=888) ZOBSLATlu,ZOBSLONlu,ZOBSALTlu,ZVALOBS
+ ELSE IF (YLL(1:2)=='LL'.OR.YLL(1:3)=='DLL' ) THEN
+ READ (8,*,END=888) ZOBSLONlu,ZOBSLATlu,ZVALOBS
+ ZOBSALTlu= XSPVAL
+ ELSE IF (YLL(1:2)=='ll' .OR. YLL(1:3)=='Dll' ) THEN
+ READ (8,*,END=888) ZOBSLATlu,ZOBSLONlu,ZVALOBS
+ ZOBSALTlu= XSPVAL
+ ELSE
+ print * ,'** Obs format=',YLL(1:4),' is an incorrect value'
+ print *, 'correct values are: ll or LL or Dll or DLL or lla or LLa or Dlla or DLLa'
+ STOP
+ ENDIF
+
+ ! recupere les coordonnées de l obs sur le plan conforme
+ IF (YSTOCK == '3D' .OR. YSTOCK == '2D' .OR. &
+ (YSTOCK == '1D' .AND. IIMNH == -999) ) THEN
+ ! recupere pour chaque obs si 2D ou 3D , pour la premiere obs si 1D
+ !(les 2 premiers arg. doivent etre XXHAT et XYHAT (pas XXX et XXY))
+ !! peu importe en masdev4_6 car plus utilises..
+ !CALL SM_XYHAT(XXHAT,XYHAT,XLATORI,XLONORI, &
+ !! XXHAT,XYHAT supprimes en masdev4_7
+ CALL SM_XYHAT(XLATORI,XLONORI, &
+ ZOBSLATlu,ZOBSLONlu,ZXOBS,ZYOBS)
+ ! quelle est la maille horizontale mesonh qui contient cette obs ?
+ ! XXHAT(I),XXHAT(I+1) = limites X de la maille I
+ ! XYHAT(J),XYHAT(J+1) = limites Y de la maille J
+ IF ( ZXOBS >= XXHAT(2) .AND. ZXOBS <= XXHAT(NIMAX+2-1) .AND.&
+ ZYOBS >= XYHAT(2) .AND. ZYOBS <= XYHAT(NJMAX+2-1) ) THEN
+ IIMNH=MAX(MIN(COUNT(XXHAT(:)<ZXOBS),NIMAX+2-1),2)
+ IJMNH=MAX(MIN(COUNT(XYHAT(:)<ZYOBS),NJMAX+2-1),2)
+ ELSE
+ print * ,'*** The observation at lat,lon ',ZOBSLATlu,ZOBSLONlu,&
+ 'is out of the Mesonh domain, not treated ***'
+ inbvalrej=inbvalrej+1
+ CYCLE
+ ENDIF
+ ELSE
+ if (ilocverbia >= 2 ) then
+ print *, ' Profil ', YSTOCK, ': following obs are at the same localisation',&
+ ' as the first one ', ZOBSLATlu,ZOBSLONlu
+ print *, 'i,j=', IIMNH,IJMNH
+ endif
+ ENDIF
+
+ if (ilocverbia >= 3 ) then
+ print *, ZXOBS,IIMNH &
+ ,XXX(IIMNH,IGRID),XXX(IIMNH-1,IGRID),XXHAT(IIMNH),&
+ XXHAT(IIMNH-1),XXHAT(IIMNH+1)
+ print *, ZYOBS,IJMNH &
+ ,XXY(IJMNH,IGRID), XXY(IJMNH-1,IGRID),XYHAT(IJMNH),&
+ XYHAT(IJMNH-1),XYHAT(IJMNH+1)
+ endif
+ IF ( YSTOCK == '3D' .OR. YSTOCK == '1D' ) THEN
+ ! quelle est la maille verticale mesonh qui contient cette obs ?
+ ! cas des obs a localiser sur la grille de masse
+ ! XZZ_W (K) , XZZ_W(K+1) = limites Z de la maille_masse K
+ ! cas des obs à localiser sur la grille de W
+ ! XZZ_masse (K-1) , XZZ_masse(K) = limites Z de la maille_W K
+ IKMNH=MIN(COUNT(XZZ(IIMNH,IJMNH,:)< ZOBSALTlu),NKMAX+2-1)
+ IF ( IKMNH == 0 .AND. ZVALOBS /= XSPVAL ) THEN
+ print *,'obs under the first model level, stored at',&
+ ' k=1', ZOBSLONlu,ZOBSLATlu,ZOBSALTlu,ZVALOBS
+ IKMNH=1
+ ENDIF
+ IF ( IGRID == 4 ) THEN ! champ d obs sur la grille W
+ IKMNH=IKMNH+1
+ ENDIF
+ ! stocke le niveau max pour minimiser la taille du tableau a ecrire
+ IKMAX=MAX(IKMAX,IKMNH)
+ ELSE
+ IKMNH=1
+ ENDIF
+ ! stockage
+ if (ilocverbia >= 2 ) then
+ IKM1=MAX(IKMNH-1,1)
+ print *, ZOBSLONlu,ZOBSLATlu,ZOBSALTlu,ZVALOBS,IIMNH,IJMNH,IKMNH &
+ , XZZ(IIMNH,IJMNH,IKMNH),XZZ(IIMNH,IJMNH,IKM1)
+ endif
+ IF (ZVALOBS /= XSPVAL ) THEN
+ if (ilocverbia >= 2 ) then
+ print *,'before TO_COMPUTING_UNITS', ZVALOBS
+ endif
+ CALL TO_COMPUTING_UNITS(CGROUP,YUNITE,ZVALOBS)
+ if (ilocverbia >= 2 ) then
+ print *,'after TO_COMPUTING_UNITS', ZVALOBS
+ endif
+ ! Voir une amelioration en moyenne ponderee avec la distance :
+ ! serait utile pour des mailles tres grandes
+ if (ilocverbia >=3 ) then
+ print *, 'Storage indexes i,j,k=',IIMNH,IJMNH,IKMNH
+ endif
+ ZALTOBS(IIMNH,IJMNH,IKMNH)=ZOBSALTlu
+ ZOBSinMNH(IIMNH,IJMNH,IKMNH)=ZOBSinMNH(IIMNH,IJMNH,IKMNH)+ZVALOBS
+ ICPTOBSinMNH(IIMNH,IJMNH,IKMNH)=ICPTOBSinMNH(IIMNH,IJMNH,IKMNH)+1
+ ENDIF
+ !
+ inbval=inbval+1
+ ENDDO ! fin de boucle de lecture du fichier d obs
+GO TO 888
+886 CONTINUE
+ print *,' *** WARNING: in reading the date in the obs file ***'
+ print *,' not enough rows (4)'
+ GO TO 888
+887 CONTINUE
+ print *,' *** WARNING: in reading the obs file ***'
+ print *,' every record must contains 4 values'
+ print *,' or 3 in 2D'
+888 CONTINUE
+ !
+ print *, 'End of reading the input obs file'
+ CLOSE (UNIT=8)
+ ! suppression du lien
+ CALL CREATLINK('DIROBS',YFILEOBS,'CLEAN',ilocverbia)
+ print *, 'number of obs taken into account in the model grid= ', inbval
+ print *, 'number of obs out of domain not taken into account= ', inbvalrej
+ !
+ ! mise a indef des mailles MNH non concernées par les obs
+ !
+ WHERE ( ICPTOBSinMNH(:,:,:) == 0)
+ ZOBSinMNH(:,:,:)= XSPVAL
+ ZALTOBS(:,:,:)= XSPVAL
+ END WHERE
+ print *, 'number of meshes set to indef= ', COUNT(ICPTOBSinMNH(:,:,:) ==0)
+ print *, 'number of meshes initialised= ', COUNT(ICPTOBSinMNH(:,:,:) > 0)
+
+ IF ( (COUNT (ICPTOBSinMNH(:,:,:) > 0) ) == 0 ) THEN
+ print *, '**** no observation is localised into the model grid'
+ print *, ' the field is not written in the output diachronic file'
+ CYCLE
+ ENDIF
+ !
+ ! calcul eventuel de la moyenne des obs incluses dans les mailles mesonh
+ WHERE ( ICPTOBSinMNH(:,:,:) > 0) &
+ ZOBSinMNH(:,:,:)=ZOBSinMNH(:,:,:)/ICPTOBSinMNH(:,:,:)
+ print *, 'end of computation of the average on ',&
+ COUNT(ICPTOBSinMNH(:,:,:) >0) , ' meshes'
+ !
+ ! traitement particulier des composantes du vent
+ SELECT CASE (CGROUP(1:1))
+ CASE ('U','V')
+ IF ( .NOT. ALLOCATED (ZVENTSAVE) ) THEN
+ ALLOCATE(ZVENTSAVE( SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3), &
+ SIZE(XVAR,4),SIZE(XVAR,5),SIZE(XVAR,6) ))
+ ALLOCATE(ZWORK3D ( SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3) ))
+ ALLOCATE(ZWORK3D2( SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3) ))
+ print *, 'Treatment for the wind: storage of the zonal component 1'
+ ZWORK3D(:,:,:)=ZOBSinMNH(:,:,:)
+ print *, ' and treatement of the Obs file for the 2d component'
+ GO TO 777
+ ELSE
+ print *, 'Treatment for the wind: storage of the meridional component 2'
+ ZWORK3D2(:,:,:)=ZOBSinMNH(:,:,:)
+ CALL UV_TO_ZONAL_AND_MERID(ZWORK3D,ZWORK3D2,0, &
+ PZC=ZVENTSAVE(:,:,:,1,1,1), &
+ PMC=XVAR(:,:,:,1,1,1) )
+
+ print *,' after UV_TO_ZONAL_AND_MERID'
+ DEALLOCATE( ZWORK3D,ZWORK3D2)
+ ENDIF
+ ! Fin traitement particulier des composantes du vent
+ CASE DEFAULT
+ ! init du champ passe par module a writevar
+ XVAR(:,:,:,1,1,1)=ZOBSinMNH(:,:,:)
+ ENDSELECT
+ !
+ ! init des variables passees par module a writevar
+ NGRIDIA(1)=IGRID
+ CTITRE(1)=CGROUP
+ CCOMMENT(1)='from '//ADJUSTL(YFILEOBS)
+ CUNITE(1)=YUNITE
+ !
+ !* 3.3 Ecriture du tableau XVAR (module MODD_ALLOC_FORDIACHRO)
+ ! --------------------------------------------------
+ zmini=MINVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ zmaxi=MAXVAL(XVAR(:,:,:,:,:,:),MASK=XVAR(:,:,:,:,:,:)/=XSPVAL)
+ print * ,' After treatment, min,max of the field ',TRIM(CGROUP),'=', zmini,zmaxi
+ print *,' Writing in diachronic format'
+ if (ilocverbia >= 1 ) then
+ print *,'dimensions of XVAR ', SIZE(XVAR,1) , SIZE(XVAR,2), SIZE(XVAR,3)
+ endif
+ !
+ ivarideb=1
+ ivarifin=SIZE(XVAR,1)
+ ivarjdeb=1
+ ivarjfin=SIZE(XVAR,2)
+ ivarkdeb=1
+ if ( IKMAX <= 2 ) THEN
+ ivarkdeb= IKMAX
+ endif
+ ivarkfin=IKMAX
+ ivartinf=1
+ ivartsup=1
+ ivartrajinf=1
+ ivartrajsup=1
+ ivarprocinf=1
+ ivarprocsup=1
+ IF ( YSTOCK == '1D' ) THEN
+ ! tableaux 1D stockés pour permettre un trace diaprog en profil vertical
+ ivarideb=IIMNH
+ ivarifin=IIMNH
+ ivarjdeb=IJMNH
+ ivarjfin=IJMNH
+ print * ,' Storage of 1D profil, position i,j in the grid=',ivarideb,ivarjdeb
+ ENDIF
+ if (ilocverbia >= 2 ) then
+ print *,'before WRITEVAR',' input arguments ',&
+ ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ TRIM(CGROUP),' ',TRIM(YFILEOUTNAME),' ',TRIM(YFLAGWRITE),' ',&
+ TRIM(YFILEOUTSUFFIX),&
+ ilocverbia,iret
+ endif
+ CALL WRITEVAR(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ CGROUP,YFILEOUTNAME,YFLAGWRITE,YFILEOUTSUFFIX,ilocverbia,iret)
+
+ print *, ' WRITEVAR, return value for (',TRIM(CGROUP),')= ',iret
+ IF ( iret /= 0 ) THEN
+ print *,'** Error when writing in the file: ',TRIM(YFILEOUTNAME)
+ STOP
+ ENDIF
+ !
+ ! traitement eventuel de la 2e composante du vent
+ IF ( ALLOCATED (ZVENTSAVE) ) THEN
+ XVAR(:,:,:,:,:,:)= ZVENTSAVE(:,:,:,:,:,:)
+ CGROUP='U'//CGROUP(2:)
+ CTITRE(1)='U'//CGROUP(2:)
+ if (ilocverbia >= 2 ) then
+ print *,'before WRITEVAR',' input arguments ',&
+ ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ TRIM(CGROUP),' ',TRIM(YFILEOUTNAME),' ',TRIM(YFLAGWRITE),' ',&
+ TRIM(YFILEOUTSUFFIX),&
+ ilocverbia,iret
+ endif
+ CALL WRITEVAR(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ CGROUP,YFILEOUTNAME,YFLAGWRITE,YFILEOUTSUFFIX,ilocverbia,iret)
+
+ print *, ' WRITEVAR, return value for (',TRIM(CGROUP),')= ',iret
+ IF ( iret /= 0 ) THEN
+ print *,'** Error when writing in the file: ',TRIM(YFILEOUTNAME)
+ STOP
+ ENDIF
+ DEALLOCATE (ZVENTSAVE)
+ ENDIF
+ !
+ IF (YSTOCK == '2D' ) THEN
+ !IF (COUNT(ZALTOBS(:,:,:) /= XSPVAL) /= 0) THEN
+ IF (galtobs) THEN
+ ! stockage egalement de l altitude des obs comme champ diachronique
+ XVAR(:,:,:,1,1,1)=ZALTOBS(:,:,:)
+ NGRIDIA(1)=1
+ CTITRE(1)='ALT_'//ADJUSTL(CGROUP)
+ CCOMMENT(1)='from '//ADJUSTL(YFILEOBS)
+ CUNITE(1)='m'
+ if (ilocverbia >= 2 ) then
+ print *,'before WRITEVAR',' input arguments ',&
+ ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ TRIM(CGROUP),' ',TRIM(YFILEOUTNAME),' ',TRIM(YFLAGWRITE),' ',&
+ TRIM(YFILEOUTSUFFIX),ilocverbia,iret
+ endif
+ CALL WRITEVAR(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ CTITRE(1),YFILEOUTNAME,YFLAGWRITE,YFILEOUTSUFFIX,ilocverbia,iret)
+
+ print *, 'WRITEVAR, return value (',TRIM(CTITRE(1)),')= ',iret
+ IF ( iret /= 0 ) THEN
+ print *,'** Error when writing in the file: ',TRIM(YFILEOUTNAME)
+ STOP
+ ENDIF
+ ELSE
+ print * , ' No altitudes in the Obs file: no field ALT_'//ADJUSTL(CGROUP)
+ ENDIF
+ ENDIF
+ !
+ ! + stockage du nombre d obs par point de grille comme champ diachronique
+ XVAR(:,:,:,1,1,1)=ICPTOBSinMNH(:,:,:)
+ NGRIDIA(1)=1
+ CTITRE(1)='N_'//ADJUSTL(CGROUP)
+ CCOMMENT(1)='from '//ADJUSTL(YFILEOBS)
+ CUNITE(1)='count'
+ if (ilocverbia >= 2 ) then
+ print *,'before WRITEVAR',' input arguments ',&
+ ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup,&
+ TRIM(CTITRE(1)),' ',TRIM(YFILEOUTNAME),' ',TRIM(YFLAGWRITE),' ',&
+ TRIM(YFILEOUTSUFFIX),&
+ ilocverbia,iret
+ endif
+ CALL WRITEVAR(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ CTITRE(1),YFILEOUTNAME,YFLAGWRITE,YFILEOUTSUFFIX,ilocverbia,iret)
+
+ print *, 'WRITEVAR return value (',TRIM(CTITRE(1)),')= ',iret
+ IF ( iret /= 0 ) THEN
+ print *,'** Error when writing in the file: ',TRIM(YFILEOUTNAME)
+ STOP
+ ENDIF
+ !
+ENDDO ! boucle fichier obs a traiter
+!
+! Fin de boucle sur les fichiers d obs
+! pour clore le traitement meme si la liste des champs est
+! incomplete ( non terminee par END)
+88 CONTINUE
+YFILEOBS='END'
+!
+!---------------------------------------------------------------------------
+!
+!* 4. Fermeture fichiers
+! ------------------
+!
+IF ( YFILEOBS(1:3) == 'END' ) THEN
+ PRINT*, 'END -> Close the output file'
+ YFLAGWRITE='CLO'
+ ! dans cet appel seul l argument YFLAGWRITE est pris en compte, tous
+ ! les autres arguments sont ignorés
+ CALL WRITEVAR(ivarideb,ivarifin,ivarjdeb,ivarjfin,ivarkdeb,ivarkfin,&
+ ivartinf,ivartsup,ivartrajinf,ivartrajsup,ivarprocinf,ivarprocsup, &
+ CGROUP,YFILEOUTNAME,YFLAGWRITE,YFILEOUTSUFFIX,ilocverbia,iret)
+ print *, 'WRITEVAR, return value=',iret
+ IF ( iret > 0 ) THEN
+ print *,'** Error when closing the file: ',TRIM(YFILEOUTNAME)
+ ENDIF
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. Fin de programme
+! ------------------
+!
+99 CONTINUE
+!
+! Suppression de tous les liens eventuellement crees
+YDUMMYFILE=''
+CALL CREATLINK(' ',YDUMMYFILE,'CLEAN',ilocverbia)
+PRINT*, 'The file ',TRIM(YLUDIR),' stores all the input directives'
+PRINT*, ' you must give a new name to use it again'
+CLOSE(ILUDIR)
+!
+IF (iret==0) THEN
+ print *,'================'
+ IF (YFILEOUTSUFFIX /= 'NEN' ) THEN
+ PRINT*, 'Output files *',TRIM(YFILEOUTSUFFIX), '.lfi are available'
+ ELSE
+ PRINT*, 'Output file ', TRIM(YFILEOUTNAME), '.lfi is available'
+ ENDIF
+ PRINT*, ' Use LCOLAREA=T and LSPOT=T in diaprog to plot the fields'
+ENDIF
+!
+END PROGRAM OBS2MESONH
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/readvar.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/readvar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..63e9db135b69a7e25d7da782d3586daa0bd68608
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/readvar.f90
@@ -0,0 +1,545 @@
+! ######
+ SUBROUTINE READVAR(HLABELCHAMP,HFILENAME,HFLAGFILE,&
+ KVERBIA,KRETCODE)
+! ################
+!
+!!**** *READVAR* -
+!!
+!!
+!! PURPOSE
+!! -------
+! Extraction d un champ du fichier diachronique et initialisation
+! des differents parametres utiles (grille, relief...)
+!
+!
+!!** METHOD
+!! ------
+! utilisation des routines de diaprog : le tableau de stockage
+! XVAR est alloué par les routines de lecture.
+!
+! au maximum 44 fichiers simultanement ouverts
+! 44 =limite FMOPEN= (JPNXFM-10)/2 avec JPNXFM=99
+!
+! HFLAGFILE='OPE' lors de la premiere utilisation du fichier
+! HFLAGFILE='NOP' lors des utilisations suivantes
+! HFLAGFILE='CLO' fermeture du fichier traite ( decremente
+! le nombre de fichiers ouverts comptabilises par FMOPEN)
+!
+! KVERBIA= 0 impressions reduites au minimum (entree et sortie de la
+! routine)
+! KVERBIA >0 impressions pour signaler chaque etape de READVAR
+!
+! KRETCODE = 0 execution de READVAR correcte
+! KRETCODE = 1 erreur lors de l ouverture du fichier
+! KRETCODE = 2 champ inconnu dans le fichier
+! KRETCODE = 3 Nombre de fichiers ouverts simultanement > limite
+!
+!!
+!! EXTERNAL
+!! --------
+!! CREATLINK : à l'ouverture du fichier, HFLAGFILE='OPE',
+!! création d'un lien dans le directory local
+!! si le fichier existe sous $DIRLFI
+!! TO_COMPUTING_UNITS: passage unites vers unites plus pertinentes
+!! pour effectuer des calculs
+!!
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHORS
+!! -------
+!! I. Mallet et N. Asencio * CNRM*
+!!
+!! Copyright 2003, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 17/03/2003
+!! N. Asencio 01/2005 call To_Computing_units
+!! G. TANGUY 03/2010 problème pour les champs sur point de flux
+! on remplace les 999 sur les mailles à côtés des bords du domaine
+! par la valeur la plus proche dans le domaine zoomé
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+! modules MesoNH
+USE MODD_PARAMETERS, ONLY: XUNDEF,JPHEXT
+USE MODD_DIM1, ONLY: NIMAX,NJMAX,NKMAX
+USE MODD_GRID1, ONLY: XZZ
+! modules DIACHRO
+! grille : XXDXHAT(:,1:7) et XXX(:,1:7), XXZS(:,:,1:7)
+USE MODD_COORD
+USE MODD_TYPE_AND_LH, ONLY: NIL,NIH,NJL,NJH,NKL,NKH,CTYPE,LICP,LJCP,LKCP
+! XVAR(i,j,k,,,), XMASK,XTRAJ ,XDATIME(16,t) ,CUNITE(p)
+USE MODD_ALLOC_FORDIACHRO
+! nom de fichiers NLUOUT,CLFIFM, CDESFM
+USE MODD_OUT
+USE MODD_FILES_DIACHRO, ONLY: NBFILES,CFILEDIAS,CLUOUTDIAS,NRESPDIAS, &
+ NLUOUTDIAS, NNPRARDIAS, NFTYPEDIAS, &
+ NNINARDIAS, NVERBDIAS
+!
+USE MODD_DIACHRO, ONLY:CFILEDIA
+!
+USE MODI_FMREAD
+USE MODI_READ_DIACHRO
+USE MODI_VERIF_GROUP
+USE MODI_ALLOC_FORDIACHRO
+!
+! modules TOOL
+USE MODI_CREATLINK
+! modules EXTRACTDIA
+USE MODI_TO_COMPUTING_UNITS
+USE MODD_READLH
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+!
+CHARACTER(LEN=*), INTENT(IN) :: HLABELCHAMP, HFILENAME ! nom du champ et du fichier
+CHARACTER(LEN=3), INTENT(INOUT) :: HFLAGFILE ! ouverture/ deja ouvert
+INTEGER, INTENT(IN) :: KVERBIA ! prints de controle
+!
+INTEGER, INTENT(OUT) :: KRETCODE ! Code de retour de la routine
+!
+!* 0.2 Local variables
+! ---------------
+!
+CHARACTER(LEN=13) :: YGP ! limite a 13 (ou 9 si plusieurs procs)
+ !car read_diachro lit YRECFM(1:16)=YGP//'.PROCnn'
+CHARACTER(LEN=32) :: YDESFM
+INTEGER :: JLOOP,JLOOPFIN,JI
+INTEGER :: IRESP,ILUDES
+INTEGER :: ILENG, ILENCH, IGRID, ILENDIM, IGROUP
+INTEGER :: idim3
+INTEGER,DIMENSION(:),ALLOCATABLE :: ITABCHAR
+CHARACTER(LEN=16) :: YRECFM
+CHARACTER(LEN=20) :: YCOMMENT
+CHARACTER(LEN=16),DIMENSION(:),ALLOCATABLE :: YGROUP
+! pour traiter les champs budget deja zoomes
+REAL , allocatable, dimension(:,:,:,:,:,:):: ZVARSAVE !
+!-------------------------------------------------------------------------------
+!
+!* 1. INITIALISATION
+! --------------
+!
+print *,'---------'
+print *,'Beginning of READVAR ',TRIM(HFILENAME),' ',HFLAGFILE,' ',TRIM(HLABELCHAMP)
+!
+! Code de retour de la routine : 0 = OK
+! 1 = erreur lors de l ouverture du fichier
+! 2 = champ inconnu
+! 3 = erreur sur le nombre de fichier
+IF ( HFLAGFILE /= 'OPE' .AND. HFLAGFILE /= 'NOP' .AND. HFLAGFILE /= 'CLO' ) THEN
+ KRETCODE=1
+ print * ,'erreur d initialisation de HFLAGFILE =', HFLAGFILE
+ print * ,'HFLAGFILE peut prendre les valeurs: OPE,NOP,CLO'
+ print *,'---------'
+ RETURN
+ENDIF
+
+KRETCODE=0
+! code de retour d erreur des routines diaprog
+LPBREAD=.FALSE.
+!
+IF(ALLOCATED(XVAR))THEN
+! desallocation des tableaux alloues dans READ_DIACHRO (via ALLOC_FOR_DIACHRO)
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ if (KVERBIA >0)then
+ print *,'*after ALLOC_FORDIACHRO(1,1,1,1,1,1,3)'
+ endif
+ENDIF
+!-------------------------------------------------------------------------------
+!
+!* 2. CLOSE THE FILE
+! --------------
+!
+IF ( HFLAGFILE(1:3) == 'CLO' ) THEN
+ CALL FMCLOS(HFILENAME,'KEEP',CLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
+ !! FMFREE ne relache pas l unite logique pour .lfi car .des deja relache
+ DO JLOOP=1,NBFILES
+ ! reperage de l indice de CFILEDIAS pour le fichier HFILENAME
+ IF (CFILEDIAS(JLOOP) == HFILENAME ) THEN
+ ! decalage du tableau CFILEDIAS pour supprimer cet element
+ DO JLOOPFIN= JLOOP,NBFILES-1
+ CFILEDIAS(JLOOPFIN)=CFILEDIAS(JLOOPFIN+1)
+ CLUOUTDIAS(JLOOPFIN)=CLUOUTDIAS(JLOOPFIN+1)
+ NLUOUTDIAS(JLOOPFIN)=NLUOUTDIAS(JLOOPFIN+1)
+ NNPRARDIAS(JLOOPFIN)=NNPRARDIAS(JLOOPFIN+1)
+ NFTYPEDIAS(JLOOPFIN)=NFTYPEDIAS(JLOOPFIN+1)
+ NVERBDIAS(JLOOPFIN)=NVERBDIAS(JLOOPFIN+1)
+ ENDDO
+ ! suppression du lien
+ CALL CREATLINK('DIRLFI',CFILEDIAS(JLOOP),'CLEAN',KVERBIA)
+ EXIT
+ ENDIF
+ ENDDO
+ NBFILES=NBFILES-1
+ print *,'End of READVAR: close of file ',TRIM(HFILENAME)
+ print *,'---------'
+ RETURN
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. OPEN THE FILE (first call)
+! --------------------------
+!
+IF ( HFLAGFILE(1:3) == 'OPE' ) THEN
+!
+ if (KVERBIA >0)then
+ print'(A23,I2,A17)','*before OPENning file, ',NBFILES,' currently opened'
+ endif
+! utilisation de tableaux et de NBFILES pour calquer la methode
+! diaprog et permettre le traitement de plusieurs fichiers simultanement
+ NBFILES=NBFILES+1
+ !IF (NBFILES > 44 ) THEN
+ ! 44 =limite FMOPEN= (JPNXFM-10)/2 avec JPNXFM=99
+ !!limite >44 car fmfree de file.des
+ !KRETCODE=3
+ !print *,' ****READVAR: pour FMOPEN erreur nb de fichiers ouverts >44 ',&
+ ! ' nbfiles= ',NBFILES
+ !RETURN
+ !ENDIF
+ IF (NBFILES > size(CFILEDIAS) ) THEN
+ KRETCODE=3
+ print'(A58,I3,A10,I3)',' ****READVAR: pour diachro erreur nb de fichiers ouverts > ',&
+ size(CFILEDIAS), ' nbfiles= ',NBFILES
+ print *,'---------'
+ RETURN
+ ENDIF
+ CFILEDIAS(NBFILES)=HFILENAME
+ CLUOUTDIAS(NBFILES)=CLUOUTDIAS(1)
+ NNPRARDIAS(NBFILES)=0
+ NFTYPEDIAS(NBFILES)= NFTYPEDIAS(1)
+ NVERBDIAS(NBFILES)=KVERBIA
+ ! listing OUT_DIA
+ CALL FMLOOK(CLUOUTDIAS(NBFILES),CLUOUTDIAS(NBFILES),&
+ NLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
+ IF (NRESPDIAS(NBFILES)/=0) THEN
+ ! ouverture du listing
+ CALL FMATTR(CLUOUTDIAS(NBFILES),CLUOUTDIAS(NBFILES),&
+ NLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
+ OPEN(UNIT=NLUOUTDIAS(NBFILES),FILE=CLUOUTDIAS(NBFILES),&
+ FORM='FORMATTED')
+ END IF
+ ! fichier diachronique
+ CALL CREATLINK('DIRLFI',CFILEDIAS(NBFILES),'CREAT',KVERBIA)
+ CALL FMOPEN(CFILEDIAS(NBFILES),'OLD',CLUOUTDIAS(NBFILES),&
+ NNPRARDIAS(NBFILES),NFTYPEDIAS(NBFILES),NVERBDIAS(NBFILES),&
+ NNINARDIAS(NBFILES),NRESPDIAS(NBFILES))
+! apres cet appel , variables initialisees:
+! NINARDIAS(NBFILES)= nb d articles dans le fichier
+! NRESPDIAS(NBFILES)= code de retour
+! une unite logique pour HFILENAME.des et HFILENAME.lfi
+!
+ if (KVERBIA >0)then
+ print'(A,A,A,5(I5,X))','*after OPENning files ',&
+ TRIM(CFILEDIAS(NBFILES)),&
+ TRIM(CLUOUTDIAS(NBFILES)),NNPRARDIAS(NBFILES), &
+ NFTYPEDIAS(NBFILES),NVERBDIAS(NBFILES),&
+ NNINARDIAS(NBFILES),NRESPDIAS(NBFILES)
+ endif
+ !
+ IF (NRESPDIAS(NBFILES).NE.0)THEN
+ KRETCODE=1
+ print'(A52,A20,A6,I3)',' ****READVAR: erreur lors de l ouverture du fichier ',&
+ CFILEDIAS (NBFILES), 'code= ',NRESPDIAS(NBFILES)
+ print *,'---------'
+ RETURN
+ ENDIF
+ !
+ ! partie DES du fichier: fermeture et unite logique relachee
+ !YDESFM(1:LEN(YDESFM))=' '
+ !YDESFM=ADJUSTL(ADJUSTR(CFILEDIAS(NBFILES))//'.des')
+ !CALL FMLOOK(YDESFM,YDESFM,ILUDES,IRESP)
+ !CLOSE(ILUDES)
+ !CALL FMFREE(YDESFM,CLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
+!! ne pas relacher unite logique car compute_r00_pc doit fermer (avec FMCLOS)
+!!le fic. d entree qui a ete amende des var. Lag.
+!
+! READ JPHEXT
+ CALL FMREAD(CFILEDIAS(NBFILES),'JPHEXT',CLUOUTDIAS(NBFILES),1,JPHEXT,IGRID,ILENCH,YCOMMENT,NRESPDIAS(NBFILES))
+
+!* 3.1 Reading head of file
+! --------------------
+!
+ CALL READ_FILEHEAD(1,HFILENAME,CLUOUTDIAS(NBFILES))
+ if (KVERBIA >0)then
+ print'(A41,3(I4,X))','*after READ_FILEHEAD, NIMAX,NJMAX,NKMAX= ',&
+ NIMAX,NJMAX,NKMAX
+ endif
+ !
+ ! lecture de MENU_BUDGET.DIM, MENU_BUDGET
+ ! appel a INI_CST
+ ! appel a READ_DIMGRIDREF: appel a SET_DIM pour lecture de IMAX, J,K-MAX
+ ! et calcul de I,J,K-INF,SUP
+ ! lecture de CARTESIAN,THINSHELL,STORAGE_TYPE
+ ! appel a SET_GRID
+ ! appel a COMPCOORD_FORDIACHRO(0): pour les 7 grilles,
+ ! calcul de X,Y,Z-HAT(m) dans XXX,XXY,XXZ(:,1:7) ! (MODD_COORD)
+ ! de topography altitude values(m):XXZS(:,:,1:7) ! (MODD_COORD)
+ ! de meshsize values XXDXHAT,XXDYHAT(:,1:7) ! (MODD_COORD)
+
+ ! apres cette lecture, les variables suivantes sont disponibles:
+ ! NIMAX,NJMAX,NKMAX , apres SETDIM, LCARTESIAN, LTHINSHELL,CSTORAGE_TYPE,
+ ! NGRID
+ ! XXHAT(IIU) pour la grille de U
+ ! XYHAT(IJU) pour la grille de V
+ ! XZHAT(IIU)
+ ! XMAP(IIU,IJU)
+ ! XLAT(IIU,IJU) pour la grille de masse
+ ! XLON(IIU,IJU) pour la grille de masse
+ ! XDXHAT(IIU),XDYHAT(IJU)
+ ! XZS(IIU,IJU)
+ ! XZZ(IIU,IJU,IKU) pour la grille W
+ ! TDTMOD,TDTCUR,TDTEXP,TDTSEG,
+ ! NSTOP,NOUT_TIMES,NOUT_NUMB, XTSTEP,XSEGLEN,
+ !
+ CALL COMPCOORD_FORDIACHRO(4) ! NGRID set to 4 then XZZ is the true height
+ !of w-point as in the model
+ if (KVERBIA >0)then
+ print *,'*after COMPCOORD_FORDIACHRO(4)'
+ endif
+ !
+ ! indiquera au prochain appel de READVAR que le fichier courant
+ !est deja ouvert (lecture du champ sans init des modules)
+ HFLAGFILE(1:3)='NOP'
+ENDIF
+!-------------------------------------------------------------------------------
+!
+!* 4. LIST OF GROUPS
+! --------------
+!
+IF(HLABELCHAMP(1:5)=='GROUP')THEN
+ print *,'*following groups are present in the file ',TRIM(HFILENAME)
+ ILENDIM=1
+ YRECFM='MENU_BUDGET.DIM'
+ CALL FMREAD(HFILENAME,YRECFM,CLUOUTDIAS(NBFILES),ILENDIM,ILENG,&
+ IGRID,ILENCH,YCOMMENT,NRESPDIAS(NBFILES))
+ IF(NRESPDIAS(NBFILES) == -47)THEN
+ print *,' No record MENU_BUDGET '
+ RETURN
+ ENDIF
+ ALLOCATE(ITABCHAR(ILENG))
+ YRECFM='MENU_BUDGET'
+ CALL FMREAD(HFILENAME,YRECFM,CLUOUTDIAS(NBFILES),ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,NRESPDIAS(NBFILES))
+ IGROUP=ILENG/16
+ ALLOCATE(YGROUP(IGROUP))
+ DO JLOOP=1,IGROUP
+ DO JI= 1,16
+ YGROUP(JLOOP)(JI:JI)=CHAR(ITABCHAR(16*(JLOOP-1)+JI))
+ ENDDO
+ ENDDO
+ print *,'****************************** GROUPS *****************************'
+ print 100,(YGROUP(JLOOP),JLOOP=1,IGROUP)
+100 FORMAT(1X,5A15)
+ DEALLOCATE(ITABCHAR,YGROUP)
+!
+ELSE
+!-------------------------------------------------------------------------------
+!
+!* 5. TEST IF GROUP EXISTS
+! --------------------
+!
+YGP=HLABELCHAMP
+CALL VERIF_GROUP(HFILENAME,CLUOUTDIAS(NBFILES),YGP)
+IF(LPBREAD)THEN
+ print *,' ****READVAR: Groupe ',TRIM(YGP),' inconnu dans le fichier ', &
+ TRIM(HFILENAME)
+ KRETCODE=2
+ LPBREAD=.FALSE.
+ print *,'---------'
+ RETURN
+ENDIF
+CFILEDIA=HFILENAME
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. READ GROUP
+! ----------
+!
+if (KVERBIA >0)then
+ print *,'*before READ_DIACHRO'
+endif
+!
+CALL READ_DIACHRO(HFILENAME,CLUOUTDIAS(NBFILES),YGP)
+if (KVERBIA >0)then
+ print *,'*after READ_DIACHRO'
+endif
+!
+! lecture d'un enregistrement de nom CGROUP (en fait plusieurs enregistrements
+!lus dans les variables suivantes:
+!CGROUP//'.TYPE' => CTYPE('CART','MASK','SPXY','SSOL','RSPL','DRST','RAPL')
+ ! MODD_TYPE_AND_LH
+!CGROUP//'.DIM' si CTYPE='CART','MASK','SPXY'
+! NIL,NJL,NKL,NIH,NJH,NKH,LICP,LJCP,LKCP ! MODD_TYPE_AND_LH
+! = zoom inside the complete x-y-zgrid
+! appel de ALLOC_FORDIACHRO pour allouer les var. suivantes
+!CGROUP//'.TITRE' =>CTITRE(p) ! MODD_ALLOC_FORDIACHRO
+!CGROUP//'.UNITE' =>CUNITE(p) ! MODD_ALLOC_FORDIACHRO
+!CGROUP//'.COMMENT' =>COMMENT(p) ! MODD_ALLOC_FORDIACHRO
+!CGROUP//'.PROCp' =>XVAR(i,j,k,t,n,p),NGRIDIA(p) ! MODD_ALLOC_FORDIACHRO
+!CGROUP//'.TRAJT' =>XTRAJT(t,n) ! MODD_ALLOC_FORDIACHRO
+!
+!CGROUP//'.TRAJX' =>XTRAJX(k,t,n) optional ! MODD_ALLOC_FORDIACHRO
+!CGROUP//'.TRAJY' =>XTRAJY(k,t,n) " ! MODD_ALLOC_FORDIACHRO
+!CGROUP//'.TRAJZ' =>XTRAJZ(k,t,n) " ! MODD_ALLOC_FORDIACHRO
+!CGROUP//'.MASK' =>XMASK(i,j,1,t,n,1) " (si CTYPE='MASK')! MODD_ALLOC_FORDIACHRO
+!CGROUP//'.DATIM' =>XDATIME(16,t) ! MODD_ALLOC_FORDIACHRO
+! EXP.YEAR=XDATIME(1,t); EXP.MONTH=XDATIME(2,t)
+! EXP.DAY=XDATIME(3,t) ; EXP.TIME=XDATIME(4,t)
+! SEG.YEAR=XDATIME(5,t); SEG.MONTH=XDATIME(6,t)
+! SEG.DAY=XDATIME(7,t); SEG.TIME=XDATIME(8,t)
+! MOD.YEAR=XDATIME(9,t); MOD.MONTH=XDATIME(10,t)
+! MOD.DAY=XDATIME(11,t) ; MOD.TIME=XDATIME(12,t)
+! CUR.YEAR=XDATIME(13,t); CUR.MONTH=XDATIME(14,t)
+! CUR.DAY=XDATIME(15,t); CUR.TIME=XDATIME(16,t)
+!
+
+! Passage a des unites plus pertinentes pour calculs si necessaire
+CALL TO_COMPUTING_UNITS(YGP,CUNITE(1))
+!
+! Traitement d un champ eventuellement zoome
+!
+IF (CTYPE == 'CART' .AND. .NOT. LICP .AND. .NOT. LJCP ) THEN
+ IF( SIZE(XVAR,1) /= SIZE(XZZ,1) .OR. SIZE(XVAR,2) /= SIZE(XZZ,2) )THEN
+ ! replace le zoom dans le domaine total avant tout autre traitement
+ !pour avoir les memes indices pour XLON,XLAT et ZHAT et XVAR
+ if (KVERBIA > 0 ) then
+ print *,' Replace un champ zoome dans le domaine total:'
+ print'(A19,3(I4,X))','NIMAX,NJMAX,NKMAX= ',NIMAX,NJMAX,NKMAX
+ print'(A25,6(I4,X))','nil,nih,njl,njh,nkl,nkh= ',nil,nih,njl,njh,nkl,nkh
+ endif
+ ! sauve XVAR
+ ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+ size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+ ZVARSAVE=XVAR
+ if (KVERBIA > 0 ) then
+ print *,'dimensions 4 5 6 :'
+ print'(3(I5,x))',size(ZVARSAVE,4),size(ZVARSAVE,5),size(ZVARSAVE,6)
+ endif
+ DEALLOCATE(XVAR)
+ idim3=SIZE(XZZ,3)
+ IF (SIZE(ZVARSAVE,3) /= SIZE(XZZ,3)) THEN
+ IF (SIZE(ZVARSAVE,3)/=1 )THEN
+ !champ 3D zoome selon k
+ idim3=SIZE(XZZ,3)
+ ELSE
+ !champ 2D
+ idim3=SIZE(ZVARSAVE,3)
+ ENDIF
+ ENDIF
+ ! nouveau XVAR= domaine total
+ ALLOCATE(XVAR(SIZE(XZZ,1),SIZE(XZZ,2),idim3,&
+ SIZE(ZVARSAVE,4),SIZE(ZVARSAVE,5),SIZE(ZVARSAVE,6)))
+ ! init seulement du zoom lu stocke dans ZVARSAVE
+ XVAR=XUNDEF
+ XVAR(nil:nih,njl:njh,nkl:nkh,:,:,:)=ZVARSAVE(:,:,:,:,:,:)
+ DEALLOCATE (ZVARSAVE)
+
+ !! GAELLE mars 2010
+ IF (nil /= 1) THEN
+ XVAR(nil-1,:,:,:,:,:)=XVAR(nil,:,:,:,:,:)
+ ENDIF
+ IF (nih /= SIZE(XZZ,1) ) THEN
+ XVAR(nih+1,:,:,:,:,:)= XVAR(nih,:,:,:,:,:)
+ ENDIF
+ IF (njl /= 1) THEN
+ XVAR(:,njl-1,:,:,:,:)=XVAR(:,njl,:,:,:,:)
+ ENDIF
+ IF(njh /= SIZE(XZZ,2) ) THEN
+ XVAR(:,njh+1,:,:,:,:)=XVAR(:,njh,:,:,:,:)
+ ENDIF
+ IF (nkl /= 1) THEN
+ XVAR(:,:,nkl-1,:,:,:)=XVAR(:,:,nkl,:,:,:)
+ ENDIF
+ IF(nkh /= idim3) THEN
+ XVAR(:,:,nkh+1,:,:,:)=XVAR(:,:,nkh,:,:,:)
+ ENDIF
+ !! GAELLE mars 2010
+
+! ENDIF
+ ENDIF
+ENDIF
+!
+! Traitement d un champ partiellement ecrit
+!
+IF (CTYPE == 'CART' .AND. .NOT. LKCP) THEN
+ IF( SIZE(XVAR,3) /= SIZE(XZZ,3) )THEN
+ if (KVERBIA > 0 ) then
+ print *,' Replace un champ partiellement ecrit dans le domaine total:'
+ print'(A7,I3)','NKMAX= ',NKMAX
+ print'(A9,2(I3,X))','nkl,nkh= ',nkl,nkh
+ endif
+ ALLOCATE(ZVARSAVE(size(XVAR,1),size(XVAR,2),size(XVAR,3), &
+ size(XVAR,4),size(XVAR,5),size(XVAR,6)) )
+ ZVARSAVE=XVAR
+ IF (SIZE(ZVARSAVE,3)/=1 )THEN
+ !champ 3D zoome selon k
+ idim3=SIZE(XZZ,3)
+ ELSE
+ !champ 2D
+ idim3=SIZE(ZVARSAVE,3)
+ ENDIF
+ print*,idim3
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(SIZE(ZVARSAVE,1),SIZE(ZVARSAVE,2),idim3,&
+ SIZE(ZVARSAVE,4),SIZE(ZVARSAVE,5),SIZE(ZVARSAVE,6)))
+ XVAR=XUNDEF
+ XVAR(:,:,nkl:nkh,:,:,:)=ZVARSAVE(:,:,:,:,:,:)
+ !! GAELLE mars 2010
+ IF (nkl /= 1) THEN
+ XVAR(:,:,nkl-1,:,:,:)=XVAR(:,:,nkl,:,:,:)
+ ENDIF
+ print*,nkh,idim3
+ IF(nkh /= idim3) THEN
+ XVAR(:,:,nkh+1,:,:,:)=XVAR(:,:,nkh,:,:,:)
+ ENDIF
+ !! GAELLE mars 2010
+
+ DEALLOCATE (ZVARSAVE)
+ ENDIF
+ENDIF
+!
+NREADIL=1 ; NREADIH=SIZE(XVAR,1)
+NREADJL=1 ; NREADJH=SIZE(XVAR,2)
+NREADKL=1 ; NREADKH=SIZE(XVAR,3)
+IF (CTYPE=='CART' .OR. CTYPE=='MASK' .OR. CTYPE=='SPXY') THEN
+ IF (.NOT. LICP) THEN
+ NREADIL=NIL ; NREADIH=NIH
+ END IF
+ IF (.NOT. LJCP) THEN
+ NREADJL=NJL ; NREADJH=NJH
+ END IF
+ IF (.NOT. LKCP) THEN
+ NREADKL=NKL ; NREADKH=NKH
+ END IF
+ENDIF
+if (KVERBIA >= 0) then
+ print*,'End of READVAR: the group ',&
+ TRIM(YGP),' of file ',TRIM(HFILENAME),&
+ ' is available in the XVAR array with sizes'
+ print'(A4,I4,5(A5,I4))',' 1:',SIZE(XVAR,1),',1:',SIZE(XVAR,2),',1:',SIZE(XVAR,3),&
+ ',1:',SIZE(XVAR,4),',1:',SIZE(XVAR,5),',1:',SIZE(XVAR,6)
+ IF (CTYPE=='CART' .OR. CTYPE=='MASK' .OR. CTYPE=='SPXY') THEN
+ print'(A90,6(I4,A))',&
+ '(initialized in the zoom (NREADIL:NREADIH,NREADJL:NREADJH,NREADKL:NREADKH)= ',&
+ NREADIL,':',NREADIH,',',NREADJL,':',NREADJH,',',NREADKL,':',NREADKH,')'
+ END IF
+endif
+!
+ENDIF ! HLABELCHAMP(1:5)/='GROUP'
+print *,'---------'
+!
+END SUBROUTINE READVAR
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/temporal_dist_for_ext.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/temporal_dist_for_ext.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1f7a95a838c1c5a45ba7b73f35c7813efb163b91
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/temporal_dist_for_ext.f90
@@ -0,0 +1,212 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/mesonh/sources/operators/s.temporal_dist.f90, Version:1.6, Date:98/06/23, Last modified:98/06/04
+!-----------------------------------------------------------------
+! #########################
+ MODULE MODI_TEMPORAL_DIST_FOR_EXT
+! #########################
+INTERFACE
+ SUBROUTINE TEMPORAL_DIST_FOR_EXT(KYEARF, KMONTHF, KDAYF, PSECF, &
+ KYEARI, KMONTHI, KDAYI, PSECI, &
+ PDIST )
+!
+INTEGER, INTENT(IN) :: KYEARF ! year of Final date
+INTEGER, INTENT(IN) :: KMONTHF ! month of Final date
+INTEGER, INTENT(IN) :: KDAYF ! day of Final date
+INTEGER, INTENT(IN) :: PSECF ! number of seconds since date at 00 UTC
+ ! of Final date
+INTEGER, INTENT(IN) :: KYEARI ! year of Initial date
+INTEGER, INTENT(IN) :: KMONTHI ! month of Initial date
+INTEGER, INTENT(IN) :: KDAYI ! day of Initial date
+INTEGER, INTENT(IN) :: PSECI ! number of seconds since date at 00 UTC
+ ! of Initial date
+INTEGER, INTENT(OUT):: PDIST ! temporal distance in secunds
+ !between the final and initial date
+!
+END SUBROUTINE TEMPORAL_DIST_FOR_EXT
+!
+END INTERFACE
+!
+END MODULE MODI_TEMPORAL_DIST_FOR_EXT
+!
+! #############################################################
+ SUBROUTINE TEMPORAL_DIST_FOR_EXT(KYEARF, KMONTHF, KDAYF, PSECF, &
+ KYEARI, KMONTHI, KDAYI, PSECI, &
+ PDIST )
+! #############################################################
+!
+!!**** *TEMPORAL_DIST* - finds the number of secunds between 2 dates
+!!
+!! PURPOSE
+!! -------
+!!
+!! WARNING
+!!
+!! -----> Only correct for dates between 19900301 and 21000228 <-----
+!!
+!! The correct test should be:
+!! IF( ((MOD(KYEAR,4)==0).AND.(MOD(KYEAR,100)/=0)) .OR. (MOD(KYEAR,400)==0))THEN
+!!
+!!** METHOD
+!! ------
+!!
+!! A comparison term by term of the elements of the 2 dates is performed.
+!! and the temporal distance between the 2 dates is then deduced.
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book 2
+!!
+!! AUTHOR
+!! ------
+!!
+! J.Stein Meteo-France
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 02/01/96
+!! Modification02/09/03 (N.Asencio) PDIST must be in DOUBLE PRECISION
+!! for several years gap
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declaration of arguments
+! ------------------------
+INTEGER, INTENT(IN) :: KYEARF ! year of Final date
+INTEGER, INTENT(IN) :: KMONTHF ! month of Final date
+INTEGER, INTENT(IN) :: KDAYF ! day of Final date
+INTEGER, INTENT(IN) :: PSECF ! number of seconds since date at 00 UTC
+ ! of Final date
+INTEGER, INTENT(IN) :: KYEARI ! year of Initial date
+INTEGER, INTENT(IN) :: KMONTHI ! month of Initial date
+INTEGER, INTENT(IN) :: KDAYI ! day of Initial date
+INTEGER, INTENT(IN) :: PSECI ! number of seconds since date at 00 UTC
+ ! of Initial date
+INTEGER, INTENT(OUT):: PDIST ! temporal distance in secunds
+ !between the final and initial date
+!
+!* 0.2 Declaration of local variables
+! ------------------------------
+!
+INTEGER :: IDAYS ! number of days between the two dates
+INTEGER :: JMONTH,JYEAR ! loop index on months or years
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. SAME YEARS AND SAME MONTHS
+! --------------------------
+!
+IF ( (KYEARF==KYEARI) .AND. (KMONTHF==KMONTHI) ) THEN
+ PDIST = ( KDAYF-KDAYI) * 86400 + PSECF - PSECI
+ ! check chronological order
+ IF (PDIST < 0.) PDIST=-999
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. SAME YEARS AND DIFFERENT MONTHS
+! -------------------------------
+!
+IF ( (KYEARF==KYEARI) .AND. (KMONTHF/=KMONTHI) ) THEN
+ ! check chronological order
+ IF ( KMONTHF < KMONTHI ) THEN
+ PDIST=-999
+ RETURN
+ END IF
+ !
+ ! cumulate the number of days for the months in between KMONTHF-1 and
+ ! KMONTHI
+ IDAYS = 0
+ DO JMONTH = KMONTHI, KMONTHF-1
+ SELECT CASE (JMONTH)
+ CASE(4,6,9,11)
+ IDAYS=IDAYS+30
+ CASE(1,3,5,7:8,10,12)
+ IDAYS=IDAYS+31
+ CASE(2)
+ IF (MOD(KYEARI,4)==0) THEN
+ IDAYS=IDAYS+29
+ ELSE
+ IDAYS=IDAYS+28
+ ENDIF
+ END SELECT
+ END DO
+ !
+ ! compute the temporal distance
+ PDIST = ( IDAYS + KDAYF - KDAYI) * 86400. + PSECF - PSECI
+ !
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. DIFFERENT YEARS
+! ---------------
+!
+IF (KYEARF/=KYEARI) THEN
+ ! check chronological order
+ IF ( KYEARF < KYEARI ) THEN
+ PDIST=-999
+ RETURN
+ END IF
+ !
+ ! cumulate the number of days for the months in between KMONTHI and
+ ! December
+ IDAYS = 0
+ DO JMONTH = KMONTHI, 12
+ SELECT CASE (JMONTH)
+ CASE(4,6,9,11)
+ IDAYS=IDAYS+30
+ CASE(1,3,5,7:8,10,12)
+ IDAYS=IDAYS+31
+ CASE(2)
+ IF (MOD(KYEARI,4)==0) THEN
+ IDAYS=IDAYS+29
+ ELSE
+ IDAYS=IDAYS+28
+ ENDIF
+ END SELECT
+ END DO
+ DO JMONTH = 1,KMONTHF-1
+ SELECT CASE (JMONTH)
+ CASE(4,6,9,11)
+ IDAYS=IDAYS+30
+ CASE(1,3,5,7:8,10,12)
+ IDAYS=IDAYS+31
+ CASE(2)
+ IF (MOD(KYEARF,4)==0) THEN
+ IDAYS=IDAYS+29
+ ELSE
+ IDAYS=IDAYS+28
+ ENDIF
+ END SELECT
+ END DO
+ ! add the number of days corresponding to full years between the two dates
+ DO JYEAR=KYEARI+1, KYEARF-1
+ IF (MOD(JYEAR,4)==0) THEN
+ IDAYS=IDAYS+366
+ ELSE
+ IDAYS=IDAYS+365
+ END IF
+ END DO
+ !
+ ! compute the temporal distance
+ PDIST = ( IDAYS + KDAYF - KDAYI) * 86400 + PSECF - PSECI
+ !
+END IF
+!
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE TEMPORAL_DIST_FOR_EXT
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/to_computing_units.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/to_computing_units.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c2f2742b41d8c15f91c7489006152352da39a66c
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/to_computing_units.f90
@@ -0,0 +1,135 @@
+! ############################################################
+ MODULE MODI_TO_COMPUTING_UNITS
+! ############################################################
+!
+INTERFACE
+ SUBROUTINE TO_COMPUTING_UNITS(HCHAMP,HUNITS,PVALOBS)
+!
+CHARACTER(LEN=*) , intent(in) :: HCHAMP ! Nom du champ
+CHARACTER(LEN=*) , intent(inout) :: HUNITS ! Unité
+REAL , intent(inout) ,OPTIONAL:: PVALOBS ! cas de traitement 1 valeur
+!
+END SUBROUTINE TO_COMPUTING_UNITS
+END INTERFACE
+END MODULE MODI_TO_COMPUTING_UNITS
+!
+!------------------------------------------------------------------------------
+!
+! ################
+ SUBROUTINE TO_COMPUTING_UNITS(HCHAMP,HUNITS,PVALOBS)
+! ################
+!
+!!**** *TO_COMPUTING_UNITS* -
+!!
+!!
+!! PURPOSE
+!! -------
+! Passage vers une unité adaptee au calcul
+! appel a From_Computing_Units(YCHAMP,CUNIT) pour revenir a l unite initiale
+!
+!!** METHOD
+! par defaut traite le tableau XVAR passe en module
+!ou PVALOBS passe en argument
+!
+! Changement du nom d unite pour diagnostiquer le traitement inverse
+! dans From_Computing_Units (routine symetrique)
+! mettre a jour suivant les variables Mesonh qui necessitent ce passage
+! AU 01/2005 : les reflectivités radar exprimees en dBz
+! les températures de brillance
+!!
+!! AUTHORS
+!! -------
+!! N. Asencio * CNRM*
+!!
+!! Copyright 2003, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 25/01/2005 (N. Asencio)
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS, ONLY:XUNDEF
+USE MODD_ALLOC_FORDIACHRO, ONLY: XVAR
+
+USE MODI_LOW2UP
+IMPLICIT NONE
+!
+!* 0.1 Arguments d'appel
+!
+CHARACTER(LEN=*) , intent(in) :: HCHAMP ! Nom du champ
+CHARACTER(LEN=*) , intent(inout) :: HUNITS ! Unité
+REAL , intent(inout), OPTIONAL:: PVALOBS ! cas de traitement 1 valeur
+!
+!* 0.2 variables locales
+!
+INTEGER :: ILOOP
+CHARACTER (LEN=13) :: YNAME
+CHARACTER (LEN=10) :: YUNIT
+! provisoire pour passer la compil
+REAL :: PCOEFA,PCOEFB
+!
+!-------------------------------------------------------------------------------
+!
+!print *,'entree TO_COMPUTING_UNITS ',TRIM(HCHAMP),' ',TRIM(HUNITS)
+!
+! passage en majuscules
+YNAME=HCHAMP
+CALL LOW2UP(YNAME)
+YUNIT=HUNITS
+CALL LOW2UP(YUNIT)
+!
+! Critere= nom de variable
+IF (INDEX(HCHAMP,'_IRBT')/=0 .OR. INDEX(HCHAMP,'_WVBT')/=0) THEN
+ ! Prevoir la routine inverse a MAKE_RADSAT
+ ! Mesonh
+ ! passage rad -> temp brillance pour le satellite KGEO
+ ! call MAKE_RADSAT(KYEARF, KMONTHF, KDAYF, PSECF, &
+ ! KGEO, KLON, PRADB, PRADF)
+ ! Viviane
+ !ZOBS est en radiance, je la transforme en tempe de brillance
+ ! IF (ZRADMOY > 0. .AND. (ALOG(ZRADMOY)-PCOEFA) /= 0. ) THEN
+ ! ZOBS(JILOOP,JJLOOP)=PCOEFB/(ALOG(ZRADMOY)-PCOEFA)
+ ! Viviane
+ ! transformation des tempe de brillance en radiance
+ ! IF ( TAB_OBS(IOBS)%PTROBS%XVALOBS /= ZUNDEF .AND. &
+ ! TAB_OBS(IOBS)%PTROBS%XVALOBS /= 0.) THEN
+ ! TAB_OBS(IOBS)%PTROBS%XVALOBS = EXP(PCOEFA+PCOEFB/&
+ ! TAB_OBS(IOBS)%PTROBS%XVALOBS)
+ IF (PRESENT (PVALOBS)) THEN
+ ! IF (PVALOBS/= XUNDEF .AND. PVALOBS /= 0.) PVALOBS=EXP(PCOEFA+PCOEFB/PVALOBS)
+ PVALOBS=PVALOBS
+ ELSE
+ ! WHERE (XVAR /= XUNDEF .AND. XVAR /= 0.) XVAR=EXP(PCOEFA+PCOEFB/XVAR)
+ XVAR=XVAR
+ ENDIF
+ !
+ ! Pour indiquer le travail inverse dans From_Computing_Units
+ HUNITS='W_to_C'
+ print *,'****TO_COMPUTING_UNITS: Passage Temperature de Brillance vers Radiance avant calcul ****'
+ print *,' Ce passage est inactif pour l instant'
+ENDIF
+!
+! Critere = unite
+SELECT CASE (YUNIT)
+ CASE ('DBZ','dBz','dBZ','ZE_LISTOBS')
+ ! Reflectivites radar
+ IF (PRESENT (PVALOBS)) THEN
+ IF (PVALOBS /= XUNDEF ) PVALOBS=10.0**(PVALOBS/10.0)
+ ! Pour indiquer le travail inverse dans From_Computing_Units
+ HUNITS='Ze_listOBS'
+ ELSE
+ WHERE (XVAR /= XUNDEF ) XVAR=10.0**(XVAR/10.0)
+ ! Pour indiquer le travail inverse dans From_Computing_Units
+ HUNITS='Ze_to_DBZ'
+ ENDIF
+ IF ( YUNIT /= 'ZE_LISTOBS' ) THEN
+ ! print pour la premiere Obs traitee seulement
+ print *,'****TO_COMPUTING_UNITS: Passage DBZ a Ze avant calcul ****'
+ ENDIF
+END SELECT
+!
+END SUBROUTINE TO_COMPUTING_UNITS
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/writecdl.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/writecdl.f90
new file mode 100644
index 0000000000000000000000000000000000000000..67c9c8bfe479477a45569c6c90bc4296d8ec1052
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/writecdl.f90
@@ -0,0 +1,702 @@
+! #################################
+ MODULE MODI_WRITECDL
+! #################################
+INTERFACE WRITECDL
+ SUBROUTINE WRITECDL(kideb,kifin,kjdeb,kjfin,kkdeb,kkfin,&
+ kitdeb,kitfin,kitrdeb,kitrfin,kipdeb,kipfin,&
+ HLABELCHAMP,HFILENAME,HFLAGFILE,HTYPEGRID, &
+ HFILENAME_SUP,KVERBIA,KRETCODE, &
+ PGRIDX,PGRIDY )
+!
+CHARACTER(LEN=*), intent(inout) :: HLABELCHAMP ! nom du champ
+ ! inout pour modifier le nom VLEV en altitude
+CHARACTER(LEN=*), intent(in) :: HFILENAME ! nom du fichier
+CHARACTER(LEN=*), intent(in) :: HFLAGFILE ! NEW=creation
+ ! OLD=ajout
+ ! CLOSE=fermeture
+CHARACTER(LEN=3) :: HFILENAME_SUP ! chaine de caracteres
+ ! a rajouter a
+ ! HFILENAME
+CHARACTER(LEN=*), intent(in) :: HTYPEGRID ! format grille reguliere plan conforme
+ ! ou lat lon CONF/LALO
+INTEGER , intent(in) :: KVERBIA ! prints de controle
+ ! desactive (0) / active (1) les prints
+ ! limites sur les 6 dimensions
+INTEGER , intent(in) :: kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
+INTEGER , intent(in) :: kitdeb,kitfin,kitrdeb,kitrfin,kipdeb,kipfin
+!
+INTEGER , intent(out) :: KRETCODE ! Code de retour de la routine
+REAL, DIMENSION(:), INTENT(IN) :: PGRIDX, PGRIDY
+END SUBROUTINE
+END INTERFACE
+END MODULE MODI_WRITECDL
+!
+! ################
+ SUBROUTINE WRITECDL(kideb,kifin,kjdeb,kjfin,kkdeb,kkfin,&
+ kitdeb,kitfin,kitrdeb,kitrfin,kipdeb,kipfin,&
+ HLABELCHAMP,HFILENAME,HFLAGFILE,HTYPEGRID, &
+ HFILENAME_SUP,KVERBIA,KRETCODE, &
+ PGRIDX,PGRIDY )
+! ################
+!
+!!**** *writedcdl* -
+!!
+!!
+!! PURPOSE
+!! -------
+! Ecriture d'un fichier de type CDL pour etre transformé en netcdf
+! via ncgen -b file.cdl
+!
+!
+!!** METHOD
+!! ------
+! Ecriture ascii de 2 fichiers en parallele:
+! un fichier pour l entete
+! un fichier pour les données
+! Chaque appel de la routine writecdl complete le fichier d entete
+! et le fichier de données.
+! Ces 2 fichiers seront concatenes avant d'appeler ncgen ( outil netcdf
+! qui cree un fichier netcdf a partir d un fichier ascii de format CDL).
+! Voir le script tonetcdf ci-dessous:
+!# concatenation de l entete et des données
+!#
+!cat ${FILE}hcl ${FILE}dcl > ${FILE}cdl
+!#
+!# outil netcdf : ncgen
+!#
+!ncgen -b ${FILE}cdl
+!
+! XVAR est alloué avant l appel a writecdl
+!
+! HFLAGFILE='NEW' lors de la premiere utilisation du fichier
+! HFLAGFILE='OLD' lors des utilisations suivantes
+! HFLAGFILE='CLO' pour la fermeture du fichier de sortie
+! ( fin de mise a jour du menu )
+!
+! KVERBIA= 0 impressions reduites au minimum (entree et sortie de la
+! routine)
+! KVERBIA >0 impressions pour signaler chaque etape de READVAR
+!
+! KRETCODE = 0 execution de writecdl correcte
+! KRETCODE = 1 erreur lors de l ouverture du fichier
+! KRETCODE = 2 erreur lors de la fermeture du fichier
+!
+! kideb,kifin,kjdeb,kjfin,kkdeb,kkfin = limites en indices i,j,k du
+! domaine à traiter dans XVAR
+! kitdeb,kitfin,kitrdeb,kitrfin,kipdeb,kipfin = limites en indices
+! des dimensions 4,5,6 de XVAR
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FROM_COMPUTING_UNITS: retour aux unites initiales avant ecriture
+!! = passage inverse a celui realise par
+!! TO_COMPUTING_UNITS
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHORS
+!! -------
+!! N. Asencio * CNRM*
+!!
+!! Copyright 2003, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! 23/06/2009 G. TANGUY * CNRM*
+!! ajout du champ _Fillvalue pour les valeurs indéfinies
+!! modification de l'ecriture de "time" : type int et la référence est prise au
+!! premier janvier deux ans auparavant
+!! ecriture de la dimension de vertical_levels quand il n'y a qu'un seul niveau
+!! demandé
+!! ajout de la variable YNETCDFCHAMP pour remplacer HLABELCHAMP dans ce
+!! programme ce qui évite de tronquer vertical_levels
+!! ajout du champ global attributes pour préciser la simulation dans l'entête
+!! 18/02/2010 : time doit etre ecrit en premier puisqu'il est UNLIMITED
+!! changement de l'ordre avec le mask
+!! Nov 2010 : ajout des paramètres de cartes (LON0,LAT0,LONOR,LATOR,RPK,BETA)
+!! pour les projections conformes (utile sous NCL pour retracer la carte)
+!! Passage des coordonnées en metres au lieu de km (coord conformes
+!! et niveaux verticaux)
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+! pour getenv et system
+#ifdef NAGf95
+USE F90_UNIX
+USE F90_UNIX_PROC
+#endif
+!
+USE MODN_NCAR, ONLY: XSPVAL
+!
+! grille : XXDXHAT(:,1:7) et XXX(:,1:7), XXZS(:,:,1:7)
+USE MODD_COORD
+! min max des indices selon x et y
+USE MODD_TYPE_AND_LH
+! XVAR(i,j,k,,,), XMASK,XTRAJ ,XDATIME(16,t)
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_FILES_DIACHRO, ONLY: NBFILES, CLUOUTDIAS, NRESPDIAS
+!
+USE MODI_TEMPORAL_DIST_FOR_EXT
+USE MODI_FROM_COMPUTING_UNITS
+USE MODD_CONF, ONLY: CEXP
+USE MODD_TIME, ONLY: TDTEXP,TDTSEG
+USE MODD_TIME1, ONLY: TDTCUR
+USE MODD_GRID
+
+!
+IMPLICIT NONE
+!
+!* 0.1 Arguments d'appel
+! -----------------
+!
+CHARACTER(LEN=*), intent(inout) :: HLABELCHAMP ! nom du champ
+ ! inout pour modifier le nom VLEV en altitude
+CHARACTER(LEN=*), intent(in) :: HFILENAME ! nom du fichier
+CHARACTER(LEN=*), intent(in) :: HFLAGFILE !NEW=creation
+ !OLD=ajout
+ !CLOSE=fermeture
+CHARACTER(LEN=3) :: HFILENAME_SUP ! chaine de caracteres
+ !a rajouter a HFILENAME
+CHARACTER(LEN=*), intent(in) :: HTYPEGRID ! format grille reguliere plan conforme
+ !ou lat lon CONF/LALO
+INTEGER , intent(in) :: KVERBIA ! prints de controle
+ !desactive (0) / active (1) les prints
+ ! limites sur les 6 dimensions
+INTEGER , intent(in) :: kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
+INTEGER , intent(in) :: kitdeb,kitfin,kitrdeb,kitrfin,kipdeb,kipfin
+!
+INTEGER , intent(out) :: KRETCODE ! Code de retour de la routine
+REAL, DIMENSION(:), INTENT(IN) :: PGRIDX, PGRIDY
+!
+!* 0.2 Variables locales
+! -----------------
+!
+INTEGER :: ILOOP,JLOOP,KLOOP,KLOOP4,KLOOP5,KLOOP6, iret
+INTEGER,save :: ILUOUT1HEAD,ILUOUT2DATA ! unites logiques de sortie
+INTEGER :: IAN,IMOIS,IJOUR,ISECONDE,ibasetime
+INTEGER :: IAN2,IMOIS2,IJOUR2,ISECONDE2,IANREF
+INTEGER, dimension(:), ALLOCATABLE :: ioffset_time
+INTEGER :: zbasetime
+!DOUBLE PRECISION :: zbasetime
+
+!
+REAL :: zmini ,zmaxi
+!
+! taille=100 et 28 cf diaprog
+CHARACTER (LEN=100) :: YSAVETITRE, YSAVECOMMENT, YSAVEUNITE
+CHARACTER (LEN=28) :: YFILEOUT,YFILEOUT1,YFILEOUT2 ! Fichiers de sortie
+CHARACTER (LEN=100) :: ycommand, ytextdim
+CHARACTER (LEN=13), save :: YLIBELLEDIM1,YLIBELLEDIM2
+CHARACTER (LEN=5) :: YNUM
+CHARACTER (LEN=28) :: YLABELCHAMPnew
+INTEGER :: ikdeb,ikfin,iitdeb,iitfin,iitrdeb,iitrfin,JK
+CHARACTER (LEN=15) :: YNETCDFCHAMP
+CHARACTER (LEN=8) :: YDATE
+CHARACTER (LEN=10) :: YTIME
+CHARACTER (LEN=5) :: YZONE
+INTEGER,DIMENSION(8) :: IVALUES
+REAL,DIMENSION(:,:,:,:,:), ALLOCATABLE:: XVAR2
+INTEGER :: II,IJ,IK,IT,IM
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. INITIALISATION
+! --------------
+!
+ IAN=XDATIME(13,1)
+ IMOIS=XDATIME(14,1)
+ IJOUR=XDATIME(15,1)
+ ISECONDE=XDATIME(16,1)
+ IANREF=IAN-2
+!
+YNETCDFCHAMP=HLABELCHAMP
+if (KVERBIA >= 0) then
+ print *,' --------- '
+ print *,'Entree WRITECDL ',TRIM(HFILENAME),' ',TRIM(YNETCDFCHAMP),' ', &
+ TRIM(HFLAGFILE),' ',TRIM(HTYPEGRID),' ', &
+ TRIM(HFILENAME_SUP),' ',KVERBIA
+endif
+!
+! Code de retour de la routine : 0 = OK
+! 1 = erreur lors de l ouverture du fichier
+! 2 = erreur lors de la fermeture du fichier
+KRETCODE=0
+!
+! Retour aux unites initiales si necessaire
+CALL FROM_COMPUTING_UNITS(YNETCDFCHAMP,CUNITE(1))
+!
+!
+! code de retour d erreur des routines diaprog
+LPBREAD=.FALSE.
+!
+if (KVERBIA > 0) then
+ print'(A41,6(I4,X))','WRITECDL: ideb,ifin,jdeb,jfin,kdeb,kfin= ',&
+ kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
+ print'(A42,2(I10,X),4(I4,X))',' tdeb,tfin,trdeb,trfin,pdeb,pfin= ',&
+ kitdeb,kitfin,kitrdeb,kitrfin,kipdeb,kipfin
+ print'(A26,6(I4,X))',' nil,nih,njl,njh,nkl,nkh=',nil,nih,njl,njh,nkl,nkh
+endif
+!
+!* 1.1 nom des fichiers de sortie (ajout d un suffixe hkcl/dkcl
+! ou hzcl/dzcl)
+!
+YFILEOUT=ADJUSTL(ADJUSTR(HFILENAME(1:LEN(HFILENAME)-1))//HFILENAME_SUP)
+YFILEOUT1=ADJUSTL(ADJUSTR(HFILENAME(1:LEN(HFILENAME)-1))//'h'//&
+ ADJUSTL(HFILENAME_SUP))
+YFILEOUT2=ADJUSTL(ADJUSTR(HFILENAME(1:LEN(HFILENAME)-1))//'d'//&
+ ADJUSTL(HFILENAME_SUP))
+if (KVERBIA > 0) then
+ print*,'fichier d entete YFILEOUT1= ',YFILEOUT1
+ print*,'fichier de donnees YFILEOUT2= ',YFILEOUT2
+endif
+!
+!-------------------------------------------------------------------------------
+!
+!* 2.1 OUVERTURE DES FICHIERS DE SORTIE
+! -------------------
+!
+IF ( HFLAGFILE(1:3) == 'NEW' ) THEN
+ !
+ ! recupere l unite logique et ouverture des fichiers
+ !
+ !* 2.1.1 Fichier entete : partie commune a toutes les variables
+ ! --------------
+ CALL FMATTR(YFILEOUT1,CLUOUTDIAS(NBFILES),ILUOUT1HEAD,NRESPDIAS(NBFILES))
+ IF (NRESPDIAS(NBFILES).NE.0)THEN
+ KRETCODE=1
+ print *,' ****WRITECDL: erreur lors de l ouverture du fichier ',&
+ TRIM(YFILEOUT1),' code= ',NRESPDIAS(NBFILES)
+ RETURN
+ ENDIF
+ OPEN(UNIT=ILUOUT1HEAD,FILE=YFILEOUT1,STATUS='NEW',FORM='FORMATTED')
+ ! creation du debut de l entete
+ !nom du fichier
+ write(ILUOUT1HEAD,*) 'netcdf ',YFILEOUT,' { '
+ !dimensions
+ write(ILUOUT1HEAD,*) 'dimensions: '
+ SELECT CASE (HTYPEGRID(1:4) )
+ CASE ('CONF')
+ YLIBELLEDIM1='W_E_direction'
+ YLIBELLEDIM2='S_N_direction'
+ CASE ('LALO')
+ YLIBELLEDIM1='longitude'
+ YLIBELLEDIM2='latitude'
+ CASE DEFAULT
+ print*, ' type de grille incorrect: LALO/CONF possibles et non ', HTYPEGRID
+ END SELECT
+ !
+ write(ILUOUT1HEAD,*) ' ',TRIM(YLIBELLEDIM1),' = ', kifin-kideb +1, ';'
+ write(ILUOUT1HEAD,*) ' ',TRIM(YLIBELLEDIM2),' = ', kjfin-kjdeb +1, ';'
+ write(ILUOUT1HEAD,*) ' vertical_levels = ', kkfin-kkdeb +1, ';'
+! write(ILUOUT1HEAD,*) ' time = ',kitfin-kitdeb +1, ';'
+ write(ILUOUT1HEAD,*) ' time = UNLIMITED ; // (',kitfin-kitdeb +1,' currently) ;'
+ write(ILUOUT1HEAD,*) ' mask = ', kitrfin-kitrdeb +1, ';'
+ write(ILUOUT1HEAD,*) 'variables: '
+
+! write (ILUOUT1HEAD,*) ' double time(time);'
+ write (ILUOUT1HEAD,*) ' int time(time);'
+ write(ILUOUT1HEAD,'(A,I4,A)') ' time:units = "seconds since ',IANREF,'-1-1 00:00:00" ;'
+ write(ILUOUT1HEAD,'(A,I4,A)') ' time:time_origin = "',IANREF,'-1-1 00:00:00" ;'
+
+ !reference temporelle
+! write (ILUOUT1HEAD,*) ' int base_time ;'
+! write (ILUOUT1HEAD,*)' base_time:units = "seconds since 1970-01-01'&
+! ,'00:00:00 UTC" ;'
+! write (ILUOUT1HEAD,*) ' base_time:long_name = ',&
+! '"base time for the file" ;'
+ !evolution temporelle / reference
+! write (ILUOUT1HEAD,*) ' int time_offset(time) ;'
+! write (ILUOUT1HEAD,*)' time_offset:units = "seconds" ;'
+! write (ILUOUT1HEAD,*) ' time_offset:long_name = "time offset from'&
+! ,' base time" ;'
+ SELECT CASE (HTYPEGRID(1:4) )
+ CASE ('CONF')
+ !grille réguliere selon x dans le plan conforme
+ write (ILUOUT1HEAD,*) ' float W_E_direction(W_E_direction);'
+ write (ILUOUT1HEAD,*) ' W_E_direction:units = "km" ;'
+ write (ILUOUT1HEAD,*) ' W_E_direction:long_name = "model grid in the conformal projection" ;'
+ !grille réguliere selon y dans le plan conforme
+ write (ILUOUT1HEAD,*) ' float S_N_direction(S_N_direction);'
+ write (ILUOUT1HEAD,*) ' S_N_direction:units = "km" ;'
+ write (ILUOUT1HEAD,*) ' S_N_direction:long_name = "model grid in the conformal projection" ;'
+ write (ILUOUT1HEAD,*) ' float LON0 ;'
+ write (ILUOUT1HEAD,*) ' LON0:units = "degrees_east" ;'
+ write (ILUOUT1HEAD,*) ' LON0:long_name = "reference longitude for the conformal projection" ;'
+ write (ILUOUT1HEAD,*) ' float LAT0 ;'
+ write (ILUOUT1HEAD,*) ' LAT0:units = "degrees_north" ;'
+ write (ILUOUT1HEAD,*) ' LAT0:long_name = "reference latitude for the conformal projection" ;'
+ write (ILUOUT1HEAD,*) ' float LONOR ;'
+ write (ILUOUT1HEAD,*) ' LONOR:units = "degrees_east" ;'
+ write (ILUOUT1HEAD,*) ' LONOR:long_name = "longitude of point x=0,y=0 in the conformal projection" ;'
+ write (ILUOUT1HEAD,*) ' float LATOR ;'
+ write (ILUOUT1HEAD,*) ' LATOR:units = "degrees_north" ;'
+ write (ILUOUT1HEAD,*) ' LATOR:long_name = "latitude of point x=0,y=0 in the conformal projection" ;'
+ write (ILUOUT1HEAD,*) ' float BETA ;'
+ write (ILUOUT1HEAD,*) ' BETA:units = "degrees" ;'
+ write (ILUOUT1HEAD,*) ' BETA:long_name = "Rotation angle for the conformal projection" ;'
+ write (ILUOUT1HEAD,*) ' float RPK ;'
+ write (ILUOUT1HEAD,*) ' RPK:units = " " ;'
+ write (ILUOUT1HEAD,*) ' RPK:long_name = "projection parameter for the conformal projection" ;'
+
+ CASE('LALO')
+ !grille réguliere selon x en longitude
+ write (ILUOUT1HEAD,*) ' float longitude(longitude);'
+ write (ILUOUT1HEAD,*) ' longitude:units = "degrees_east" ;'
+ write (ILUOUT1HEAD,*) ' longitude:long_name = "longitudes" ;'
+ !grille réguliere selon y en latitude
+ write (ILUOUT1HEAD,*) ' float latitude(latitude);'
+ write (ILUOUT1HEAD,*) ' latitude:units = "degrees_north" ;'
+ write (ILUOUT1HEAD,*) ' latitude:long_name = "latitudes" ;'
+ END SELECT
+ !
+ !* 2.1.2 Fichier contenant les donnees: variables contenant la grille
+ ! ------------------------------
+ CALL FMATTR(YFILEOUT2,CLUOUTDIAS(NBFILES),ILUOUT2DATA,NRESPDIAS(NBFILES))
+ IF (NRESPDIAS(NBFILES).NE.0)THEN
+ KRETCODE=1
+ print *,' ****WRITECDL: erreur lors de l ouverture du fichier ',&
+ TRIM(YFILEOUT2),' code= ',NRESPDIAS(NBFILES)
+ RETURN
+ ENDIF
+ OPEN(UNIT=ILUOUT2DATA,FILE=YFILEOUT2,STATUS='NEW',FORM='FORMATTED')
+ !
+ !calcul et ecriture du nombre de secondes depuis le 01/01 2 ans auparavant
+ zbasetime=0.
+ if (KVERBIA > 0) then
+ print *,' calcul ibasetime: IAN,IMOIS,IJOUR,ISECONDE,zbasetime'
+ print *,IAN,IMOIS,IJOUR,ISECONDE,zbasetime
+ endif
+ CALL TEMPORAL_DIST_FOR_EXT(IAN,IMOIS,IJOUR,ISECONDE,IANREF,01,01,0,zbasetime)
+ if (KVERBIA > 0) then
+ print *, IAN,IMOIS,IJOUR,ISECONDE,zbasetime
+ endif
+ !
+ ibasetime=zbasetime
+ write(ILUOUT2DATA,*) 'data: '
+ write(ILUOUT2DATA,*) 'time = '!,zbasetime !, ' ;'
+
+ ! write(ILUOUT2DATA,*) 'base_time = ',ibasetime, ' ;'
+ !ecriture de l instant du fichier= 0 seconde / reference
+ !write(ILUOUT2DATA,*) 'time_offset = 0 ;'
+! ytextdim='time_offset = '
+! write(ILUOUT2DATA,*) ytextdim
+ ALLOCATE(ioffset_time(kitfin-kitdeb+1)) ; ioffset_time(:)=0
+ DO JK=kitdeb,kitfin
+ !ibasetime=XTRAJT(JK,1)-XTRAJT(kitdeb,1) !
+ ! cas ou TEXP et TSEG sont faux
+ IAN=XDATIME(13,kitdeb)
+ IMOIS=XDATIME(14,kitdeb)
+ IJOUR=XDATIME(15,kitdeb)
+ ISECONDE=XDATIME(16,kitdeb)
+ IAN2=XDATIME(13,JK)
+ IMOIS2=XDATIME(14,JK)
+ IJOUR2=XDATIME(15,JK)
+ ISECONDE2=XDATIME(16,JK)
+ CALL TEMPORAL_DIST_FOR_EXT(IAN2,IMOIS2,IJOUR2,ISECONDE2,IAN,IMOIS,IJOUR,ISECONDE,zbasetime)
+ ioffset_time(jk-kitdeb+1)=ibasetime+zbasetime
+ ENDDO
+ write(ILUOUT2DATA,1010,advance='no') ioffset_time(1:kitfin-kitdeb+1)
+ DEALLOCATE(ioffset_time)
+ WRITE(ILUOUT2DATA,'(";")')
+ write(ILUOUT2DATA,*) ' '
+!------------------------------------------------------------------
+ SELECT CASE (HTYPEGRID(1:4) )
+ CASE ('CONF')
+ ! grille régulière selon X en km
+ write(ILUOUT2DATA,*) ' W_E_direction ='
+ write(ILUOUT2DATA,1000,advance='no') PGRIDX(kideb:kifin)*0.001
+ WRITE(ILUOUT2DATA,'(";")')
+ write(ILUOUT2DATA,*) ' '
+ ! grille régulière selon Y en km
+ write(ILUOUT2DATA,*) ' S_N_direction ='
+ write(ILUOUT2DATA,1000,advance='no') PGRIDY(kjdeb:kjfin)*0.001
+ WRITE(ILUOUT2DATA,'(";")')
+ write(ILUOUT2DATA,*) ' '
+ !parametre de la grille
+ write(ILUOUT2DATA,*) ' LON0 ='
+ write(ILUOUT2DATA,1000,advance='no') XLON0
+ WRITE(ILUOUT2DATA,'(";")')
+ write(ILUOUT2DATA,*) ' '
+ write(ILUOUT2DATA,*) ' LAT0 ='
+ write(ILUOUT2DATA,1000,advance='no') XLAT0
+ WRITE(ILUOUT2DATA,'(";")')
+ write(ILUOUT2DATA,*) ' '
+ write(ILUOUT2DATA,*) ' LONOR ='
+ write(ILUOUT2DATA,1000,advance='no') XLONORI
+ WRITE(ILUOUT2DATA,'(";")')
+ write(ILUOUT2DATA,*) ' '
+ write(ILUOUT2DATA,*) ' LATOR ='
+ write(ILUOUT2DATA,1000,advance='no') XLATORI
+ WRITE(ILUOUT2DATA,'(";")')
+ write(ILUOUT2DATA,*) ' '
+ write(ILUOUT2DATA,*) ' BETA ='
+ write(ILUOUT2DATA,1000,advance='no') XBETA
+ WRITE(ILUOUT2DATA,'(";")')
+ write(ILUOUT2DATA,*) ' '
+ write(ILUOUT2DATA,*) ' RPK ='
+ write(ILUOUT2DATA,1000,advance='no') XRPK
+ WRITE(ILUOUT2DATA,'(";")')
+ write(ILUOUT2DATA,*) ' '
+
+
+ CASE('LALO')
+ write(ILUOUT2DATA,*) 'longitude ='
+ write(ILUOUT2DATA,1000,advance='no') PGRIDX(kideb:kifin)
+ WRITE(ILUOUT2DATA,'(";")')
+ write(ILUOUT2DATA,*) ' '
+ write(ILUOUT2DATA,*) 'latitude ='
+ write(ILUOUT2DATA,1000,advance='no') PGRIDY(kjdeb:kjfin)
+ WRITE(ILUOUT2DATA,'(";")')
+ write(ILUOUT2DATA,*) ' '
+ END SELECT
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. ECRITURE du champ dans YFILEOUT2 et de l entete dans YFILEOUT1
+! --------
+!
+IF ( HFLAGFILE(1:3) /= 'CLO' ) THEN
+ !
+ if (KVERBIA > 0) then
+ print*,'WRITECDL: format CDL ecriture en cours '
+ endif
+ !
+ ! Ecriture du champ + lat,lon ,altitude du niveau
+ !
+ ! 3.1 liste des dimensions tel que "Last dim varies fastest"
+ !
+ ytextdim=''
+ !Process: ecriture d une variable netcdf par processus donc lignes commentees
+ !IF ( kipfin-kipdeb > 0) THEN
+ ! ytextdim='process '
+ !ENDIF
+ ! ATTENTION le TEMPS DOIT ETRE LA PREMIERE VARIABLE CAR UNLIMITED
+ !Time
+ SELECT CASE (YNETCDFCHAMP)
+ CASE ('VLEV')
+ if (KVERBIA >= 2) then
+ print*,' No temporal dimension for ', YNETCDFCHAMP
+ endif
+ IF ( SIZE(XVAR,2) > 1 ) THEN
+ ! cas du champ 3D pour les altitudes
+ ! passage en km pour utilisation Zebra
+ YNETCDFCHAMP='VLEV'
+ CUNITE(1)='km'
+ XVAR=XVAR*0.001
+ ELSE
+ ! cas d une liste de niveaux verticaux choisis par l utilisateur
+ ! on garde l unité donnée par extractdia metres ou hPa
+ YNETCDFCHAMP='vertical_levels'
+ ENDIF
+ CASE ('LAT','LON')
+ if (KVERBIA >= 2) then
+ print*,' No temporal dimension for ', YNETCDFCHAMP
+ endif
+ CASE DEFAULT
+ ! Les variables doivent avoir la dimension time meme si
+ ! cette dimension est egale a 1
+ !IF ( kitfin-kitdeb > 0 ) THEN
+ IF (ytextdim /= '') ytextdim=ADJUSTL(ADJUSTR(ytextdim)//',')
+ ytextdim=ADJUSTL(ADJUSTR(ytextdim)//'time ')
+ !ENDIF
+ END SELECT
+
+ !Mask
+ SELECT CASE (YNETCDFCHAMP)
+ CASE ('VLEV','LAT','LON')
+ CASE DEFAULT
+ IF ( kitrfin-kitrdeb > 0) THEN
+ IF (ytextdim /= '') ytextdim=ADJUSTL(ADJUSTR(ytextdim)//',')
+ ytextdim=ADJUSTL(ADJUSTR(ytextdim)//'mask ')
+ ENDIF
+ END SELECT
+
+ !Z
+ SELECT CASE (YNETCDFCHAMP)
+ CASE ('LAT','LON')
+ if (KVERBIA >= 2) then
+ print*,' No vertical dimension for ', YNETCDFCHAMP
+ endif
+ CASE ('vertical_levels')
+ IF (ytextdim /= '') ytextdim=ADJUSTL(ADJUSTR(ytextdim)//',')
+ ytextdim=ADJUSTL(ADJUSTR(ytextdim)//'vertical_levels ')
+ CASE DEFAULT
+ IF ( kkfin-kkdeb > 0) THEN
+ IF (ytextdim /= '') ytextdim=ADJUSTL(ADJUSTR(ytextdim)//',')
+ ytextdim=ADJUSTL(ADJUSTR(ytextdim)//'vertical_levels ')
+ ENDIF
+ END SELECT
+ !Y
+ IF ( kjfin-kjdeb > 0) THEN
+ IF (ytextdim /= '') ytextdim=ADJUSTL(ADJUSTR(ytextdim)//',')
+ ytextdim=ADJUSTL(ADJUSTR(ytextdim)//ADJUSTL(YLIBELLEDIM2))
+ ENDIF
+ !X
+ IF ( kifin-kideb > 0) THEN
+ IF (ytextdim /= '') ytextdim=ADJUSTL(ADJUSTR(ytextdim)//',')
+ ytextdim=ADJUSTL(ADJUSTR(ytextdim)//ADJUSTL(YLIBELLEDIM1))
+ ENDIF
+ !
+ if (KVERBIA >= 2) then
+ print *,' dimensions du tableau= ', TRIM(ytextdim)
+ end if
+ !
+ ! Ecriture d une variable netcdf par processus
+ ! nommée nom_var+pnum_process
+ DO KLOOP6=kipdeb,kipfin
+ YLABELCHAMPnew=ADJUSTL(YNETCDFCHAMP)
+ IF ( SIZE(XVAR,6) > 1 ) THEN
+ ! ajout du numéro de processus
+ WRITE (YNUM,'(I5)') KLOOP6
+ YLABELCHAMPnew=ADJUSTL(ADJUSTR(YNETCDFCHAMP)//'p'//ADJUSTL(YNUM))
+ ENDIF
+ write (ILUOUT1HEAD,*) ' float ',TRIM(YLABELCHAMPnew),'(',TRIM(ytextdim),') ;'
+ write (ILUOUT1HEAD,*) TRIM(YLABELCHAMPnew), ':long_name = "',TRIM(CTITRE(kloop6)),'" ;'
+ write (ILUOUT1HEAD,*) TRIM(YLABELCHAMPnew), ':units = "',TRIM(CUNITE(kloop6)),'" ;'
+ SELECT CASE (YNETCDFCHAMP)
+ CASE ('LAT','LON')
+ ikdeb=1 ; ikfin=1 ; iitdeb=1 ; iitfin=1 ; iitrdeb=1 ; iitrfin=1
+ CASE DEFAULT
+ ikdeb=kkdeb ; ikfin=kkfin ; iitdeb=kitdeb ; iitfin=kitfin ; iitrdeb=kitrdeb ; iitrfin=kitrfin
+ END SELECT
+ IF (ANY(XVAR(kideb:kifin,kjdeb:kjfin,ikdeb:ikfin,iitdeb:iitfin,iitrdeb:iitrfin,kloop6)/=XSPVAL)) THEN
+ zmini=MINVAL(XVAR(kideb:kifin,kjdeb:kjfin,ikdeb:ikfin, &
+ iitdeb:iitfin,iitrdeb:iitrfin,kloop6), &
+ MASK=XVAR(kideb:kifin,kjdeb:kjfin,ikdeb:ikfin, &
+ iitdeb:iitfin,iitrdeb:iitrfin,kloop6)/=XSPVAL )
+ zmaxi=MAXVAL(XVAR(kideb:kifin,kjdeb:kjfin,ikdeb:ikfin, &
+ iitdeb:iitfin,iitrdeb:iitrfin,kloop6), &
+ MASK=XVAR(kideb:kifin,kjdeb:kjfin,ikdeb:ikfin, &
+ iitdeb:iitfin,iitrdeb:iitrfin,kloop6)/=XSPVAL )
+ ELSE
+ zmini=XSPVAL ; zmaxi=XSPVAL
+ ENDIF
+ IF (ABS (zmini) > 1.E-05 .AND. ABS(zmaxi) > 1.E-05 ) THEN
+ write (ILUOUT1HEAD,FMT=101) TRIM(YLABELCHAMPnew),zmini,zmaxi
+ ELSE
+ write (ILUOUT1HEAD,FMT=103) TRIM(YLABELCHAMPnew),zmini,zmaxi
+ ENDIF
+ IF (YNETCDFCHAMP /= 'vertical_levels') THEN
+ write (ILUOUT1HEAD,FMT=102) TRIM(YLABELCHAMPnew),XSPVAL
+ write (ILUOUT1HEAD,FMT=104) TRIM(YLABELCHAMPnew),XSPVAL
+ ENDIF
+ !
+ ! 3.2 ecriture des valeurs: Last dim varies fastest
+ !
+! on intervertit la place du temps et la place du mask avant l'ecriture
+
+ALLOCATE(XVAR2(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,5),SIZE(XVAR,4)))
+
+DO II=kideb,kifin
+ DO IJ=kjdeb,kjfin
+ DO IK=ikdeb,ikfin
+ DO IT=iitdeb,iitfin
+ DO IM=iitrdeb,iitrfin
+ XVAR2(II,IJ,IK,IM,IT)=XVAR(II,IJ,IK,IT,IM,kloop6)
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDDO
+ENDDO
+
+
+
+ write(ILUOUT2DATA,*) TRIM(YLABELCHAMPnew),' = '
+ IF (ABS (zmini) > 1.E-04 .AND. ABS(zmaxi) > 1.E-04 ) THEN
+ WRITE(ILUOUT2DATA,FMT=1000,advance='no') XVAR2(kideb:kifin,kjdeb:kjfin,&
+ ikdeb:ikfin,iitrdeb:iitrfin,iitdeb:iitfin)
+ ELSE
+ WRITE(ILUOUT2DATA,FMT=1001,advance='no') XVAR2(kideb:kifin,kjdeb:kjfin,&
+ ikdeb:ikfin,iitrdeb:iitrfin,iitdeb:iitfin)
+ ENDIF
+DEALLOCATE(XVAR2)
+ WRITE(ILUOUT2DATA,'(";")')
+ write(ILUOUT2DATA,*) ' '
+ END DO
+
+ !
+101 FORMAT (1H ,A,16H :actual_range = ,F0.5,3Hf ,,F0.5,3Hf ;)
+103 FORMAT (1H ,A,16H :actual_range = ,E11.5,3Hf ,,E11.5,3Hf ;)
+102 FORMAT (1H ,A,18H :missing_value = ,F0.5,3Hf ;)
+104 FORMAT (1H ,A,15H :_FillValue = ,F0.5,3Hf ;)
+!105 FORMAT (8H time = ,E17.11,3Hf ;)
+
+ ! le ":" est le descripteur de fin d'exploitation d'un format.
+ ! sous f95 et pgf90. D. Gazen
+1000 FORMAT (7(F0.5,:,", "))
+1001 FORMAT (7(E11.5,:,", "))
+1010 FORMAT (7(I10,:,", "))
+!
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. FERMETURE des fichiers de sortie
+! --------------------------------
+!
+IF ( HFLAGFILE(1:3) == 'CLO' ) THEN
+ ! fin de fichier de données
+ WRITE(ILUOUT2DATA,*) '}'
+ if (KVERBIA > 0) then
+ print*,'WRITECDL: avant fermeture fichier de sortie ',YFILEOUT
+ endif
+ ! force les buffers a etre vides pour permettre a l appel
+ ! systeme de traiter les fichiers complets
+ !CALL FLUSH (ILUOUT1HEAD)
+ !CALL FLUSH (ILUOUT2DATA)
+ !
+ ! fermeture
+ write (ILUOUT1HEAD,*) "// global attributes:"
+ write (ILUOUT1HEAD,*) ' :title = "Meso-NH simulation" ;'
+ write (ILUOUT1HEAD,*) ' :grid_resolution_in_meters = "', XXDXHAT(1,1),' x ',XXDYHAT(1,1),'" ;'
+ write (ILUOUT1HEAD,*) ' :description = "Data are from the file ', HFILENAME, '" ;'
+ write (ILUOUT1HEAD,'(A46,3(I4,X),F12.4,A25,3(I4,X),F12.4,A3)')&
+ ' :comments = " Meso-NH experience starts at ',TDTEXP,' and segment starts at ', TDTSEG,' ";'
+ CALL DATE_AND_TIME(YDATE, YTIME, YZONE, IVALUES)
+ write (ILUOUT1HEAD,FMT=201) IVALUES(3),IVALUES(2),IVALUES(1),IVALUES(5),IVALUES(6),IVALUES(7)
+201 FORMAT (' :history = "created on ',I2,'/',I2,'/',I4, ' at ',I2,':',I2,':',I2,'" ;')
+
+
+ CLOSE(ILUOUT1HEAD)
+ CALL FMFREE(YFILEOUT1,CLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
+ IF (NRESPDIAS(NBFILES).NE.0)THEN
+ KRETCODE=2
+ print *,' ****WRITECDL: erreur lors de la fermeture du fichier ',&
+ TRIM(YFILEOUT1),' code= ',NRESPDIAS(NBFILES)
+ ENDIF
+ CLOSE(ILUOUT2DATA)
+ CALL FMFREE(YFILEOUT2,CLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
+ IF (NRESPDIAS(NBFILES).NE.0)THEN
+ KRETCODE=2
+ print *,' ****WRITECDL: erreur lors de la fermeture du fichier ',&
+ TRIM(YFILEOUT2),' code= ',NRESPDIAS(NBFILES)
+ ENDIF
+ !
+ if (KVERBIA > 0) then
+ print *,'WRITECDL: before calling tonetcdf'
+ end if
+ ycommand='tonetcdf '//ADJUSTL(ADJUSTR(HFILENAME))
+ call SYSTEM ( TRIM(ycommand) )
+ !
+ if (KVERBIA >= 0) then
+ print*,'Sortie WRITECDL: Fichier ',TRIM(YFILEOUT),' disponible au format cdl'
+ print*,' --------- '
+ endif
+ !
+ENDIF
+!
+!
+HLABELCHAMP=YNETCDFCHAMP
+
+END SUBROUTINE WRITECDL
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/writegrib.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/writegrib.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3b71957fc30b1892e742f78b55ebb0566bb5b67e
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/writegrib.f90
@@ -0,0 +1,490 @@
+! #################################
+ MODULE MODI_WRITEGRIB
+! #################################
+INTERFACE WRITEGRIB
+ SUBROUTINE WRITEGRIB(kideb,kifin,kjdeb,kjfin,kkdeb,kkfin,&
+ kitdeb,kitfin,kitrdeb,kitrfin,kipdeb,kipfin,&
+ HLABELCHAMP,HFILENAME,HFLAGFILE,HOUTGRID,HTYPEOUT, &
+ KVERBIA,KRETCODE,KCODCOD,PLEV,OVAR2D,KLEVEL2D,PLATLON)
+!
+CHARACTER(LEN=*), intent(inout) :: HLABELCHAMP ! nom du champ
+ ! inout pour modifier le nom VLEV en altitude
+CHARACTER(LEN=*), intent(in) :: HFILENAME ! nom du fichier
+CHARACTER(LEN=*), intent(in) :: HFLAGFILE ! NEW=creation
+ ! OLD=ajout
+ ! CLOSE=fermeture
+CHARACTER(LEN=*), intent(in) :: HOUTGRID ! format grille reguliere plan conforme
+ !ou lat lon CONF/LALO
+CHARACTER(LEN=*), INTENT(in) :: HTYPEOUT ! type de fichier sortie
+INTEGER , intent(in) :: KVERBIA ! prints de controle
+ ! desactive (0) / active (1) les prints
+ ! limites sur les 6 dimensions
+INTEGER , intent(in) :: kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
+INTEGER , intent(in) :: kitdeb,kitfin,kitrdeb,kitrfin,kipdeb,kipfin
+!
+INTEGER , intent(out) :: KRETCODE ! Code de retour de la routine
+INTEGER, INTENT(IN) :: KCODCOD ! parameter code
+REAL, DIMENSION(:), INTENT(IN) :: PLEV !niveaux verticaux
+LOGICAL,INTENT(IN) :: OVAR2D ! champ 2D (surface) si TRUE sinon 3D
+INTEGER,OPTIONAL,INTENT(IN) :: KLEVEL2D
+REAL,DIMENSION(:),OPTIONAL,INTENT(IN) :: PLATLON
+END SUBROUTINE
+END INTERFACE
+END MODULE MODI_WRITEGRIB
+!
+! ################
+ SUBROUTINE WRITEGRIB(kideb,kifin,kjdeb,kjfin,kkdeb,kkfin,&
+ kitdeb,kitfin,kitrdeb,kitrfin,kipdeb,kipfin,&
+ HLABELCHAMP,HFILENAME,HFLAGFILE,HOUTGRID,HTYPEOUT, &
+ KVERBIA,KRETCODE,KCODCOD,PLEV,OVAR2D,KLEVEL2D,PLATLON)
+! ################
+! pour getenv et system
+#ifdef NAGf95
+USE F90_UNIX
+USE F90_UNIX_PROC
+#endif
+!
+USE MODN_NCAR, ONLY: XSPVAL
+!
+! grille : XXDXHAT(:,1:7) et XXX(:,1:7), XXZS(:,:,1:7)
+USE MODD_COORD
+! min max des indices selon x et y
+USE MODD_TYPE_AND_LH
+! XVAR(i,j,k,,,), XMASK,XTRAJ ,XDATIME(16,t)
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_FILES_DIACHRO, ONLY: NBFILES, CLUOUTDIAS, NRESPDIAS
+!
+USE MODI_TEMPORAL_DIST ! interface modules
+USE MODI_FROM_COMPUTING_UNITS
+USE MODD_CONF
+USE MODD_TIME, ONLY: TDTEXP,TDTSEG
+USE MODD_TIME1, ONLY: TDTCUR
+USE MODD_GRID
+USE MODD_GRID1
+!
+USE MODN_OUTFILE
+USE MODE_GRIDPROJ
+USE MODD_CST
+!
+IMPLICIT NONE
+!
+!* 0.1 Arguments d'appel
+! -----------------
+!
+CHARACTER(LEN=*), intent(inout) :: HLABELCHAMP ! nom du champ
+ ! inout pour modifier le nom VLEV en altitude
+CHARACTER(LEN=*), intent(in) :: HFILENAME ! nom du fichier
+CHARACTER(LEN=*), intent(in) :: HFLAGFILE !NEW=creation
+ !OLD=ajout
+ !CLOSE=fermeture
+CHARACTER(LEN=*), intent(in) :: HOUTGRID ! format grille reguliere plan conforme
+ !ou lat lon CONF/LALO
+CHARACTER(LEN=*), INTENT(in) :: HTYPEOUT ! type de fichier sortie
+
+INTEGER , intent(in) :: KVERBIA ! prints de controle
+ !desactive (0) / active (1) les prints
+ ! limites sur les 6 dimensions
+INTEGER , intent(in) :: kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
+INTEGER , intent(in) :: kitdeb,kitfin,kitrdeb,kitrfin,kipdeb,kipfin
+!
+INTEGER , intent(out) :: KRETCODE ! Code de retour de la routine
+INTEGER, INTENT(IN) :: KCODCOD ! parameter code
+REAL, DIMENSION(:), INTENT(IN) :: PLEV !niveaux verticaux
+LOGICAL,INTENT(IN) :: OVAR2D ! champ 2D (surface) si TRUE sinon 3D
+INTEGER,OPTIONAL,INTENT(IN) :: KLEVEL2D
+REAL,DIMENSION(:),OPTIONAL,INTENT(IN) :: PLATLON
+!
+!
+!
+!
+INTEGER :: ILOOP,JLOOP,KLOOP,KLOOP4,KLOOP5,KLOOP6, iret
+INTEGER :: IAN,IMOIS,IJOUR,ISECONDE,ibasetime
+INTEGER :: IAN2,IMOIS2,IJOUR2,ISECONDE2,IANREF
+INTEGER, dimension(:), ALLOCATABLE :: ioffset_time
+INTEGER :: zbasetime
+!DOUBLE PRECISION :: zbasetime
+
+!
+REAL :: zmini ,zmaxi
+!
+! taille=100 et 28 cf diaprog
+CHARACTER (LEN=100) :: YSAVETITRE, YSAVECOMMENT, YSAVEUNITE
+CHARACTER (LEN=40) :: YFILEOUT ! Fichier de sortie
+CHARACTER (LEN=100) :: ycommand, ytextdim
+CHARACTER (LEN=13), save :: YLIBELLEDIM1,YLIBELLEDIM2
+CHARACTER (LEN=5) :: YNUM
+CHARACTER (LEN=28) :: YLABELCHAMPnew
+INTEGER :: ikdeb,ikfin,iitdeb,iitfin,iitrdeb,iitrfin,JK
+CHARACTER (LEN=15) :: YNETCDFCHAMP
+CHARACTER (LEN=8) :: YDATE
+CHARACTER (LEN=10) :: YTIME
+CHARACTER (LEN=5) :: YZONE
+INTEGER,DIMENSION(8) :: IVALUES
+REAL,DIMENSION(:,:,:,:,:), ALLOCATABLE:: XVAR2
+INTEGER :: II,IJ,IK,IT,IM
+!
+!
+INTEGER :: IGRIBFILE ! logical unit for grib file
+INTEGER :: IRESP
+CHARACTER (LEN=22) :: YFIELDGRIB
+CHARACTER (LEN=6) :: YLEV
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: ZFIELD
+INTEGER :: JI,JJ,JJI,JJJ,IIX,IJY
+CHARACTER (LEN=22) ::YSUFFIX
+!
+! POUR GRIBEX
+INTEGER, DIMENSION(2) :: ISEC0 ! see gribex documentation
+INTEGER, DIMENSION(1024) :: ISEC1
+INTEGER, DIMENSION(1024) :: ISEC2
+INTEGER, DIMENSION(2) :: ISEC3
+INTEGER, DIMENSION(512) :: ISEC4
+!
+REAL, DIMENSION(512) :: ZSEC2
+REAL, DIMENSION(2) :: ZSEC3
+!
+REAL, DIMENSION(:),ALLOCATABLE :: ZSEC4
+INTEGER :: IPUNP ! length of data array ZSEC4
+INTEGER :: INBITS ! number of bits for coding
+INTEGER, DIMENSION(:),ALLOCATABLE :: INBUFF ! grib buffer
+INTEGER :: IPACK ! length of grib buffer INBUFF
+CHARACTER(LEN=1) :: YOPER ! requested function
+INTEGER :: IWORD ! number of words of INBUFF occupied by coded data
+INTEGER :: IERR ! return gribex code
+!
+REAL :: ZLENGTH ! length of forecast in seconds
+REAL :: ZLATREF2 ! second reference latitude in Lambert projection
+REAL :: ZMAP60 ! map factor at 60³ parallel nearest of the pole
+INTEGER :: ITIME
+!-------------------------------------------------------------------------------
+!
+!* 1. INITIALISATION
+! --------------
+!
+print *,' --------- '
+print *,'Entree WRITEGRIB ',TRIM(HFILENAME),' ',TRIM(HLABELCHAMP),' ', &
+ TRIM(HFLAGFILE),' ',KVERBIA
+
+KRETCODE=0
+CALL FROM_COMPUTING_UNITS(HLABELCHAMP,CUNITE(1))
+LPBREAD=.FALSE.
+print'(A41,6(I4,X))','WRITEGRIB: ideb,ifin,jdeb,jfin,kdeb,kfin= ',&
+ kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
+print'(A42,2(I10,X),4(I4,X))',' tdeb,tfin,trdeb,trfin,pdeb,pfin= ',&
+ kitdeb,kitfin,kitrdeb,kitrfin,kipdeb,kipfin
+print'(A26,6(I4,X))',' nil,nih,njl,njh,nkl,nkh=',nil,nih,njl,njh,nkl,nkh
+
+YFILEOUT=TRIM(HFILENAME)//'.'//HTYPEOUT(2:4)
+print*,'fichier de sortie YFILEOUT= ',YFILEOUT
+!
+!-------------------------------------------------------------------------------
+!
+!* 2.1 OUVERTURE DES FICHIERS DE SORTIE
+! -------------------
+!
+IF ( HFLAGFILE(1:3) == 'NEW' ) THEN
+! Open the MULTIGRIB file if necessary
+ print*,'The output GRIB file is named: ', YFILEOUT
+ CALL PBOPEN(IGRIBFILE,YFILEOUT,"W",IRESP)
+ IF (IRESP /= 0) print*, 'ERROR when opening file, IRESP=',IRESP
+END IF
+!-------------------------------------------------------------------------------
+!
+!* 3. ECRITURE du champ
+! --------
+!
+IF ( HFLAGFILE(1:3) /= 'CLO' ) THEN
+! Pour l'instant on ne triate qu'un seul temps, trajectoire/mask ou processus
+! si on en veut un en particulier il faut le faire avec le zoom
+! probleme s'il y a plusieurs temps dans un fichier ils auront tous le meme
+! dans le fichier grib donc il vaut mieux ne pas concatener les fichiers
+ IF (kitdeb/=kitfin) THEN
+ PRINT*,"=== WARNING ==="
+ PRINT*," you are asking for several times : (",kitdeb,":",kitfin,")"
+ PRINT*," only the first one (",kitdeb,") will be take into account"
+ ENDIF
+ IF (kitrdeb/=kitrfin) THEN
+ PRINT*,"=== WARNING ==="
+ PRINT*," you are asking for several trajectories : (",kitrdeb,":",kitrfin,")"
+ PRINT*," only the first one (",kitrdeb,") will be take into account"
+ ENDIF
+ IF (kipdeb/=kipfin) THEN
+ PRINT*,"=== WARNING ==="
+ PRINT*," you are asking for several processus : (",kipdeb,":",kipfin,")"
+ PRINT*," only the first one (",kipdeb,") will be take into account"
+ ENDIF
+!
+ !=========================================
+ ! ecriture de la section 1 du GRIB
+ !=========================================
+ ISEC1(:)=0
+ ISEC1(1)=1
+ ISEC1(2)=85 ! Idendification of center : French Weather Service
+ ISEC1(3)=96 ! Generating process identification number : MESONH identifier
+ ISEC1(4)=255 ! Grid definition : non-standard grid definition
+ ISEC1(5)=192 ! section 2 included, section 3 included (missing value)
+ ISEC1(6)=KCODCOD ! parameter indicator
+ ISEC1(10)=TDTEXP%TDATE%YEAR-100*(TDTEXP%TDATE%YEAR/100) ! year of century
+ ISEC1(11)=TDTEXP%TDATE%MONTH ! month of reference date (start of experiment)
+ ISEC1(12)=TDTEXP%TDATE%DAY ! day of reference date (start of experiment)
+ ISEC1(13)=NINT(TDTEXP%TIME)/3600 ! hour of reference date (start of experiment)
+ ISEC1(14)=NINT(TDTEXP%TIME)/60 - 60*ISEC1(13) ! minutes of reference date (start of exper0,0,0,0,0,0iment)
+ ISEC1(15)=1 ! time unit: hour
+ CALL TEMPORAL_DIST(TDTCUR%TDATE%YEAR,TDTCUR%TDATE%MONTH,TDTCUR%TDATE%DAY,TDTCUR%TIME, &
+ TDTEXP%TDATE%YEAR,TDTEXP%TDATE%MONTH,TDTEXP%TDATE%DAY,TDTEXP%TIME, &
+ ZLENGTH)
+ ISEC1(16)=NINT(ZLENGTH/3600) ! length of forecast (period of time since the start of experiment
+ !IF (NVERB>=5) print*, 'ZLENGTH=',ZLENGTH,'ISEC1=',ISEC1(16)
+ print*, 'ZLENGTH=',ZLENGTH,'ISEC1=',ISEC1(16)
+ ISEC1(21)=TDTEXP%TDATE%YEAR/100+1 ! century of data
+ !=========================================
+
+ ! zoom sur les dimensions
+
+ ALLOCATE(ZFIELD(kifin-kideb+1,kjfin-kjdeb+1,kkfin-kkdeb+1))
+ IIX=kifin-kideb+1
+ IJY=kjfin-kjdeb+1
+ IK=kkfin-kkdeb+1
+! print*,IIX,IJY,IK
+! print*,SHAPE(XVAR)
+ ZFIELD(:,:,:)=XVAR(kideb:kifin,kjdeb:kjfin,kkdeb:kkfin,kitdeb,kitrdeb,kipdeb)
+!===========================================================================
+!===========================================================================
+! GRILLE LAT/LON REGULIERE
+!===========================================================================
+!===========================================================================
+ IF (HOUTGRID=='LALO' )THEN
+ ISEC2(:)=0
+ ISEC2(1)=0 ! lat/lon regular grid
+ ISEC2(2)=IIX
+ ISEC2(3)=IJY
+ ISEC2(4)=PLATLON(1)
+ ISEC2(5)=PLATLON(3)
+ ISEC2(6)= 128
+ ISEC2(7)=PLATLON(2)
+ ISEC2(8)=PLATLON(4)
+! print*,"ISEC2(2),ISEC2(3)",ISEC2(2),ISEC2(3)
+! print*,"ISEC2(4),ISEC2(5), ISEC2(7),ISEC2(8)",ISEC2(4),ISEC2(5), ISEC2(7),ISEC2(8)
+ ISEC2(9)= (ISEC2(8)-ISEC2(5))/(IIX-1)
+ IF (ISEC2(9)<0) ISEC2(9)=(ISEC2(8)-ISEC2(5)+360000.)/(IIX-1)
+ ISEC2(10)=(ISEC2(4)-ISEC2(7))/(IJY-1)
+! print*,"ISEC2(9),ISEC2(10)",ISEC2(9),ISEC2(10)
+ !
+ ! quelques verif de coherence
+ !
+ IF (ISEC2(7)/= (ISEC2(4)-ISEC2(10)*(IJY-1))) THEN
+ print*,"ERREUR : ISEC2(7)/= (ISEC2(4)-ISEC2(10)*(IJY-1)))"
+ print*,"ISEC2(7)=",ISEC2(7)
+ print*,"ISEC2(4)=",ISEC2(4)
+ print*,"ISEC2(10)=",ISEC2(10)
+ print*,"IJY=",IJY
+ STOP
+ ENDIF
+ IF (ISEC2(8)/= (ISEC2(5)+ISEC2(9)*(IIX-1))) THEN
+ print*,"ERREUR : ISEC2(8)/= (ISEC2(5)+ISEC2(9)*(IIX-1)))"
+ print*,"ISEC2(8)=",ISEC2(8)
+ print*,"ISEC2(5)=",ISEC2(5)
+ print*,"ISEC2(9)=",ISEC2(9)
+ print*,"IIX=",IIX
+ STOP
+ ENDIF
+
+ ISEC2(11)=0 ! scanning: i+, j-
+ ISEC2(12)=IK ! number of vertical levels
+!===========================================================================
+!===========================================================================
+! ON RESTE SUR LA PROJECTION CONFORME
+!===========================================================================
+!===========================================================================
+ ELSE IF (HOUTGRID=='CONF') THEN
+ ! print*,"XRPK=",XRPK
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!XXXXXXXXXXXXXXXXXXXXXXXX Mercator XXXXXXXXXXXXXXXXXXXXXXXXXX
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ IF (ABS(XRPK)<1.E-10) THEN
+ ISEC2(:)=0
+ ISEC2(1)=1
+ ISEC2(2)=IIX
+ ISEC2(3)=IJY
+ ISEC2(4)=1000.*XLAT(kideb,kjdeb) ! latitude of first point
+ ISEC2(5)=1000.*(XLON(kideb,kjdeb) &! longitude of first point
+ -360.*NINT(XLON(kideb,kjdeb)/360.))
+ ISEC2(6)=0
+ ISEC2(7)=1000.*XLAT(kifin,kjfin) ! latitude of last point
+ ISEC2(8)=1000.*(XLON(kifin,kjfin) &! longitude of last point
+ -360.*NINT(XLON(kifin,kjfin)/360.))
+ ISEC2(9)=1000.*XLAT0
+ ISEC2(11)=64
+ ISEC2(12)=IK
+ ISEC2(13)=XXHAT(kideb+1)-XXHAT(kideb) ! DX at XLAT0
+ ISEC2(14)=XYHAT(kjdeb+1)-XYHAT(kjdeb) ! DY at XLAT0
+ ISEC2(19)=8
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!XXXXXXXXXXXXXXXXXXXXXXXX Polar Stereographic XXXXXXXXXXXXXXXXXXXXXXXXXX
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ ELSE IF ( ABS(XRPK)==1. ) THEN
+ ISEC2(:)=0
+ ISEC2(1)=5 ! polar stereographic projection
+ ISEC2(2)=IIX ! number of points along x
+ ISEC2(3)=IJY ! number of points along y
+ ISEC2(4)=1000.*XLAT(kideb,kjdeb) ! latitude of first point
+ ISEC2(5)=1000.*(XLON(kideb,kjdeb) & ! longitude of first point
+ -360.*NINT(XLON(kideb,kjdeb)/360.))
+ ISEC2(7)=1000.*(XLON0-360.*NINT(XLON0/360.))! longitude of the reference meridian
+ IF (XRPK>0.) THEN
+ ZMAP60=( COS(XLAT0*XPI/180.) / COS(XPI/3.) )**(1.-ABS(XRPK)) &
+ *((1+SIN(XLAT0*XPI/180.))/(1+SIN(XPI/3.)))**(ABS(XRPK))
+ ELSE IF (XRPK<0.) THEN
+ ZMAP60=( COS(-XLAT0*XPI/180.) / COS(-XPI/3.) )**(1.-ABS(XRPK)) &
+ *((1+SIN(-XLAT0*XPI/180.))/(1+SIN(-XPI/3.)))**(ABS(XRPK))
+ END IF
+ ISEC2(9)=(XXHAT(kideb+1)-XXHAT(kideb)) /ZMAP60 ! DX at 60³
+ ISEC2(10)=(XYHAT(kjdeb+1)-XYHAT(kjdeb))/ZMAP60 ! DY at 60³
+ ISEC2(11)=64 ! scanning I+, J+, (I,J) (01000000)
+ ISEC2(12)=IK
+ IF (XRPK>1.-1.E-10) THEN
+ ISEC2(13)=0 ! North pole in the domain
+ ELSE
+ ISEC2(13)=1 ! South pole in the domain
+ ! bizarre normalement c'est 128 d'apres la doc mais ca ne marche pas
+ ! par contre ok avec 1
+ END IF
+ ISEC2(19)=8
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!XXXXXXXXXXXXXXXXXXXXXXXXXX Conformal Lambert XXXXXXXXXXXXXXXXXXXXXXXXXX
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ ELSE IF ( ABS(XRPK)<1. .AND. ABS(XRPK)>1.E-10 ) THEN
+ ISEC2(:)=0
+ ISEC2(1)=3
+ ISEC2(2)=IIX
+ ISEC2(3)=IJY
+ ISEC2(4)=1000.*XLAT(kideb,kjdeb) ! latitude of first point
+ ISEC2(5)=1000.*(XLON(kideb,kjdeb) &! longitude of first point
+ -360.*NINT(XLON(kideb,kjdeb)/360.))
+ print*,"ISEC2(4),ISEC2(5) :",ISEC2(4),ISEC2(5)
+ ISEC2(6)=128
+ ISEC2(7)=1000.*(XLON0-360.*NINT(XLON0/360.)) ! reference longitude
+ ISEC2(8)=0
+ ISEC2(9)=(XXHAT(kideb+1)-XXHAT(kideb))
+ ISEC2(10)=(XYHAT(kjdeb+1)-XYHAT(kjdeb))
+ print*,"ISEC2(9),ISEC2(10) :",ISEC2(9),ISEC2(10)
+ ISEC2(11)=64
+ ISEC2(12)=IK
+ IF (XRPK>0.) THEN
+ ISEC2(13)=0 ! North pole in the projection plane
+ ZLATREF2=LATREF2(XLAT0,XRPK)
+ ISEC2(14)=1000*MAX(XLAT0,ZLATREF2)
+ ISEC2(15)=1000*MIN(XLAT0,ZLATREF2)
+ ELSE
+ ISEC2(13)=128 ! South pole in the projection plane
+ ZLATREF2=LATREF2(XLAT0,XRPK)
+ ISEC2(14)=1000*MIN(XLAT0,ZLATREF2)
+ ISEC2(15)=1000*MAX(XLAT0,ZLATREF2)
+ END IF
+ ISEC2(19)=8 ! U and V along x and y axes
+ ISEC2(20)=-90000 ! latitude of south pole
+ ELSE
+ print*,"ERREUR : seules les projection stereographique,"
+ print*," mercator ou lambert son reconnues"
+ STOP
+ END IF
+ ELSE
+ print*,"HOUTGRID=",HOUTGRID," non reconnu"
+ ENDIF
+!
+ ZSEC2(:)=0
+ ZSEC2(1)=XBETA*XPI/180. ! angle of rotation (unit ????, supposed radian)
+ ZSEC2(2)=1.
+ DO JK=1,IK
+ ZSEC2(JK+10)=PLEV(JK)
+ END DO
+!
+ ISEC3(:)=0
+ ISEC3(1)=0 ! missing data is considered
+ ISEC3(2)=-1
+ ZSEC3(:)=0
+ ZSEC3(1)=0 ! not used
+ ZSEC3(2)=999. ! value for missing data
+ !
+ ALLOCATE(INBUFF((SIZE(ZFIELD,1)*SIZE(ZFIELD,2)*4)+4202))
+ IPUNP=IIX*IJY
+ INBITS=24
+ IPACK=((IIX*IJY*INBITS/8)+(2101*2))
+ !
+ ISEC4(1)=IIX*IJY ! number of data to be packed
+ ISEC4(2)=INBITS ! number of bits used for each value
+ ISEC4(3)=0 ! 0 since section 2 is present
+ ISEC4(4)=0 ! simple packing
+ ISEC4(5)=0 ! floating point data representation
+ ISEC4(6:42)=0
+ !
+ ALLOCATE(ZSEC4(IIX*IJY))
+ ZSEC4(:)=0.
+ !
+ DO JK=kkdeb,kkfin
+ IF (OVAR2D) THEN
+ IF (PRESENT(KLEVEL2D)) THEN
+ ISEC1(7)=105 ! type of level : altitude
+ ISEC1(8)= KLEVEL2D! value of level
+ ISEC1(9)=0 ! bottom level if layer
+ ISEC2(12)=1
+ ZSEC2(11)=KLEVEL2D
+ ELSE
+ ISEC1(7)=105 ! type of level : altitude
+ ISEC1(8)=XZHAT(2) ! value of level
+ ISEC1(9)=0 ! bottom level if layer
+ ISEC2(12)=1
+ ZSEC2(11)=XZHAT(2)
+ ENDIF
+ ELSE
+ IF (HTYPEOUT(1:1) == 'P') THEN
+ ISEC1(7)=100 ! type of level : isobaric surfac
+ ISEC1(8)=NINT(PLEV(JK)) ! value of level
+ ISEC1(9)=0 ! bottom level if layer
+ ELSEIF (HTYPEOUT(1:1) == 'A') THEN
+ ISEC1(7)=105 ! type of level : isobaric surfac
+ ISEC1(8)=NINT(PLEV(JK)) ! value of level
+ ISEC1(9)=0 ! bottom level if layer
+ ELSE ! code as height levels
+ ISEC1(7)=103 ! type of level : altitude
+ ISEC1(8)=NINT(PLEV(JK)) ! value of level
+ ISEC1(9)=0 ! bottom level if layer
+ ENDIF
+ ENDIF
+
+ !
+ ZSEC4(1:IIX*IJY)=RESHAPE(ZFIELD(:,:,JK),(/IIX*IJY/))
+ IF (NVERB>=10) CALL GRSDBG(1) ! switch ON(1)/OFF(0) debug printing
+ CALL GRSDBG(0) ! pas de redirection possible...
+ YOPER = 'C' ! for coding
+ IERR = 1
+ INBUFF(:)=0.
+ CALL GRIBEX (ISEC0,ISEC1,ISEC2,ZSEC2,ISEC3,ZSEC3,ISEC4, &
+ ZSEC4,IPUNP,INBUFF,IPACK,IWORD,YOPER,IERR)
+ print'(A,I3,A,I5,A,I7,A,I7)', 'FIELD= ',KCODCOD,' LEVEL= ',NINT(PLEV(JK)), &
+ ' IPACK= ',IPACK,' IWORD= ',IWORD
+
+ CALL PBWRITE(IGRIBFILE,INBUFF,ISEC0(1),IERR)
+ print*, 'in unit IGRIBFILE=',IGRIBFILE, &
+ ' number of bytes: ',IERR
+ IF (IERR < 0) THEN
+ print*, 'ERROR when writing in GRIB file: IERR=',IERR
+ STOP
+ ENDIF
+ END DO
+ DEALLOCATE(ZFIELD)
+ DEALLOCATE(ZSEC4)
+ DEALLOCATE(INBUFF)
+ENDIF
+!-------------------------------------------------------------------------------
+!
+!* 4. FERMETURE des fichiers de sortie
+! --------------------------------
+!
+IF ( HFLAGFILE(1:3) == 'CLO' ) THEN
+ print*,'WRITEGRIB: avant fermeture fichier de sortie ',YFILEOUT
+ CALL PBCLOSE(IGRIBFILE,IRESP)
+ print*, 'After close of ',YFILEOUT,' IRESP=',IRESP
+ENDIF
+
+
+END SUBROUTINE WRITEGRIB
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/writellhv.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/writellhv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d3bb95a9ddc6867def2615d72841f5bc879da0b4
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/writellhv.f90
@@ -0,0 +1,612 @@
+! #################################
+ MODULE MODI_WRITELLHV
+! #################################
+INTERFACE WRITELLHV
+ SUBROUTINE WRITELLHV(kideb,kifin,kjdeb,kjfin,kkdeb,kkfin, &
+ KTDEB,KTFIN,KTRDEB,KTRFIN,KPDEB,KPFIN, &
+ HLABELCHAMP,HFILENAME,HFLAGFILE,HTYPEOUT,&
+ KVERBIA,KRETCODE,HFILENAME_SUP,PLON,PLAT,PALT )
+!
+CHARACTER(LEN=*), INTENT(in) :: HLABELCHAMP,HFILENAME ! nom du champ et du fichier
+CHARACTER(LEN=*), INTENT(in) :: HFLAGFILE ! NEW=creation
+ ! OLD=ajout
+ ! CLOSE=fermeture
+ ! NEW1H=creation entete speciale
+ ! OLDNH= ajout sans entete
+CHARACTER(LEN=*), INTENT(in) :: HTYPEOUT ! type de fichier sortie
+ ! LL?V= lon lat alt val
+ ! ll?v= lat lon alt val
+ !?=H,h alt du niveau k
+ ! Z,z alt apres
+ ! P,p interpol. verticale
+ ! en Z=cst Presssion=cst
+INTEGER , INTENT(in) :: KVERBIA ! prints de controle
+ ! desactive (0) / active (1) les prints
+ ! limites sur les 6 dimensions
+INTEGER , INTENT(in) :: KIDEB,KIFIN,KJDEB,KJFIN,KKDEB,KKFIN
+INTEGER , INTENT(in) :: KTDEB,KTFIN,KTRDEB,KTRFIN,KPDEB,KPFIN
+INTEGER , INTENT(out) :: KRETCODE ! Code de retour de la routine
+CHARACTER(LEN=3) ,OPTIONAL :: HFILENAME_SUP ! chaine de caracteres
+ !a rajouter a HFILENAME
+REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: PLON,PLAT ! tableaux des lat et
+ ! lon si LLZV ou LLPV
+REAL, DIMENSION(:,:,:), INTENT(IN),OPTIONAL :: PALT ! tableau des altitudes
+END SUBROUTINE
+END INTERFACE
+END MODULE MODI_WRITELLHV
+! ######
+ SUBROUTINE WRITELLHV(kideb,kifin,kjdeb,kjfin,kkdeb,kkfin, &
+ KTDEB,KTFIN,KTRDEB,KTRFIN,KPDEB,KPFIN, &
+ HLABELCHAMP,HFILENAME,HFLAGFILE,HTYPEOUT,&
+ KVERBIA,KRETCODE,HFILENAME_SUP,PLON,PLAT,PALT )
+! ################
+!
+!!**** *WRITELLHV* -
+!!
+!!
+!! PURPOSE
+!! -------
+! Ecriture d'un fichier de type lon,lat,alt,val (LL) ou lat,lon,alt,val (ll)
+! lon,lat= type LLHV,llhv: position dans la grille modele
+! type LLZV,llzv/LLPV,llpv: apres interpolation horizontale
+! (PLAT,PLON)
+! alt= type LLHV,llhv: position verticale de la grille du modèle (XZZ)
+! ou apres interpolation verticale a Z ou P=cst (PALT)
+! type LLZVllzv,/LLPV,llpv: apres interpolation verticale
+! a Z ou P=cst (PALT)
+! NB: ces interpolations ont ete realisees avant l'appel de WRITELLHV
+!
+!
+!!** METHOD
+!! ------
+! utilisation des routines de diaprog : le tableau de stockage
+! XVAR est alloué avant l appel a WRITELLHV
+!
+! HFLAGFILE='NEW' lors de la premiere utilisation du fichier
+! HFLAGFILE='OLD' lors des utilisations suivantes avec nouvelle entete
+! HFLAGFILE='NEW1H' lors de la premiere utilisation du fichier et gestion
+! d une entete speciale (cas mesonh2obs)
+! HFLAGFILE='OLDNH' lors des utilisations suivantes sans nouvelle entete
+! (cas mesonh2obs)
+! HFLAGFILE='OLD1H' lors des utilisations suivantes du fichier et gestion
+! d une entete speciale (cas mesonh2obs)
+! HFLAGFILE='CLO' pour la fermeture du fichier de sortie
+! ( fin de mise a jour du menu )
+!
+! KVERBIA= 0 impressions reduites au minimum (entree et sortie de la
+! routine)
+! KVERBIA >0 impressions pour signaler chaque etape de READVAR
+!
+! KRETCODE = 0 execution de WRITELLHV correcte
+! KRETCODE = 1 erreur lors de l ouverture du fichier
+! KRETCODE = 2 erreur lors de la fermeture du fichier
+!
+! kideb,kifin,kjdeb,kjfin,kkdeb,kkfin = limites en indices i,j,k du
+! domaine à traiter dans XVAR
+! KTDEB,KTFIN,KTRDEB,KTRFIN,KPDEB,KPFIN = limites en indices
+! des dimensions 4,5,6 de XVAR
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FROM_COMPUTING_UNITS: retour aux unites initiales avant ecriture
+!! = passage inverse a celui realise par
+!! TO_COMPUTING_UNITS
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHORS
+!! -------
+!! N. Asencio * CNRM*
+!!
+!! Copyright 2003, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+! 04/11/2009 (G. Tanguy) : add case IJHV,IJZV, IJPV , JIHV, JIZV, JIPV
+! 11/07/2014 (G. Tanguy) : correctoin bug IJHV au lieu de JIHV
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+! modules MESONH
+USE MODD_CST
+USE MODD_PARAMETERS, ONLY: JPHEXT,JPVEXT
+USE MODE_GRIDPROJ
+USE MODD_GRID, ONLY: XLONORI,XLATORI
+USE MODD_GRID1, ONLY: XZZ,XXHAT,XYHAT
+!
+! modules DIACHRO
+USE MODN_NCAR, ONLY: XSPVAL
+! XVAR(i,j,k,,,),XMASK,XTRAJT,X,Y,Z,XDATIME(16,t),CUNITE(p)
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_COORD, ONLY: XXX,XXY,XXZS, & ! XXX(:,1:7), XXY(:,1:7), XXZS(:,:,1:7)
+ XXDXHAT,XXDYHAT ! XXDXHAT(:,1:7), XXDYHAT(:,1:7)
+! nom de fichiers NLUOUT,CLFIFM, CDESFM
+USE MODD_OUT
+USE MODD_FILES_DIACHRO, ONLY: NBFILES, CLUOUTDIAS, NRESPDIAS
+! pour appel a FMATTR et FMCLOS
+!USE MODD_DIACHRO, ONLY:CFILEDIA,CLUOUTDIA, &
+! NLUOUTDIA,NRESPDIA,NNPRARDIA,NFTYPEDIA,NVERBDIA,NNINARDIA
+!
+!
+USE MODI_FROM_COMPUTING_UNITS
+IMPLICIT NONE
+!
+!* 0.1 Arguments d'appel
+!
+CHARACTER(LEN=*), INTENT(IN):: HLABELCHAMP,HFILENAME ! nom du champ et du fichier
+CHARACTER(LEN=*), INTENT(IN):: HFLAGFILE ! NEW=creation
+ ! OLD=ajout
+ ! CLOSE=fermeture
+ ! NEW1H=creation entete speciale
+ ! OLDNH=ajout sans entete
+CHARACTER(LEN=*), INTENT(IN):: HTYPEOUT ! type de fichier sortie
+ ! LL?V= lon lat alt val
+ ! ll?v= lat lon alt val
+ !?=H,h alt du niveau k
+ ! Z,z alt apres
+ ! P,p interpol. verticale
+ ! en Z=cst Presssion=cst
+INTEGER, INTENT(IN) :: KVERBIA ! prints de controle
+ ! desactive (0) / active (1) les prints
+ ! limites sur les 6 dimensions
+INTEGER, INTENT(IN) :: KIDEB,KIFIN,KJDEB,KJFIN,KKDEB,KKFIN
+INTEGER, INTENT(IN) :: KTDEB,KTFIN,KTRDEB,KTRFIN,KPDEB,KPFIN
+!
+INTEGER , INTENT(OUT) :: KRETCODE ! Code de retour de la routine
+CHARACTER(LEN=3) ,OPTIONAL :: HFILENAME_SUP ! chaine de caracteres
+ !a rajouter a HFILENAME
+REAL, DIMENSION(:,:), INTENT(IN), OPTIONAL :: PLON,PLAT ! tableaux des lat et
+ ! lon si LLZV ou LLPV
+REAL, DIMENSION(:,:,:), INTENT(IN),OPTIONAL :: PALT ! tableau des altitudes
+!
+!* 0.2 Declarations des variables locales
+!
+INTEGER :: JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP ! indices de boucle
+INTEGER,save :: ILUOUTLL ! unite logique de sortie
+INTEGER :: IAN,IMOIS,IJOUR,IHEURE,IMINUTE,ISEC,INBVAL,IGRID
+INTEGER :: IIU,IJU
+! taille= 28 cf routines FM
+CHARACTER (LEN=28) :: YFILEOUT ! Fichier de sortie
+REAL , DIMENSION(:,:) ,ALLOCATABLE :: ZLAT,ZLON ! lat et lon
+REAL , DIMENSION(:,:) ,ALLOCATABLE :: ZX,ZY
+!-------------------------------------------------------------------------------
+!
+!* 1. INITIALISATION
+! --------------
+!
+if (KVERBIA >= 0) then
+ print *,'--------- '
+ print *,'Entree WRITELLHV: ',TRIM(HFILENAME),' ',TRIM(HLABELCHAMP),' ', &
+ TRIM(HFLAGFILE),' ',TRIM(HTYPEOUT),' ',KVERBIA
+endif
+!
+! Code de retour de la routine : 0 = OK
+! 1 = erreur lors de l ouverture du fichier
+! 2 = erreur lors de la fermeture du fichier
+KRETCODE=0
+!
+! Retour aux unites initiales si necessaire
+IF (HFLAGFILE(1:3) /= 'CLO' ) THEN
+ IF (HLABELCHAMP/='END') CALL From_Computing_Units(HLABELCHAMP,CUNITE(1))
+END IF
+!
+!
+! init du zoom
+if (KVERBIA > 0 .AND. HFLAGFILE(1:3) /= 'CLO' ) THEN
+ print*,'WRITELLHV: zoom '
+ print'(A,6(I4,X))',' ideb,ifin,jdeb,jfin,kdeb,kfin=',&
+ kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
+ print'(A,2(I8,X),4(I4,X))',' tdeb,tfin,trdeb,trfin,pdeb,pfin=',&
+ KTDEB,KTFIN,KTRDEB,KTRFIN,KPDEB,KPFIN
+endif
+!
+!* 1.1 nom du fichier de sortie (ajout d un suffixe LLHV/LLZV/LLPV)
+!
+SELECT CASE ( HTYPEOUT(1:4) )
+ CASE ('LLHV','llhv','LLZV','llzv','LLPV','llpv','jihv','IJHV',&
+ 'IJZV','jizv','IJPV','jipv','llav','LLAV')
+ YFILEOUT=ADJUSTL(ADJUSTR(HFILENAME(1:LEN(HFILENAME)-1))//HTYPEOUT(1:4))
+ CASE DEFAULT
+ PRINT*,' ****WRITELLHV: type ', TRIM(HTYPEOUT),' non prevu'
+ PRINT*,'types possibles: LLHV/llhv, LLZV/llzv, LLPV/llpv, IJHV/jihv'
+ PRINT*,'IJZV/jizv, IJPV/jipv,LLAV/llav'
+ KRETCODE=1
+ RETURN
+END SELECT
+IF ( PRESENT(HFILENAME_SUP)) THEN
+ IF(HFILENAME_SUP(1:3) /= ' ') THEN
+ YFILEOUT=ADJUSTL( ADJUSTR(YFILEOUT)//'_'//ADJUSTL(HFILENAME_SUP) )
+ ENDIF
+ENDIF
+!
+!* 1.2 ouverture du fichier de sortie et allocations
+!
+IF ( HFLAGFILE(1:3) == 'NEW' ) THEN
+ ! recupere l unite logique et ouverture du fichier
+ CALL FMATTR(YFILEOUT,CLUOUTDIAS(NBFILES),ILUOUTLL,NRESPDIAS(NBFILES))
+ IF (NRESPDIAS(NBFILES)==0 ) THEN
+ OPEN(UNIT=ILUOUTLL,FILE=YFILEOUT,STATUS='NEW',FORM='FORMATTED')
+ ELSE
+ PRINT*,' ****WRITELLHV: error when openning ', TRIM(YFILEOUT), &
+ 'code= ',NRESPDIAS(NBFILES)
+ KRETCODE=1
+ RETURN
+ ENDIF
+ENDIF
+!
+!* 1.3 test sur les arguments optionnels
+!
+IF ( HFLAGFILE(1:3) /= 'CLO' ) THEN
+IIU=SIZE(XZZ,1) ; IJU=SIZE(XZZ,2)
+!
+IF (.NOT.PRESENT(PLAT) .AND. .NOT.PRESENT(PLON)) THEN
+! utilisation des lat. et lon. de la grille modele
+ ALLOCATE(ZX(IIU,IJU),ZY(IIU,IJU))
+ ALLOCATE(ZLAT(IIU,IJU),ZLON(IIU,IJU))
+ if (KVERBIA>0) print*,'WRITELLHV: LAT et LON de la grille modele '
+ELSE ! ( present(PLAT) .or. present(PLON) )
+ IF ( (PRESENT(PLAT) .AND. .NOT.PRESENT(PLON)) .OR. &
+ (.NOT.PRESENT(PLAT) .AND. PRESENT(PLON)) .OR. &
+ .NOT.PRESENT(PALT) ) THEN
+ PRINT*,' ****WRITELLHV: latitudes ET longitudes doivent etre presentes '
+ PRINT*,' ET altitudes '
+ KRETCODE=1
+ RETURN
+ ENDIF
+ ! Cas de passage par argument de PLAT et PLON différents de
+ !ceux de la grille du modele
+ IF (PRESENT (PLON)) THEN
+ ALLOCATE(ZLON(SIZE(PLON,1),SIZE(PLON,2)))
+ ZLON=PLON
+ ENDIF
+ IF (PRESENT (PLAT)) THEN
+ ALLOCATE(ZLAT(SIZE(PLON,1),SIZE(PLON,2)))
+ ZLAT=PLAT
+ ENDIF
+ENDIF
+ENDIF
+!
+!------------------------------------------------------------------------------
+!
+!* 2. ECRITURE DU CHAMP DANS LE FICHIER DE SORTIE
+! -------------------------------------------
+!
+IF ( HFLAGFILE(1:3) /= 'CLO' ) THEN
+ if (KVERBIA > 0) then
+ print'(A,I4)','WRITELLHV: unite sortie ILUOUTLL= ', ILUOUTLL
+ endif
+ ! ecriture de la ligne d entete de champ
+ !(temps courant)
+ IAN=XDATIME(13,1)
+ IMOIS=XDATIME(14,1)
+ IJOUR=XDATIME(15,1)
+ IHEURE=XDATIME(16,1)/3600
+ IMINUTE=(XDATIME(16,1)-(IHEURE*3600))/60
+ IF ( HFLAGFILE(4:5) /= 'NH') THEN
+ ! first line
+ write(ILUOUTLL,FMT='(I4,4(I2,X),A,A,A,A)') IAN,IMOIS,IJOUR,IHEURE,IMINUTE,TRIM(HLABELCHAMP),' ',TRIM(CUNITE(1)),&
+ ' first_line_format=Year Month Day UTCHour Minute VARIABLE_NAME UNIT'
+ ! second line
+ IF ( HFLAGFILE(4:5)== '1H') THEN
+ ! entete unique donnant le nombre de valeurs totales ecrites lors de
+ ! plusieurs appels avec OLDNH
+ write(ILUOUTLL,*) 'second_line_format=values written in the same chronological order than the OBS file'
+ ELSE
+ ! entete donnant exactement le nombre de valeurs ecrites lors de cet appel
+ write(ILUOUTLL,FMT='(6(I4,X),A)') kkdeb,kkfin,kjdeb,kjfin,kideb,kifin ,&
+ 'second_line_format=values written from (k=kbeg,kend (j=jbeg,jend (i=ibeg,iend)))'
+ ENDIF
+ ENDIF
+ !
+ if (KVERBIA > 0) then
+ print'(A,6(I4,X))',' kideb,kifin,kjdeb,kjfin,kkdeb,kkfin= ',kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
+ print'(A,2(I6,X),4(I4,X))',' ktdeb,ktfin,ktrdeb,ktrfin,kpdeb,kpfin= ',&
+ ktdeb,ktfin,ktrdeb,ktrfin,kpdeb,kpfin
+ print'(A,6(I4,X))',' dimensions de XVAR ',SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),SIZE(XVAR,6)
+
+ endif
+ ! ecriture du champ + lat,lon ,altitude du niveau
+ INBVAL= (kkfin-kkdeb+1) * (kjfin-kjdeb+1) * (kifin-kideb+1)
+ DO JPLOOP= KPDEB,KPFIN
+ IGRID=NGRIDIA(JPLOOP)
+ IF (.NOT.PRESENT(PLAT) .AND. .NOT.PRESENT(PLON)) THEN
+ ZX(1:IIU,1) = XXX(1:IIU,IGRID)
+ ZX(:,2:IJU) = SPREAD(ZX(:,1),2,IJU-1)
+ ZY(1,1:IJU) = XXY(1:IJU,IGRID)
+ ZY(2:IIU,:) = SPREAD(ZY(1,:),1,IIU-1)
+ ! les 2 premiers arg. doivent etre XXHAT et XYHAT (pas XXX et XXY)
+ !! peu importe en masdev4_6 car plus utilises..
+ !CALL SM_LATLON(XXHAT,XYHAT,XLATORI,XLONORI, &
+ !! supprimes en masdev4_7
+ CALL SM_LATLON(XLATORI,XLONORI, &
+ ZX,ZY,ZLAT,ZLON )
+ ENDIF
+ ! init de XZZ a la grille du champ (par defaut readvar
+ !l initialise a la grille 4 des vitesses verticales W)
+ CALL COMPCOORD_FORDIACHRO(IGRID)
+ if (KVERBIA > 0) then
+ print'(A,I2)','*after COMPCOORD_FORDIACHRO ',IGRID
+ endif
+ DO JTRLOOP= KTRDEB,KTRFIN
+ DO JTLOOP= KTDEB,KTFIN
+ IAN=XDATIME(13,JTLOOP)
+ IMOIS=XDATIME(14,JTLOOP)
+ IJOUR=XDATIME(15,JTLOOP)
+ IHEURE=XDATIME(16,JTLOOP)/3600
+ IMINUTE=(XDATIME(16,JTLOOP)-(IHEURE*3600))/60
+ ISEC=XDATIME(16,JTLOOP)-IHEURE*3600-IMINUTE*60
+ IF ( HFLAGFILE(4:5) /= 'NH') THEN
+ IF ( HFLAGFILE(4:5) == '1H') THEN
+ ! plusieurs futurs appels avec OLDNH : le nombre de lignes ne peut
+ ! etre connu a cet instant
+ write(ILUOUTLL,FMT='(F10.5,X,I6,A,3(I2,X),A,2(I2,X),A,A)') XSPVAL,&
+ JTLOOP,'(', &
+ IHEURE,IMINUTE,ISEC,')', &
+ JTRLOOP,JPLOOP, &
+ ' undef_value for these timenumber,',&
+ ' (UTCHour Min. Sec.), trajectorynumber, processnumber'
+ ELSE
+ write(ILUOUTLL,FMT='(I7,X,F10.5,X,I6,A,3(I2,X),A,2(I2,X),A,A)') INBVAL,&
+ XSPVAL,JTLOOP,'(', &
+ IHEURE,IMINUTE,ISEC,')', &
+ JTRLOOP,JPLOOP, &
+ 'number_of_next_lines, undef_value for these timenumber,',&
+ ' (UTCHour Min. Sec.), trajectorynumber, processnumber'
+ ENDIF
+ ENDIF
+ DO JKLOOP= kkdeb,kkfin
+ SELECT CASE ( HTYPEOUT(1:4) )
+ CASE ('LLHV','llhv')
+ IF (kkdeb == 1 .AND. kkfin == 1) THEN
+ ! champ 2D: altitude donnee par PALT(:,:,IGRID) ou XXZS(:,:,IGRID)
+ DO JJLOOP= kjdeb,kjfin
+ DO JILOOP= kideb,kifin
+ IF (PRESENT (PALT) ) THEN
+ if (KVERBIA > 0) then
+ print'(A,I2,X,F10.5)', 'LLHV 2D igrid PALT(:,:)= ',IGRID, &
+ PALT(JILOOP,JJLOOP,IGRID)
+ endif
+ IF (HTYPEOUT(1:4)=='LLHV') THEN
+ WRITE(ILUOUTLL,FMT=1000)ZLON(JILOOP,JJLOOP), &
+ ZLAT(JILOOP,JJLOOP), &
+ PALT(JILOOP,JJLOOP,IGRID), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ELSE IF (HTYPEOUT(1:4)=='llhv') THEN
+ WRITE(ILUOUTLL,FMT=1000)ZLAT(JILOOP,JJLOOP), &
+ ZLON(JILOOP,JJLOOP), &
+ PALT(JILOOP,JJLOOP,IGRID), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ENDIF
+ ELSE
+ IF (HTYPEOUT(1:4)=='LLHV') THEN
+ WRITE(ILUOUTLL,FMT=1000)ZLON(JILOOP,JJLOOP), &
+ ZLAT(JILOOP,JJLOOP), &
+ XXZS(JILOOP,JJLOOP,IGRID), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ELSE IF (HTYPEOUT(1:4)=='llhv') THEN
+ WRITE(ILUOUTLL,FMT=1000)ZLAT(JILOOP,JJLOOP), &
+ ZLON(JILOOP,JJLOOP), &
+ XXZS(JILOOP,JJLOOP,IGRID), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ENDIF
+ ENDIF
+ END DO
+ END DO
+ ELSE
+ ! champ 3D
+ !altitude des niveaux donnee par XZZ ou PALT
+ DO JJLOOP= kjdeb,kjfin
+ DO JILOOP= kideb,kifin
+ IF (PRESENT (PALT) ) THEN
+ if (KVERBIA > 0 .AND. JILOOP==1 .AND. JJLOOP==1) then
+ print '(A,I4,X,F10.5)', 'LLHV 3D K,PALT(1,1,K)= ',JKLOOP, &
+ PALT(JILOOP,JJLOOP,JKLOOP)
+ endif
+ IF (HTYPEOUT(1:4)=='LLHV') THEN
+ WRITE(ILUOUTLL,FMT=1000)ZLON(JILOOP,JJLOOP), &
+ ZLAT(JILOOP,JJLOOP), &
+ PALT(JILOOP,JJLOOP,JKLOOP), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ELSE IF (HTYPEOUT(1:4)=='llhv') THEN
+ WRITE(ILUOUTLL,FMT=1000)ZLAT(JILOOP,JJLOOP), &
+ ZLON(JILOOP,JJLOOP), &
+ PALT(JILOOP,JJLOOP,JKLOOP), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ENDIF
+ ELSE
+ IF (HTYPEOUT(1:4)=='LLHV') THEN
+ WRITE(ILUOUTLL,FMT=1000)ZLON(JILOOP,JJLOOP), &
+ ZLAT(JILOOP,JJLOOP), &
+ XZZ(JILOOP,JJLOOP,JKLOOP), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ELSE IF (HTYPEOUT(1:4)=='llhv') THEN
+ WRITE(ILUOUTLL,FMT=1000)ZLAT(JILOOP,JJLOOP), &
+ ZLON(JILOOP,JJLOOP), &
+ XZZ(JILOOP,JJLOOP,JKLOOP), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ENDIF
+ ENDIF
+ END DO
+ END DO
+ ENDIF
+ CASE ('IJHV','jihv')
+ IF (kkdeb == 1 .AND. kkfin == 1) THEN
+ ! champ 2D: altitude donnee par PALT(:,:,IGRID) ou XXZS(:,:,IGRID)
+ DO JJLOOP= kjdeb,kjfin
+ DO JILOOP= kideb,kifin
+ IF (PRESENT (PALT) ) THEN
+ if (KVERBIA > 0) then
+ print '(A,I2,X,F10.5)', 'IJHV 2D igrid PALT(:,:)= ',IGRID, &
+ PALT(JILOOP,JJLOOP,IGRID)
+ endif
+ IF (HTYPEOUT(1:4)=='IJHV') THEN
+ WRITE(ILUOUTLL,FMT=1001) JILOOP, &
+ JJLOOP, &
+ PALT(JILOOP,JJLOOP,IGRID), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ELSE IF (HTYPEOUT(1:4)=='jihv') THEN
+ WRITE(ILUOUTLL,FMT=1001)JJLOOP, &
+ JILOOP, &
+ PALT(JILOOP,JJLOOP,IGRID), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ENDIF
+ ELSE
+ IF (HTYPEOUT(1:4)=='IJHV') THEN
+ WRITE(ILUOUTLL,FMT=1001)JILOOP, &
+ JJLOOP, &
+ XXZS(JILOOP,JJLOOP,IGRID), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ELSE IF (HTYPEOUT(1:4)=='jihv') THEN
+ WRITE(ILUOUTLL,FMT=1001)JJLOOP, &
+ JILOOP, &
+ XXZS(JILOOP,JJLOOP,IGRID), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ENDIF
+ ENDIF
+ END DO
+ END DO
+ ELSE
+ ! champ 3D
+ !altitude des niveaux donnee par XZZ ou PALT
+ DO JJLOOP= kjdeb,kjfin
+ DO JILOOP= kideb,kifin
+ IF (PRESENT (PALT) ) THEN
+ if (KVERBIA > 0 .AND. JILOOP==1 .AND. JJLOOP==1) then
+ print '(A,I4,X,F10.5)', 'IJHV 3D K,PALT(1,1,K)= ',JKLOOP, &
+ PALT(JILOOP,JJLOOP,JKLOOP)
+ endif
+ IF (HTYPEOUT(1:4)=='IJHV') THEN
+ WRITE(ILUOUTLL,FMT=1001)JILOOP, &
+ JJLOOP, &
+ PALT(JILOOP,JJLOOP,JKLOOP), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ELSE IF (HTYPEOUT(1:4)=='jihv') THEN
+ WRITE(ILUOUTLL,FMT=1001)JILOOP, &
+ JJLOOP, &
+ PALT(JILOOP,JJLOOP,JKLOOP), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ENDIF
+ ELSE
+ IF (HTYPEOUT(1:4)=='IJHV') THEN
+ WRITE(ILUOUTLL,FMT=1001)JILOOP, &
+ JJLOOP, &
+ XZZ(JILOOP,JJLOOP,JKLOOP), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ELSE IF (HTYPEOUT(1:4)=='jihv') THEN
+ WRITE(ILUOUTLL,FMT=1001)JILOOP, &
+ JJLOOP, &
+ XZZ(JILOOP,JJLOOP,JKLOOP), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ENDIF
+ ENDIF
+ END DO
+ END DO
+ ENDIF
+
+ CASE ('LLZV','llzv','LLPV','llpv','LLAV','llav')
+ IF (PRESENT (PALT) ) THEN
+ !altitude des niveaux donnee par PALT
+ if (KVERBIA > 0) then
+ print'(A,A,I4,X,F10.5)', HTYPEOUT(1:4),' K,PALT(1,1,K)= ',JKLOOP,PALT(1,1,JKLOOP)
+ endif
+ ELSE
+ PRINT*,'** WRITELLHV: les altitudes doivent etre passees par argument'
+ PRINT*,' pour HTYPEOUT= ',HTYPEOUT(1:4)
+ KRETCODE=1
+ RETURN
+ ENDIF
+ DO JJLOOP= kjdeb,kjfin
+ DO JILOOP= kideb,kifin
+ IF (HTYPEOUT(1:2)=='LL') THEN
+ WRITE(ILUOUTLL,FMT=1000)ZLON(JILOOP,JJLOOP), &
+ ZLAT(JILOOP,JJLOOP), &
+ PALT(1,1,JKLOOP), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ELSE IF (HTYPEOUT(1:2)=='ll') THEN
+ WRITE(ILUOUTLL,FMT=1000)ZLAT(JILOOP,JJLOOP), &
+ ZLON(JILOOP,JJLOOP), &
+ PALT(1,1,JKLOOP), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ENDIF
+ END DO
+ END DO
+ CASE ('IJZV','jizv','IJPV','jipv')
+ IF (PRESENT (PALT) ) THEN
+ !altitude des niveaux donnee par PALT
+ if (KVERBIA > 0) then
+ print'(A,A,I4,X,F10.5)', HTYPEOUT(1:4),' K,PALT(1,1,K)= ',JKLOOP,PALT(1,1,JKLOOP)
+ endif
+ ELSE
+ PRINT*,'** WRITELLHV: les altitudes doivent etre passees par argument'
+ PRINT*,' pour HTYPEOUT= ',HTYPEOUT(1:4)
+ KRETCODE=1
+ RETURN
+ ENDIF
+ DO JJLOOP= kjdeb,kjfin
+ DO JILOOP= kideb,kifin
+ IF (HTYPEOUT(1:2)=='IJ') THEN
+ WRITE(ILUOUTLL,FMT=1001)JILOOP, &
+ JJLOOP, &
+ PALT(1,1,JKLOOP), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ELSE IF (HTYPEOUT(1:2)=='ji') THEN
+ WRITE(ILUOUTLL,FMT=1001)JJLOOP, &
+ JILOOP, &
+ PALT(1,1,JKLOOP), &
+ XVAR(JILOOP,JJLOOP,JKLOOP,JTLOOP,JTRLOOP,JPLOOP)
+ ENDIF
+ END DO
+ END DO
+
+ END SELECT
+ END DO
+ END DO
+ END DO
+ END DO
+!
+1000 FORMAT ( 2(F11.6,1x),F8.2,1x,E15.9)
+1001 FORMAT ( 2(I4,1x),F8.2,1x,E15.9)
+
+ if (KVERBIA >= 0) then
+ print*,'WRITELLHV: ecriture de ',TRIM(HLABELCHAMP)
+ print*,'--------- '
+ endif
+ENDIF
+!-------------------------------------------------------------------------------
+!
+!* 3. FERMETURE DU FICHIER DE SORTIE
+! ------------------------------
+!
+IF ( HFLAGFILE(1:3) == 'CLO' ) THEN
+ if (KVERBIA > 0) then
+ print*,'WRITELLHV: before closing file ',TRIM(YFILEOUT),' unit ',iluoutll
+ endif
+ !
+ ! fichier de sortie
+ CLOSE(UNIT=ILUOUTLL)
+ CALL FMFREE(YFILEOUT,CLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
+ IF( NRESPDIAS(NBFILES)==0 ) THEN
+ if (KVERBIA >= 0) then
+ print*,'End of WRITELLHV: File ',TRIM(YFILEOUT),' available with format ',HTYPEOUT
+ print*,'--------- '
+ endif
+ ELSE
+ PRINT*,' ****WRITELLHV: error when closing ', TRIM(YFILEOUT), &
+ ' code= ',NRESPDIAS(NBFILES)
+ KRETCODE=2
+ RETURN
+ ENDIF
+ !
+ENDIF
+!
+!-------------------------------------------------------------------------------
+END SUBROUTINE WRITELLHV
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/writevar.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/writevar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4b4cafdffee6dd3d5be3a071c9ad1d84bad64859
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/writevar.f90
@@ -0,0 +1,524 @@
+! #################################
+ MODULE MODI_WRITEVAR
+! #################################
+INTERFACE WRITEVAR
+ SUBROUTINE WRITEVAR(kideb,kifin,kjdeb,kjfin,kkdeb,kkfin,&
+ ktdeb,ktfin,ktrdeb,ktrfin,kpdeb,kpfin, &
+ HLABELCHAMP,HFILENAME,HFLAGFILE,HFILENAME_SUP,KVERBIA,KRETCODE)
+!
+CHARACTER(LEN=*), INTENT(IN) :: HLABELCHAMP, HFILENAME ! nom du champ et du fichier
+CHARACTER(LEN=3), INTENT(IN) :: HFLAGFILE ! NEW=creation
+ ! OLD=ajout
+ ! CLO=fermeture
+CHARACTER(LEN=3) :: HFILENAME_SUP ! chaine de caracteres
+ ! a rajouter a
+ ! HFILENAME
+ ! si ='NEN' alors HFILENAME
+ ! contient le nom complet
+INTEGER , INTENT(IN) :: KVERBIA ! prints de controle
+!
+INTEGER , intent(in) :: kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
+INTEGER , intent(in) :: ktdeb,ktfin,ktrdeb,ktrfin,kpdeb,kpfin
+!
+INTEGER , INTENT(OUT) :: KRETCODE ! Code de retour de la routine
+!
+END SUBROUTINE
+END INTERFACE
+END MODULE MODI_WRITEVAR
+! ######
+ SUBROUTINE WRITEVAR(kideb,kifin,kjdeb,kjfin,kkdeb,kkfin,&
+ ktdeb,ktfin,ktrdeb,ktrfin,kpdeb,kpfin, &
+ HLABELCHAMP,HFILENAME,HFLAGFILE,HFILENAME_SUP,KVERBIA,KRETCODE)
+! ################
+!
+!!**** *WRITEVAR* -
+!!
+!!
+!! PURPOSE
+!! -------
+! Ecriture d'un fichier de type:
+! diachronique en vue d'un traitement via diaprog
+!
+!
+!!** METHOD
+!! ------
+! utilisation des routines de diaprog : le tableau de stockage
+! XVAR est alloué avant l appel a WRITEVAR
+!
+! HFLAGFILE='NEW' lors de la premiere utilisation du fichier
+! HFLAGFILE='OLD' lors des utilisations suivantes
+! HFLAGFILE='CLO' pour la fermeture du fichier de sortie
+! ( fin de mise a jour du menu )
+!
+! KVERBIA= 0 impressions reduites au minimum (entree et sortie de la
+! routine)
+! KVERBIA >0 impressions pour signaler chaque etape de WRITEVAR
+!
+! KRETCODE = 0 execution de WRITEVAR correcte
+! KRETCODE = 1 erreur lors de l ouverture du fichier
+! KRETCODE = 2 erreur lors de l ecriture du champ
+! KRETCODE = 3 erreur lors de la fermeture du champ
+! KRETCODE = -1 pas de fermeture car pas d ouverture
+!
+! kideb,kifin,kjdeb,kjfin,kkdeb,kkfin = limites en indices i,j,k du
+! domaine à traiter dans XVAR
+! ktdeb,ktfin,ktrdeb,ktrfin = limites en indices
+! des dimensions 4,5 de XVAR
+!
+!! EXTERNAL
+!! --------
+!! FROM_COMPUTING_UNITS: retour aux unites initiales avant ecriture
+!! = passage inverse a celui realise par
+!! TO_COMPUTING_UNITS
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHORS
+!! -------
+!! I. Mallet , N. Asencio , J. Stein * CNRM*
+!!
+!! Copyright 2003, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 17/03/2003
+! N. Asencio 01/2005 : take in account 2D fields XZ, YZ and
+! zoomed fields inside the complete x-y-z-grid
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+! modules MESONH
+USE MODD_CST
+USE MODD_PARAMETERS, ONLY: JPHEXT,JPVEXT
+! NIMAX,NJMAX,NKMAX,NIINF, NISUP
+USE MODD_DIM1
+USE MODD_GRID, ONLY: XLAT0,XLON0,XRPK,XBETA
+! descriptif grille: XXHAT(:) ,XLAT(:,:),XDXHAT(:),XMAP(:,:)
+! ,XZS(:,:),XZZ(:,:,:) ,XCOSSLOPE(:,:),XDIRCOSXW(:,:)
+USE MODD_GRID1
+!
+! modules DIACHRO
+USE MODN_NCAR, ONLY: XSPVAL
+USE MODD_COORD ! grille : XXDXHAT(:,1:7) et XXX(:,1:7), XXZS(:,:,1:7)
+USE MODD_TYPE_AND_LH ! zoom selon x et y et z : NIL,NIH,NJL,NJH,NKL,NKH,CTYPE
+USE MODD_ALLOC_FORDIACHRO ! XVAR(i,j,k,,,), XMASK,XTRAJ ,XDATIME(16,t)
+USE MODD_OUT ! nom de fichiers NLUOUT,CLFIFM, CDESFM
+USE MODD_FILES_DIACHRO ! NBFILES + nom des fichiers CFILEDIAS, CLUOUTDIAS
+! pour l appel a WRITE_DIMGRIDREF, FMATTR et FMCLOS
+USE MODD_DIACHRO, ONLY:CFILEDIA,CLUOUTDIA, &
+ NLUOUTDIA,NRESPDIA,NNPRARDIA,NFTYPEDIA,NVERBDIA,NNINARDIA
+USE MODD_READLH
+!
+USE MODI_WRITE_DIMGRIDREF
+USE MODI_WRITE_DIACHRO
+USE MODI_MENU_DIACHRO
+USE MODI_FROM_COMPUTING_UNITS
+!
+!
+IMPLICIT NONE
+!
+!* 0.1 Arguments d'appel
+! ----------------
+!
+CHARACTER(LEN=*), INTENT(IN) :: HLABELCHAMP, HFILENAME ! nom du champ et du fichier
+CHARACTER(LEN=3), INTENT(IN) :: HFLAGFILE ! NEW=creation
+ ! OLD=ajout
+ ! CLO=fermeture
+CHARACTER(LEN=3) :: HFILENAME_SUP ! chaine de caracteres
+ !a rajouter a HFILENAME
+ ! si ='NEN' alors HFILENAME
+ ! contient le nom complet
+INTEGER , INTENT(IN) :: KVERBIA ! prints de controle
+!
+INTEGER , intent(in) :: kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
+INTEGER , intent(in) :: ktdeb,ktfin,ktrdeb,ktrfin,kpdeb,kpfin
+!
+INTEGER , INTENT(OUT) :: KRETCODE ! Code de retour de la routine
+!
+!* 0.2 Declarations des variables locales
+! -----------------------------------
+!
+INTEGER :: ISAVENGRIDIA,iret
+! repositionne le zoom/grille si zoom d un champ deja zoome
+INTEGER :: InewIL,InewIH,InewJL,InewJH,InewKL,InewKH
+!
+REAL ,DIMENSION(:,:,:,:,:,:) , ALLOCATABLE :: ZVARZS,& ! stockage dans
+ ! un tableau 6d de ZS
+ ! avant son ecriture
+ ZVARSAVE ! sauvegarde de XVAR
+!
+! taille=100 et 28 cf diachro
+CHARACTER (LEN=100) :: YSAVETITRE, YSAVECOMMENT, YSAVEUNITE
+CHARACTER (LEN=28), SAVE :: YFILEOUT='zadefinir' ! Fichier de sortie
+CHARACTER (LEN=28) :: YSAVEFILEDIA ! sauve le contenu de CFILEDIA
+CHARACTER (LEN=3) :: YFLAGZS
+CHARACTER (LEN=3) :: YFLAGFILE
+!
+INTEGER,SAVE :: IGROUP=0 ! pour compter le nb de champs ecrits
+!-------------------------------------------------------------------------------
+!
+!* 1. INITIALISATION
+! --------------
+!
+! Code de retour de la routine : 0 = OK
+! 1 = erreur lors de l ouverture du fichier
+KRETCODE=0
+!
+YFLAGFILE=HFLAGFILE
+!
+if (KVERBIA >= 0) then
+ print *,'--------- '
+ print *,'Beginning of WRITEVAR ',TRIM(HFILENAME),' ',TRIM(HLABELCHAMP),' ',&
+ TRIM(YFLAGFILE) ,' ',&
+ TRIM(HFILENAME_SUP),' ',KVERBIA
+endif
+!
+! code de retour d erreur des routines diaprog
+LPBREAD=.FALSE.
+!
+!* 1.1 Determine le nom du fichier de sortie au premier passage
+! -------------------
+!
+IF (YFILEOUT=='zadefinir') THEN
+ ! alignement à droite pour que le test LEN(YFILEOUT)-1:LEN(YFILEOUT)) == '.Z' fonctionne
+ YFILEOUT=(ADJUSTR(HFILENAME))
+ IF (HFILENAME_SUP(1:3) /= 'NEN' ) THEN
+ ! cas d un appel obs2mesonh
+ !avec redefinition totale du nom de fichier de sortie (on prend HFILENAME tel quel)
+ IF (HFILENAME_SUP(1:3)=='SAM') THEN
+ ! cas d un appel dans compute_r00pc
+ ! pas d ajout de suffixe (on complete un fichier existant ouvert en 'OLD')
+ ! m.a.j. de la liste des enregistrements diachroniques
+ CALL MENU_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),'READ')
+ IF(YFLAGFILE(1:3)/='CLO') YFLAGFILE='OLD'
+ ELSE
+ ! ajout d un suffixe 2
+ IF (LEN_TRIM(HFILENAME_SUP) == 0) HFILENAME_SUP='2 '
+ !
+ IF ( YFILEOUT(LEN(YFILEOUT)-1:LEN(YFILEOUT)) == '.Z' ) THEN
+ ! ajout du suffixe devant le .Z
+ ! et suppression de .Z car le fichier cree sera non compresse
+ YFILEOUT=ADJUSTL(YFILEOUT(1:LEN(YFILEOUT)-2)//HFILENAME_SUP)
+ ELSE
+ ! ajout en fin de nom
+ YFILEOUT=ADJUSTL(YFILEOUT(1:LEN(YFILEOUT))//HFILENAME_SUP)
+ END IF
+ END IF
+ ENDIF
+ YFILEOUT=ADJUSTL(YFILEOUT)
+END IF
+!
+if (KVERBIA > 0) then
+ PRINT*,'WRITEVAR: output diachronic file ',YFILEOUT
+endif
+!
+!* 1.2 Appel avec fichier courant different du fichier a ecrire
+! -------------------
+! cas possibles dans compute_r00pc, exrwdia et obs2mesonh avec HFILENAME_SUP(1:3) /= 'NEN'
+!
+IF ( YFLAGFILE(1:3) /= 'CLO' ) THEN
+! reinit eventuelle de l entete si fichier courant different du fichier a ecrire
+ YSAVEFILEDIA=CFILEDIA
+ IF ( YSAVEFILEDIA /= HFILENAME .AND. HFILENAME_SUP(1:3) /= 'NEN' ) THEN
+ ! seul le cas compute_r00pc est concerné
+ ! dans le cas obs2mesonh avec HFILENAME_SUP(1:3) /= 'NEN', la reinit de
+ ! l entete (date et heure) a été faite dans obs2mesonh
+ if (KVERBIA > 0) then
+ print *,'WRITEVAR: fichier courant dans READVAR ',YSAVEFILEDIA
+ print *,' different du fichier a ecrire ', HFILENAME
+ print *,' seul XVAR est sauve. La grille spatiale est supposée identique.'
+ endif
+ ISAVENGRIDIA=NGRIDIA(1)
+ YSAVETITRE=CTITRE(1)
+ YSAVECOMMENT=CCOMMENT(1)
+ YSAVEUNITE=CUNITE(1)
+ ! lecture d un champ de HFILENAME pour reinitialiser les modules diachro
+ !pour creer l en tete du fichier de sortie YFILEOUT(HFILENAME)
+ ALLOCATE(ZVARSAVE(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),&
+ SIZE(XVAR,4),SIZE(XVAR,5),SIZE(XVAR,6)) )
+ ZVARSAVE=XVAR
+ YFLAGZS='NOP'
+ CALL READVAR ('ZSBIS',HFILENAME,YFLAGZS,KVERBIA,iret)
+ if (KVERBIA > 0) then
+ print *,'WRITEVAR: apres reinit des modules pour le fichier ',HFILENAME
+ endif
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(SIZE(ZVARSAVE,1),SIZE(ZVARSAVE,2),SIZE(ZVARSAVE,3),&
+ SIZE(ZVARSAVE,4),SIZE(ZVARSAVE,5),SIZE(ZVARSAVE,6)) )
+ XVAR=ZVARSAVE
+ NGRIDIA(1)=ISAVENGRIDIA
+ CTITRE(1)=YSAVETITRE
+ CCOMMENT(1)=YSAVECOMMENT
+ CUNITE(1)=YSAVEUNITE
+ ENDIF
+ CFILEDIA=ADJUSTL(YFILEOUT)
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. Ouverture du fichier de sortie
+! -------------------
+!
+IF ( YFLAGFILE(1:3) /= 'CLO' ) THEN
+! Repositionne eventuellement le zoom en I et J , pour K (2 cas)
+InewIL=max(NREADIL,kideb)
+InewJL=max(NREADJL,kjdeb)
+InewKL=max(NREADKL,kkdeb)
+InewIH=min(NREADIH,kifin)
+InewJH=min(NREADJH,kjfin)
+InewKH=min(NREADKH,kkfin)
+IF ( NREADKL == NREADKH .AND. SIZE(XVAR,3) > 1 )THEN
+ ! en lecture le tableau contient un seul niveau vertical
+ ! en ecriture le tableau (autre variable) contient plusieurs niveaux:
+ ! ecriture du zoom utilisateur
+ InewKL=kkdeb
+ InewKH=kkfin
+ print *, '* warning: desaccord sur le zoom selon la verticale'
+ print *, ' le zoom lu=',NREADKL,NREADKH ,'et le zoom ecrit=',kkdeb,kkfin
+ ! Pour des traces diaprog sur ce nouveau zoom
+ NREADKL=kkdeb
+ NREADKH=kkfin
+ENDIF
+ if (KVERBIA > 1) then
+ print*,'ancienne localisation du champ/grille :',NREADIL,NREADIH,NREADJL,NREADJH,NREADKL,NREADKH
+ print*,' zoom demande: ', kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
+ print*,'nouvelle localisation du champ/grille :',&
+ InewIL,InewIH,InewJL,InewJH,InewKL,InewKH
+ endif
+ENDIF
+!
+IF ( YFLAGFILE(1:3) == 'NEW' ) THEN
+ !
+ CLUOUTDIA=CLUOUTDIAS(NBFILES)
+ NLUOUTDIA=NLUOUTDIAS(NBFILES)
+ if (KVERBIA >0)then
+ print *,'WRITEVAR: avant OPEN_FILES ',TRIM(YFILEOUT),' ',TRIM(CFILEDIA), &
+ ' ',TRIM(CLUOUTDIA)
+ endif
+ !
+ if (KVERBIA > 1) then
+ print *,'WRITEVAR: lat0,lon0 ',XLAT0,XLON0
+ endif
+ ! Ouverture et ecriture de l entete
+ CALL WRITE_DIMGRIDREF
+ IF (NRESPDIA.NE.0)THEN
+ KRETCODE=1
+ print *,' ****WRITEVAR: erreur lors de l ouverture du fichier ',&
+ YFILEOUT, 'code= ',NRESPDIA
+ RETURN
+ ENDIF
+ !
+ IF (TRIM(HLABELCHAMP)/='ZSBIS') THEN
+ ! Ecriture de ZS avec le nom ZSBIS necessaire pour tracer
+ ! le champ "ZS" dans diaprog
+ ALLOCATE(ZVARZS(SIZE(XZS,1),SIZE(XZS,2),1,1,1,1))
+ ZVARZS(:,:,1,1,1,1)=XZS
+ ISAVENGRIDIA=NGRIDIA(1)
+ YSAVETITRE=CTITRE(1)
+ YSAVECOMMENT=CCOMMENT(1)
+ YSAVEUNITE=CUNITE(1)
+ NGRIDIA(1)=4
+ CTITRE(1)='ZSBIS'
+ CUNITE(1)='m'
+ CCOMMENT(1)='X_Y_ZS (m)'
+ CALL WRITE_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),'ZSBIS','CART',NGRIDIA,&
+ XDATIME,ZVARZS(kideb:kifin,kjdeb:kjfin,:,:,:,:),&
+ XTRAJT,CTITRE,CUNITE,CCOMMENT, &
+ .FALSE.,.FALSE.,.FALSE.,InewIL,InewIH,InewJL,InewJH,1,1)
+ if (KVERBIA > 0) then
+ print *,'WRITEVAR(zs) size= 1:',size(ZVARZS,1),',1:',size(ZVARZS,2)
+ print *,' InewIL,InewIH,InewJL,InewJH,1,1=', InewIL,InewIH,InewJL,InewJH
+ end if
+ DEALLOCATE(ZVARZS)
+ NGRIDIA(1)=ISAVENGRIDIA
+ CTITRE(1)=YSAVETITRE
+ CCOMMENT(1)=YSAVECOMMENT
+ CUNITE(1)=YSAVEUNITE
+ if (KVERBIA > 1) then
+ print *,'WRITEVAR: apres write_diachro ZSBIS'
+ endif
+ !
+ IF (NRESPDIA.NE.0)THEN
+ KRETCODE=2
+ print *,' ****WRITEVAR: erreur lors de l ecriture de ZS dans ',&
+ YFILEOUT, ' code= ',NRESPDIA
+ RETURN
+ ELSE
+ IGROUP=IGROUP+1
+ ENDIF
+ !
+ ENDIF
+!
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 4 Ecriture du champ dans YFILEOUT
+! -------------------
+!
+IF ( YFLAGFILE(1:3) /= 'CLO' ) THEN
+ !
+ if (KVERBIA >= 0) then
+ print*,'WRITEVAR: ecriture en cours de ',HLABELCHAMP
+ endif
+ ! Retour aux unites initiales si necessaire
+ CALL FROM_COMPUTING_UNITS(HLABELCHAMP,CUNITE(1))
+ !
+ if (KVERBIA > 1) then
+ print*,'WRITEVAR: NGRID,NGRIDIA(:) =',NGRID,NGRIDIA
+ endif
+ !
+ IF ( SIZE(XVAR,6) /= SIZE(NGRIDIA,1))THEN
+ print * ,' *** erreur possible: la dimension6 de XVAR=',SIZE(XVAR,6) ,&
+ 'est differente de la dimension des tableaux NGRIDIA,CUNIT...'
+ ENDIF
+ IF ( SIZE(XVAR,4) /= SIZE(XDATIME,2))THEN
+ print * ,' *** erreur possible: la dimension4 de XVAR=',SIZE(XVAR,4) ,&
+ 'est differente de la dimension des tableaux XDATIME,XTRAJT...'
+ ENDIF
+ !
+ IF (ALLOCATED(XMASK)) THEN
+ ! CTYPE='MASK'
+ IF ( SIZE(XVAR,5) /= SIZE(XMASK,5))THEN
+ print * ,' *** erreur possible: la dimension5 de XVAR=',SIZE(XVAR,5) ,&
+ 'est differente de la dimension5 du tableau XMASK'
+ ENDIF
+ CALL WRITE_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),HLABELCHAMP,CTYPE, &
+ NGRIDIA(kpdeb:kpfin),XDATIME(:,ktdeb:ktfin), &
+ XVAR(kideb:kifin,kjdeb:kjfin,kkdeb:kkfin,&
+ ktdeb:ktfin,ktrdeb:ktrfin,kpdeb:kpfin),&
+ XTRAJT(ktdeb:ktfin,:),CTITRE(kpdeb:kpfin),&
+ CUNITE(kpdeb:kpfin),CCOMMENT(kpdeb:kpfin), &
+ LICP,LJCP,LKCP,InewIL,InewIH,InewJL,InewJH,InewKL,InewKH,&
+ ! LICP,LJCP,LKCP,kideb,kifin,kjdeb,kjfin,kkdeb,kkfin,&
+ PMASK=XMASK)
+ ELSE IF (ALLOCATED(XTRAJX).AND.ALLOCATED(XTRAJY).AND.ALLOCATED(XTRAJZ))THEN
+ IF ( CTYPE=='SSOL' ) THEN
+ CALL WRITE_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),HLABELCHAMP,CTYPE, &
+ NGRIDIA(kpdeb:kpfin),XDATIME(:,ktdeb:ktfin), &
+ XVAR(kideb:kifin,kjdeb:kjfin,kkdeb:kkfin,&
+ ktdeb:ktfin,ktrdeb:ktrfin,kpdeb:kpfin),&
+ XTRAJT(ktdeb:ktfin,:),CTITRE(kpdeb:kpfin),&
+ CUNITE(kpdeb:kpfin),CCOMMENT(kpdeb:kpfin), &
+ PTRAJX=XTRAJX,PTRAJY=XTRAJY, &
+ PTRAJZ=XTRAJZ(kkdeb:kkfin,1:1,ktrdeb:ktrfin))
+ ELSE
+ ! CTYPE='DRST' or CTYPE='RSPL' or CTYPE='RAPL'
+ CALL WRITE_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),HLABELCHAMP,CTYPE, &
+ NGRIDIA(kpdeb:kpfin),XDATIME(:,ktdeb:ktfin), &
+ XVAR(kideb:kifin,kjdeb:kjfin,kkdeb:kkfin,&
+ ktdeb:ktfin,ktrdeb:ktrfin,kpdeb:kpfin),&
+ XTRAJT(ktdeb:ktfin,:),CTITRE(kpdeb:kpfin),&
+ CUNITE(kpdeb:kpfin),CCOMMENT(kpdeb:kpfin), &
+ PTRAJX=XTRAJX,PTRAJY=XTRAJY, &
+ PTRAJZ=XTRAJZ(kkdeb:kkfin,ktdeb:ktfin,ktrdeb:ktrfin))
+ ENDIF
+ ELSE IF (.NOT.ALLOCATED(XTRAJX) .AND. .NOT.ALLOCATED(XTRAJY) .AND. .NOT.ALLOCATED(XTRAJZ))THEN
+ ! CTYPE='CART' or CTYPE='SPXY'
+ CALL WRITE_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),HLABELCHAMP,CTYPE, &
+ NGRIDIA(kpdeb:kpfin),XDATIME(:,ktdeb:ktfin), &
+ XVAR(kideb:kifin,kjdeb:kjfin,kkdeb:kkfin,&
+ ktdeb:ktfin,ktrdeb:ktrfin,kpdeb:kpfin),&
+ XTRAJT(ktdeb:ktfin,:),CTITRE(kpdeb:kpfin),&
+ CUNITE(kpdeb:kpfin),CCOMMENT(kpdeb:kpfin), &
+ LICP,LJCP,LKCP,InewIL,InewIH,InewJL,InewJH,InewKL,InewKH)
+ ! LICP,LJCP,LKCP,kideb,kifin,kjdeb,kjfin,kkdeb,kkfin)
+ ELSE
+ KRETCODE=2
+ print *,' ****WRITEVAR: cas d ecriture non prevu pour ',HLABELCHAMP
+ RETURN
+ ENDIF
+ if (KVERBIA > 0) then
+ print *,'WRITEVAR(champ)'
+ print *,' ideb,ifin,jdeb,jfin,kdeb,kfin=', &
+ kideb,kifin,kjdeb,kjfin,kkdeb,kkfin
+ print *,' tdeb,tfin,trdeb,trfin,pdeb,pfin=',&
+ ktdeb,ktfin,ktrdeb,ktrfin,kpdeb,kpfin
+ end if
+ if (KVERBIA > 1) then
+ print*,'WRITEVAR: apres write_diachro, CTYPE=',CTYPE,' xdatime(16,ktdeb:ktfin)'
+ do iret=ktdeb,ktfin
+ print*, iret,' ',XDATIME(1:4,iret)
+ print*, XDATIME(5:8,iret)
+ print*, XDATIME(9:12,iret)
+ print*, XDATIME(13:16,iret)
+ end do
+ endif
+ IF (NRESPDIA.NE.0)THEN
+ KRETCODE=2
+ print *,' ****WRITEVAR: erreur lors de l ecriture de ',HLABELCHAMP,&
+ ' dans ',YFILEOUT, ' code= ',NRESPDIA
+ RETURN
+ ELSE
+ IGROUP=IGROUP+1
+ ENDIF
+ !
+ CFILEDIA=YSAVEFILEDIA
+ IF ( YSAVEFILEDIA /= HFILENAME .AND. HFILENAME_SUP(1:3) /= 'NEN') THEN
+ ! retablit les infos du fichier courant
+ if (KVERBIA > 0) then
+ print *,'WRITEVAR: avant retour aux infos des modules pour ',&
+ ' le fichier courant ', YSAVEFILEDIA
+ endif
+ !
+ YFLAGZS='NOP'
+ CALL READVAR ('ZSBIS',YSAVEFILEDIA,YFLAGZS,KVERBIA,iret)
+ DEALLOCATE(XVAR)
+ ALLOCATE(XVAR(SIZE(ZVARSAVE,1),SIZE(ZVARSAVE,2),SIZE(ZVARSAVE,3),&
+ SIZE(ZVARSAVE,4),SIZE(ZVARSAVE,5),SIZE(ZVARSAVE,6)) )
+ XVAR=ZVARSAVE
+ DEALLOCATE(ZVARSAVE)
+ ENDIF
+ if (KVERBIA >= 0) then
+ print *,'--------- '
+ endif
+ !
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 4 FERMETURE des fichiers de sortie
+! ---------------------------------
+!
+IF ( YFLAGFILE(1:3) == 'CLO' ) THEN
+ if (KVERBIA > 0 .AND. IGROUP>0) then
+ print *,'WRITEVAR: before closing the output file ',TRIM(YFILEOUT)
+ print *,' List of the ',IGROUP,' variables :'
+ endif
+ !
+ ! fichier de sortie
+ CALL MENU_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),'END')
+ if (KVERBIA > 0 .AND. IGROUP>0) then
+ CALL MENU_DIACHRO(YFILEOUT,CLUOUTDIAS(NBFILES),'READ')
+ endif
+ IF (IGROUP>0) THEN
+ CALL FMCLOS(YFILEOUT,'KEEP',CLUOUTDIAS(NBFILES),NRESPDIAS(NBFILES))
+ !
+ if (NRESPDIAS(NBFILES)==0) then
+ print*,'End of WRITEVAR: file ',TRIM(YFILEOUT),' available '
+ print *,'--------- '
+ else
+ print *,' ****WRITEVAR: error when closing the file ',&
+ TRIM(YFILEOUT), ' code= ',NRESPDIAS(NBFILES)
+ KRETCODE=3
+ endif
+ ELSE
+ print *,' ****WRITEVAR: file not opened, so no closing'
+ KRETCODE=-1
+ END IF
+ ! pour determination du nom du fichier de sortie au prochain appel
+ YFILEOUT='zadefinir'
+ IGROUP=0
+ !
+ENDIF
+!
+END SUBROUTINE WRITEVAR
diff --git a/LIBTOOLS/tools/diachro/src/EXTRACTDIA/zmoy.f90 b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/zmoy.f90
new file mode 100644
index 0000000000000000000000000000000000000000..21a7820b1ce70ab5df89d55b1cd79cfc0138bea4
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/EXTRACTDIA/zmoy.f90
@@ -0,0 +1,157 @@
+! ##################
+ MODULE MODI_ZMOY
+! ##################
+!
+INTERFACE
+ SUBROUTINE ZMOY(pvar,KGRID,pmoyz,pvalmin,pvalmax,pundef,KJPVEXT,KJPHEXT)
+!
+REAL , intent(in), dimension (:,:,:) :: pvar ! champ3D a traiter
+INTEGER , intent(in) :: KGRID ! numero de grille du champ
+INTEGER , intent(in) :: KJPvext,KJPhext ! points a exclure
+REAL , intent(in) :: pvalmin,pvalmax ! definition de la couche
+ ! altitude en mètres
+REAL , intent(in) :: pundef ! valeur indefinie
+REAL , intent(out), dimension (:,:) :: pmoyz ! champ2D moyenné sur la couche
+END SUBROUTINE ZMOY
+END INTERFACE
+END MODULE MODI_ZMOY
+!
+!------------------------------------------------------------------------------
+!
+! ####################################################
+ SUBROUTINE ZMOY(pvar,KGRID,pmoyz,pvalmin,pvalmax,pundef,KJPVEXT,KJPHEXT)
+! ################
+!
+!!**** *zmoy* -
+!!
+!!
+!! PURPOSE
+!! -------
+! moyenne sur la couche pvalmin,pvalmax
+! pvar peut etre partiellement indefini ( = pundef)
+!
+!!** METHOD
+!!
+!! AUTHORS
+!! -------
+!! N. Asencio * CNRM* d apres evoltempo.f90 J. Stein
+!!
+!! Copyright 2003, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+! appel de zinter avec le parametre optionel KNIVMOD
+! toutes les grilles sont traitées par appel à COMPCOORD_FORDIACHRO
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+! descriptIF grille: XXHAT ,XLAT,XDXHAT,XMAP,XZS,XZZ
+USE MODD_GRID1, ONLY:XZZ
+!
+USE MODI_ZINTER
+IMPLICIT NONE
+!* 0.1 Arguments d'appel
+REAL , intent(in), dimension (:,:,:) :: pvar ! champ3D a traiter
+INTEGER , intent(in) :: KGRID ! numero de grille du champ
+INTEGER , intent(in) :: KJPvext,KJPhext ! points a exclure
+REAL , intent(in) :: pvalmin,pvalmax ! definition de la couche
+ ! altitude en mètres
+REAL , intent(in) :: pundef ! valeur indefinie
+REAL , intent(out), dimension (:,:) :: pmoyz ! champ2D moyenné sur la couche
+
+!* 0.2 variables locales
+INTEGER :: ji,jj,jk ! boucles
+INTEGER :: ikmin,ikmax
+REAL , allocatable ,dimension (:,:,:) :: zinterpomin,zinterpomax
+!! champs interpolés aux bornes de la couche
+INTEGER , allocatable ,dimension (:,:) :: iknivmin,iknivmax
+!! stockage des premiers niveaux modele
+!! situés au dessus de chaque borne de la couche
+REAL :: zhmin
+! specIFique a l appel de zinter
+REAL , allocatable ,dimension (:) :: pnivz ! liste des niveaux verticaux
+! ici un seul niveau utilisé mais zinter s'attEND à un tableau 1D
+INTEGER :: ikdebmod ! premier niveau modele au dessus du sol
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. interpolation sur z=pvalmin et pvalmax et recuperation
+! des niveaux K correspondant
+!
+IF (.NOT. ALLOCATEd(zinterpomin)) &
+ ALLOCATE(zinterpomin(size(pvar,1),size(pvar,2),1))
+IF (.NOT. ALLOCATEd(zinterpomax)) &
+ ALLOCATE(zinterpomax(size(pvar,1),size(pvar,2),1))
+IF (.NOT. ALLOCATEd(iknivmin)) ALLOCATE(iknivmin(size(pvar,1),size(pvar,2)))
+IF (.NOT. ALLOCATEd(iknivmax)) ALLOCATE(iknivmax(size(pvar,1),size(pvar,2)))
+IF (.NOT. ALLOCATEd(pnivz)) ALLOCATE(pnivz(1))
+!
+! init du tableau XZZ pour la grille= KGRID
+CALL COMPCOORD_FORDIACHRO(KGRID)
+!
+ikdebmod=2
+pnivz(1)=pvalmin
+CALL ZINTER(pvar,XZZ,zinterpomin,pnivz,ikdebmod,pundef,KNIVMOD=iknivmin)
+pnivz(1)=pvalmax
+CALL ZINTER(pvar,XZZ,zinterpomax,pnivz,ikdebmod,pundef,KNIVMOD=iknivmax)
+!
+! en retour de zinter, knivmax= premiers niveaux modele > pvalmax
+! pour obtenir les derniers niveaux inclus dans la couche:
+WHERE ( iknivmax /= 1+KJPVEXT ) iknivmax=iknivmax-1
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. moyenne verticale sur la couche
+!
+pmoyz=0.
+!
+! Cumul
+!
+DO jj=1+KJPHEXT,SIZE(pvar,2)-KJPHEXT
+ DO ji=1+KJPHEXT,SIZE(pvar,1)-KJPHEXT
+ ikmin=max(iknivmin(ji,jj),1+KJPVEXT)
+ ikmax=iknivmax(ji,jj)
+ !
+ ! borne inferieure de la couche
+ !
+ IF ( zinterpomin(ji,jj,1) /= pundef .AND. pvar(ji,jj,ikmin) /= pundef ) then
+ pmoyz(ji,jj) = &
+ 0.5*( zinterpomin(ji,jj,1)+pvar(ji,jj,ikmin) )*(XZZ(ji,jj,ikmin)-pvalmin)
+ ENDIF
+ !
+ ! borne superieure de la couche
+ !
+ IF ( zinterpomax(ji,jj,1) /= pundef .AND. pvar(ji,jj,ikmax) /= pundef ) then
+ pmoyz(ji,jj) = pmoyz(ji,jj) + &
+ 0.5*( zinterpomax(ji,jj,1)+pvar(ji,jj,ikmax) )*(pvalmax-XZZ(ji,jj,ikmax))
+ ENDIF
+ !
+ ! tous les niveaux modele inclus dans la couche
+ !
+ DO jk=ikmin,ikmax-1
+ IF ( pvar(ji,jj,jk) /= pundef .AND. pvar(ji,jj,jk+1) /= pundef ) then
+ pmoyz(ji,jj) = pmoyz(ji,jj) + &
+ 0.5*( pvar(ji,jj,jk) + pvar(ji,jj,jk+1))*(XZZ(ji,jj,jk+1)-XZZ(ji,jj,jk))
+ ENDIF
+ END DO
+ !
+ ! calcul de la hauteur utile de la couche
+ zhmin=max(pvalmin,XZZ(ji,jj,ikdebmod))
+ IF ( pmoyz(ji,jj) /= 0.) pmoyz(ji,jj)=pmoyz(ji,jj)/ (pvalmax-zhmin)
+ !
+ END DO
+END DO
+!
+! passage a indef des zones ou la moyenne est restee a l init 0.
+WHERE ( pmoyz == 0. ) pmoyz=pundef
+!
+! nettoyage
+IF ( ALLOCATED(zinterpomin)) DEALLOCATE(zinterpomin)
+IF ( ALLOCATED(zinterpomax)) DEALLOCATE(zinterpomax)
+IF ( ALLOCATED(iknivmin)) DEALLOCATE(iknivmin)
+IF ( ALLOCATED(iknivmax)) DEALLOCATE(iknivmax)
+IF ( ALLOCATED(pnivz)) DEALLOCATE(pnivz)
+
+END SUBROUTINE ZMOY
diff --git a/LIBTOOLS/tools/diachro/src/FM/fm_read.f90 b/LIBTOOLS/tools/diachro/src/FM/fm_read.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8f65534eda58bd2c7f35fbfc5e5f7371f913643a
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM/fm_read.f90
@@ -0,0 +1,231 @@
+! ######spl
+ SUBROUTINE FM_READ(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! ###########################################################
+!
+!!**** *FM_READ* - routine to read a single data article in a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREAD is to read one single article of data in
+! a Meso-nh file. This routine only holds for LFI-files (not namelists)
+!
+!!** METHOD
+!! ------
+!!
+!! The unformatted fortran read operation is actually executed in the
+!! routine LFILEC. You just need to indicate the name of the file
+!! without the ".lfi" suffix,
+!! and the name of the article you want to read, as well as the length of
+!! the field. LFILEC then knows how
+!! to get the record number of the desired field by referring to an intern
+!! table of association.
+!! In FMREAD, the data is first stored in IWORK and then split in KGRID
+!! (IWORK(1)=C-grid indicator) and KFIELD (integer or real data field)
+!! which are both stored on the same LFI logical article.
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FMLOOK,LFINFO,LFILEC,CHAR
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! MODULE: MODD_FMDECLAR contains management parameters and
+!! storage arrays to move information around at the
+!! level of all "FM"-routines.
+!!
+!! REFERENCE
+!! ---------
+!!
+!! see the Technical Specifications Report for the Meso-nh project
+!! (in French)
+!!
+!! AUTHOR
+!! ------
+!!
+!! C. FISCHER *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/94
+!! modified by V. Masson 16/09/96 (prints if error occurs)
+!!
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*), INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*), INTENT(IN) ::HRECFM ! name of the desired article
+
+CHARACTER(LEN=*), INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+
+INTEGER(KIND=8),DIMENSION(1:KLENG),INTENT(OUT)::KFIELD ! array containing
+ ! the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=JPXKRK), INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems occured
+
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER::IRESP,ILENGA,IPOSEX,ITOTAL,INUMBR,J,IROW,IFMFNL,ILUPRI
+INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE::IWORK,IWORKNEW
+INTEGER,DIMENSION(1:JPXKRK)::ICOMMENT
+CHARACTER(LEN=JPFINL)::YFNLFI
+CHARACTER(LEN=LEN(HFILEM))::YINTFN
+INTEGER :: DATASIZE,ITYPCOD,NEWSIZE
+!
+!* 0.3 Taskcommon for logical units
+!
+COMMON/TASKREAD/ILUPRI,INUMBR,IRESP
+!DIR$ TASKCOMMON TASKREAD
+!
+!----------------------------------------------------------------------------
+!
+!* 1.1 THE NAME OF LFIFM
+!
+IRESP = 0 ; IROW = 0 ; ILUPRI = 6
+IFMFNL=JPFINL-4
+
+IROW=LEN(HFILEM)
+
+IF (IROW.EQ.0) THEN
+ IRESP=-61
+ GOTO 1000
+ELSEIF (IROW.GT.IFMFNL) THEN
+ IRESP=-62
+ GOTO 1000
+ENDIF
+YINTFN=ADJUSTR(HFILEM)
+YFNLFI=YINTFN//'.lfi'
+YFNLFI=ADJUSTL(YFNLFI)
+
+!
+!* 1.2 WE LOOK FOR THE FILE'S LOGICAL UNIT
+!
+CALL FMLOOK(YFNLFI,HFIPRI,INUMBR,IRESP)
+IF (IRESP.NE.0) GOTO 1000
+
+!
+!* 2.a LET'S GET SOME INFORMATION ON THE DESIRED ARTICLE
+!
+!ILENGA=0
+!print *,' ***FM_READ ILENGA mis a 0 avant CALL LFINFO'
+CALL LFINFO(IRESP,INUMBR,HRECFM,ILENGA,IPOSEX)
+!print *,' ***FM_READ ILENGA,IRESP AP LFINFO ',ILENGA,IRESP
+IF (IRESP.NE.0) THEN
+ GOTO 1000
+ELSEIF (ILENGA.EQ.0) THEN
+!print *,' ***FM_READ passage IRESP=-47 GOTO 1000'
+ IRESP=-47
+ GOTO 1000
+ELSEIF (ILENGA.GT.JPXFIE) THEN
+ IRESP=-48
+ GOTO 1000
+ENDIF
+
+!
+!* 2.b UNFORMATTED DIRECT ACCESS READ OPERATION
+!
+ITOTAL=ILENGA
+IF(ALLOCATED(IWORK)) DEALLOCATE(IWORK)
+ALLOCATE(IWORK(ITOTAL))
+
+CALL LFILEC(IRESP,INUMBR,HRECFM,IWORK,ITOTAL)
+IF (IRESP.NE.0) GOTO 1000
+!
+!* 2.c THE GRID INDICATOR AND THE COMMENT STRING
+!* ARE SEPARATED FROM THE DATA
+!
+KGRID=IWORK(1)
+KLENCH=IWORK(2)
+IF (KLENCH < 0 .OR. KLENCH > JPXKRK) THEN
+ IRESP=-58
+ GOTO 1000
+END IF
+!
+DATASIZE=ITOTAL-KLENCH-2
+!
+CALL GET_COMPHEADER(IWORK(3+KLENCH),DATASIZE,NEWSIZE,ITYPCOD)
+IF (NEWSIZE >= 0) THEN
+ ! compressed field found
+ WRITE (ILUPRI,*) TRIM(HRECFM),' is compressed (old/new/kleng SIZE):',DATASIZE,NEWSIZE,KLENG
+ IF (KLENG /= NEWSIZE) THEN
+ IRESP=-63
+ GOTO 1000
+ ENDIF
+
+ ALLOCATE(IWORKNEW(NEWSIZE))
+ CALL DECOMPRESS_FIELD(IWORKNEW,NEWSIZE,IWORK(3+KLENCH),DATASIZE,ITYPCOD)
+ KFIELD(1:KLENG) = IWORKNEW(1:KLENG)
+ DEALLOCATE(IWORKNEW)
+ELSE
+ IF (KLENG /= DATASIZE) THEN
+ IRESP=-63
+ GOTO 1000
+ END IF
+ KFIELD(1:KLENG)=IWORK(KLENCH+3:ITOTAL)
+END IF
+!
+SELECT CASE (KLENCH)
+CASE(-10:-1)
+ IRESP=-58
+ GOTO 1000
+CASE(0)
+ KFIELD(1:KLENG)=IWORK(3:ITOTAL)
+CASE(1:JPXKRK)
+ ICOMMENT(1:KLENCH)=IWORK(3:KLENCH+2)
+ DO J=1,KLENCH
+ HCOMMENT(J:J)=CHAR(ICOMMENT(J))
+ ENDDO
+CASE(JPXKRK+1:)
+ IRESP=-56
+ GOTO 1000
+END SELECT
+!
+DEALLOCATE(IWORK)
+!
+! this is a pure binary field: no uncompressing of any kind
+!
+!* 3. MESSAGE PRINTING WHATEVER THE ISSUE WAS
+!
+1000 CONTINUE
+
+IF (IRESP.NE.0) THEN
+ YFNLFI=ADJUSTL(HFIPRI)
+ DO J=1,JPNXLU
+ IF (CNAMFI(J).EQ.YFNLFI) THEN
+ ILUPRI=J
+ EXIT
+ ENDIF
+ ENDDO
+ WRITE (ILUPRI,*) ' exit from FMREAD with IRESP:',IRESP
+ !WRITE (ILUPRI,*) ' | HFILEM = ',HFILEM
+ WRITE (ILUPRI,*) ' | HRECFM = ',HRECFM
+ !WRITE (ILUPRI,*) ' | KLENG = ',KLENG
+ !WRITE (ILUPRI,*) ' | KGRID = ',KGRID
+ !WRITE (ILUPRI,*) ' | KLENCH = ',KLENCH
+ ! Suppression OBLIGATOIRE de l'impression suivante car pb qd IWORK non alloue
+ ! (IRESP=-47)
+ !WRITE (ILUPRI,*) ' | KLENCH = ',IWORK(23)
+ENDIF
+KRESP=IRESP
+
+RETURN
+ END SUBROUTINE FM_READ
diff --git a/LIBTOOLS/tools/diachro/src/FM/fm_writ.f90 b/LIBTOOLS/tools/diachro/src/FM/fm_writ.f90
new file mode 100644
index 0000000000000000000000000000000000000000..250a985a62d932581414922b9806cf6a1a8b8eb8
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM/fm_writ.f90
@@ -0,0 +1,195 @@
+! ###########################################################
+ SUBROUTINE FM_WRIT(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! ###########################################################
+!
+!!**** *FM_WRIT* - routine to write a single data article into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRIT is to write one article into a Meso-nh data file.
+! This routine only holds for a LFI-file (not namelist).
+!
+!!** METHOD
+!! ------
+!!
+!! The unformatted write operation is actually performed by the routine
+!! LFIECR. You need to indicate the file name without the ".lfi"
+!! suffix, the data array and the
+!! length of this array. Furthermore, you have to give a name for the article
+!! you are writing (string) which you better choose by convention.
+!! FMWRIT also appends the grid-indicator (KGRID) at the beginning of
+!! the LFI logical article (IWORK(1)) ; then the length of the comment
+!! string (KLENCH) ; then the comment string itself which is first
+!! converted into integer type using ICHAR.
+!! Finally, it writes the data (integer or
+!! real) itself (rest of array IWORK). We stress that the length KLENG
+!! that the user has to indicate is the length of the real data array
+!! WITHOUT taking the other fields into account.
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FMLOOK,LFIECR,ICHAR
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! MODULE: MODD_FMDECLAR contains management parameters and
+!! storage arrays to move information around at the
+!! level of all "FM"-routines.
+!!
+!! REFERENCE
+!! ---------
+!!
+!! see the Technical Specifications Report for the Meso-nh project
+!! (in French)
+!!
+!! AUTHOR
+!! ------
+!!
+!! C. FISCHER *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/94
+!! modified by V. Masson 16/09/96 (prints if error occurs)
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER(KIND=8),DIMENSION(1:KLENG),INTENT(IN) ::KFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=KLENCH), INTENT(IN) ::HCOMMENT ! comment string)
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER::IRESP,ITOTAL,INUMBR,J,IROW,IFMFNL,ILUPRI
+INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE::IWORK
+INTEGER,DIMENSION(1:JPXKRK)::ICOMMENT
+CHARACTER(LEN=JPFINL)::YFNLFI
+CHARACTER(LEN=LEN(HFILEM))::YINTFN
+!
+!* 0.3 Taskcommon for logical units
+!
+COMMON/TASKWRIT/ILUPRI,INUMBR,IRESP
+!DIR$ TASKCOMMON TASKWRIT
+!
+!----------------------------------------------------------------------------
+!
+!* 1.1 THE NAME OF LFIFM
+!
+IRESP = 0 ; IROW = 0 ; ILUPRI = 6
+IFMFNL=JPFINL-4
+
+IROW=LEN(HFILEM)
+
+IF (IROW.EQ.0) THEN
+ IRESP=-64
+ GOTO 1000
+ELSEIF (IROW.GT.IFMFNL) THEN
+ IRESP=-65
+ GOTO 1000
+ENDIF
+YINTFN=ADJUSTR(HFILEM)
+YFNLFI=YINTFN//'.lfi'
+YFNLFI=ADJUSTL(YFNLFI)
+
+!
+!* 1.2 WE LOOK FOR THE FILE'S LOGICAL UNIT
+!
+CALL FMLOOK(YFNLFI,HFIPRI,INUMBR,IRESP)
+IF (IRESP.NE.0) GOTO 1000
+
+!
+!* 2. GRID INDICATOR, COMMENT AND DATA ARE PUT TOGETHER
+!
+IF (KLENG.LE.0) THEN
+ IRESP=-40
+ GOTO 1000
+ELSEIF (KLENG.GT.JPXFIE) THEN
+ IRESP=-43
+ GOTO 1000
+ELSEIF ((KGRID.LT.0).OR.(KGRID.GT.8)) THEN
+ IRESP=-46
+ GOTO 1000
+ENDIF
+
+ITOTAL=KLENG+1+KLENCH+1
+IF(ALLOCATED(IWORK)) DEALLOCATE(IWORK)
+ALLOCATE(IWORK(ITOTAL))
+
+IWORK(1)=KGRID
+
+SELECT CASE (KLENCH)
+CASE(:-1)
+ IRESP=-55
+ GOTO 1000
+CASE(0)
+ IWORK(2)=KLENCH
+ IWORK(3:KLENG+2)=KFIELD(1:KLENG)
+CASE(1:JPXKRK)
+ DO J=1,KLENCH
+ ICOMMENT(J)=ICHAR(HCOMMENT(J:J))
+ ENDDO
+ IWORK(2)=KLENCH
+ IWORK(3:KLENCH+2)=ICOMMENT(1:KLENCH)
+ IWORK(KLENCH+3:ITOTAL)=KFIELD(1:KLENG)
+CASE(JPXKRK+1:)
+ IRESP=-57
+ GOTO 1000
+END SELECT
+
+!
+! no compressing of any kind: the data is pure binary
+!
+!* 3. UNFORMATTED, DIRECT ACCESS WRITE OPERATION
+!
+CALL LFIECR(IRESP,INUMBR,HRECFM,IWORK,ITOTAL)
+IF (IRESP.NE.0) GOTO 1000
+
+DEALLOCATE(IWORK)
+!
+!* 4. MESSAGE PRINTING WHATEVER THE ISSUE WAS
+!
+1000 CONTINUE
+
+IF (IRESP.NE.0) THEN
+YFNLFI=ADJUSTL(HFIPRI)
+DO J=1,JPNXLU
+ IF (CNAMFI(J).EQ.YFNLFI) THEN
+ ILUPRI=J
+ EXIT
+ ENDIF
+ENDDO
+WRITE (ILUPRI,*) ' exit from FMWRIT with IRESP:',IRESP
+WRITE (ILUPRI,*) ' | HFILEM = ',HFILEM
+WRITE (ILUPRI,*) ' | HRECFM = ',HRECFM
+WRITE (ILUPRI,*) ' | KLENG = ',KLENG
+WRITE (ILUPRI,*) ' | KGRID = ',KGRID
+WRITE (ILUPRI,*) ' | KLENCH = ',KLENCH
+ENDIF
+KRESP=IRESP
+
+RETURN
+ END SUBROUTINE FM_WRIT
diff --git a/LIBTOOLS/tools/diachro/src/FM/fmattr.f90 b/LIBTOOLS/tools/diachro/src/FM/fmattr.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2253491b55b2a9c3c33c827fb22e06d6c6924d95
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM/fmattr.f90
@@ -0,0 +1,160 @@
+! ######spl
+ SUBROUTINE FMATTR(HFILEM,HFIPRI,KNUMBR,KRESP)
+! #############################################
+!
+!!**** *FMATTR* - routine to attribute a logical unit to a file name
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMATTR is to attribute to the file named HFILEM
+! the logical unit number KNUMBR chosen among the free logical units
+!
+!!** METHOD
+!! ------
+!!
+!! If FMATTR is called for the very first time, then all the management
+!! arrays used by the FM-routines are initialized in FMINIT.
+!! Otherwise, the name HFILEM is searched in the array CNAMFI, where
+!! it should not exist ! Finally, a logical unit number is searched
+!! in array CNAMFI. As soon as a free place is found (CNAMFI=CPUDFN),
+!! this place becomes the logical unit number for HFILEM and CNAMFI is
+!! set to HFILEM.
+!!
+!! EXTERNAL
+!! --------
+!!
+!! LOCKON,LOCKOFF
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! MODULE: MODD_FMDECLAR contains management parameters and
+!! storage arrays to move information around at the
+!! level of all "FM"-routines.
+!! MODD_FMMULTI contains variables for multitasking
+!!
+!! REFERENCE
+!! ---------
+!!
+!! see the Technical Specifications Report for the Meso-nh project
+!! (in French)
+!!
+!! AUTHOR
+!! ------
+!!
+!! C. FISCHER *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 04/94
+!! modified by C. Fischer 5/7/95 (locks for multitasking)
+!! modified by V. Masson 16/09/96 (prints if error occurs)
+!!
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+USE MODD_FMMULTI
+
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*), INTENT(IN) ::HFILEM ! file name
+
+CHARACTER(LEN=*), INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(OUT)::KNUMBR ! logical unit number
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER::IRESP=0,J,ILOGIQ=0,ILUPRI
+CHARACTER(LEN=JPFINL)::YLOCFN,YLOCFN2
+!
+!* 0.3 Taskcommon for logical units
+!
+COMMON/TASKATTR/ILUPRI
+!DIR$ TASKCOMMON TASKATTR
+!
+!----------------------------------------------------------------------------
+!
+!* 1. INITIALISATION AND TEST THAT FILE DOES NOT ALREADY EXIST
+!
+IRESP = 0 ; ILOGIQ = 0 ; ILUPRI = 6
+YLOCFN=HFILEM ; YLOCFN=ADJUSTL(YLOCFN)
+
+!dino IF (LFMMUL) CALL LOCKON(NFMLOC)
+
+IF (LFCATT) THEN
+ CALL FMINIT
+ LFCATT=.FALSE.
+ELSE
+ IF (NOPEFI.LT.0) THEN
+ IRESP=-50
+ GOTO 1000
+ ELSE
+ DO J=1,JPNXLU
+ IF (YLOCFN.EQ.CNAMFI(J)) THEN
+ IRESP=-51
+ GOTO 1000
+ ENDIF
+ ENDDO
+ ENDIF
+ENDIF
+!
+!* 2. WE LOOK FOR A FREE PLACE IN ARRAY CNAMFI
+!
+! That place will become the number for the logical unit attributed to HFILEM
+!
+
+DO J=1,JPNXLU
+ IF (CNAMFI(J).EQ.CPUDFN) THEN
+ ILOGIQ=J
+ CNAMFI(J)=YLOCFN
+ EXIT
+ ENDIF
+ENDDO
+IF (ILOGIQ.EQ.0) THEN
+ IRESP=-52
+ GOTO 1000
+ENDIF
+
+KNUMBR=ILOGIQ ; NOPEFI=NOPEFI+1
+
+!dino IF (LFMMUL) CALL LOCKOFF(NFMLOC)
+
+!
+!* 3. MESSAGE PRINTING WHATEVER THE ISSUE WAS
+!
+1000 CONTINUE
+
+IF (IRESP.NE.0) THEN
+ YLOCFN2=ADJUSTL(HFIPRI)
+!
+! in the special case where FMATTR is called to reserve a logical unit
+! for the output file itself (i.e. HFILEM=HFIPRI),
+! no print is performed because we do not know
+! whether this file was actually opened or not.
+!
+ IF (YLOCFN2.EQ.YLOCFN) THEN
+ ILUPRI=ILOGIQ
+ ELSE
+ DO J=1,JPNXLU
+ IF (CNAMFI(J).EQ.YLOCFN2) THEN
+ ILUPRI=J
+ EXIT
+ ENDIF
+ ENDDO
+ WRITE (ILUPRI,*) ' exit from FMATTR with IRESP:',IRESP
+ WRITE (ILUPRI,*) ' | HFILEM = ',HFILEM
+ ENDIF
+ENDIF
+KRESP=IRESP
+
+RETURN
+ END SUBROUTINE FMATTR
diff --git a/LIBTOOLS/tools/diachro/src/FM/fmclos.f90 b/LIBTOOLS/tools/diachro/src/FM/fmclos.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d59f23ef7685cdcbf114a77d5b6be256001db878
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM/fmclos.f90
@@ -0,0 +1,223 @@
+! #############################################
+ SUBROUTINE FMCLOS(HFILEM,HSTATU,HFIPRI,KRESP)
+! #############################################
+!
+!!**** *FMCLOS* - routine to close a meso-nh file opened with the "FM"-routines
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMCLOS is to close a mesonh file composed of the DESFM
+! and the LFIFM part. The LFIFM file is closed
+! using the LFI-package for direct access Fortran files. The DESFM file is
+! closed using a classical CLOSE statement.
+!
+!!** METHOD
+!! ------
+!!
+!! The closure is proceeded in 4 steps:
+!! 1. close DESFM
+!! 2. close LFIFM by calling LFIFER
+!! 3. erase the file from the management arrays (FMFREE)
+!! 4. the cpio and storage command is loaded into the pipe
+!! the pipe has the special fortran unit 10
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FMLOOK,FMFREE,LFIFER,CLOSE,FLUSH,LOCKON,LOCKOFF
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! MODULE: MODD_FMDECLAR contains management parameters and
+!! storage arrays to move information around at the
+!! level of all "FM"-routines.
+!! MODD_FMMULTI contains variables for multitasking
+!!
+!! REFERENCE
+!! ---------
+!!
+!! see the Technical Specifications Report for the Meso-nh project
+!! (in French)
+!!
+!! AUTHOR
+!! ------
+!!
+!! C. FISCHER *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/94
+!! modified by C. Fischer 4/11/94 (write in the pipe)
+!! modified by C. Fischer 5/7/95 (locks for multitasking)
+!! modified by P. Jabouille 26/06/96 (case NFITYP=2 :
+!! file is not sent to the remote machine)
+!! modified by V. Masson 16/09/96 (prints if error occurs)
+!!
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+USE MODD_FMMULTI
+
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*), INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*), INTENT(IN) ::HSTATU ! status for the closed file
+
+CHARACTER(LEN=*), INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER::IRESP,IROWF,IPOSNU,J,INUMBR,IFMFNL,ILUPRI,IERR
+CHARACTER(LEN=7)::YSTATU
+CHARACTER(LEN=JPFINL)::YFNDES,YFNLFI
+CHARACTER(LEN=LEN(HFILEM))::YINTFN
+CHARACTER(LEN=10)::YTRANS,YCPIO
+CHARACTER(LEN=100)::YCOMMAND
+LOGICAL::GSTATU
+!
+!* 0.3 Taskcommon for logical units
+!
+COMMON/TASKCLOS/ILUPRI,INUMBR,IRESP,YFNDES,YFNLFI,YSTATU
+!DIR$ TASKCOMMON TASKCLOS
+!
+!----------------------------------------------------------------------------
+!
+!* 1.1 THE NAME OF DESFM=HFILEM.des
+!
+IRESP = 0 ; IROWF = 0 ; IPOSNU = 0 ; ILUPRI = 6 ; IERR = 0
+IFMFNL=JPFINL-4
+YTRANS='transfer.x'
+
+IROWF=LEN(HFILEM)
+
+IF (IROWF.EQ.0) THEN
+ IRESP=-59
+ GOTO 1000
+ELSEIF (IROWF.GT.IFMFNL) THEN
+ IRESP=-60
+ GOTO 1000
+ENDIF
+YINTFN=ADJUSTR(HFILEM)
+YFNDES=YINTFN//'.des'
+YFNDES=ADJUSTL(YFNDES)
+!
+!* 1.2 TEST FOR FILE EXISTENCE AND SEARCH OF ITS LOGICAL UNIT
+!
+CALL FMLOOK(YFNDES,HFIPRI,INUMBR,IRESP)
+IF (IRESP.NE.0) THEN
+ GOTO 1000
+ELSEIF (LEN(HSTATU).LE.0) THEN
+ IRESP=-41
+ GOTO 1000
+ELSE
+ GSTATU=HSTATU.EQ.'KEEP'.OR.HSTATU.EQ.'DELETE'
+ IF (GSTATU) THEN
+ YSTATU=HSTATU(1:MIN0(LEN(HSTATU),LEN(YSTATU)))
+ ELSE
+ YSTATU='DEFAULT'
+ ENDIF
+ENDIF
+!
+!* 1.3 THE LOGICAL UNIT OF DESFM IS RELEASED FOR "FM"
+!
+CALL FMFREE(YFNDES,HFIPRI,IRESP)
+IF (IRESP.NE.0) GOTO 1000
+!
+!* 2. CLOSURE OF DESFM
+!
+! case of a namelist
+!
+CLOSE (UNIT=INUMBR,IOSTAT=IRESP,STATUS=YSTATU)
+IF (IRESP.NE.0) GOTO 1000
+!
+!* 3.1 THE NAME OF LFIFM=HFILEM.lfi
+!
+YFNLFI=YINTFN//'.lfi'
+YFNLFI=ADJUSTL(YFNLFI)
+!
+!* 3.2 TEST FOR FILE EXISTENCE AND SEARCH OF ITS LOGICAL UNIT
+!
+CALL FMLOOK(YFNLFI,HFIPRI,INUMBR,IRESP)
+IF (IRESP.NE.0) GOTO 1000
+!
+!* 3.3 THE LOGICAL UNIT FOR LFIFM IS RELEASED FOR "FM"
+!
+CALL FMFREE(YFNLFI,HFIPRI,IRESP)
+IF (IRESP.NE.0) GOTO 1000
+!
+!* 4. CLOSURE OF LFI
+!
+! case of a LFI file
+!
+CALL LFIFER(IRESP,INUMBR,YSTATU)
+IF (IRESP.NE.0) GOTO 1000
+!
+!* 5. INPUT FOR THE UNIX SYSTEM TO SAVE AND SEND THE FILE
+!
+PRINT*,'KTYPE=',NFITYP(INUMBR)
+SELECT CASE (NFITYP(INUMBR))
+CASE(:-1)
+ IRESP=-66
+ GOTO 1000
+CASE(0)
+ YCPIO='NIL'
+CASE(1)
+ YCPIO='MESONH'
+CASE(2)
+ PRINT*,'FILE ',HFILEM,' NOT TRANSFERED'
+ GOTO 1000
+CASE(3:)
+ IRESP=-66
+ GOTO 1000
+END SELECT
+WRITE (YCOMMAND,20) YTRANS,YCPIO,HFILEM
+!
+! write into the pipe : the "flush" forces instanteneous buffer transfer
+! which is necessary for parallel treatment
+!
+PRINT*,'YCOMMAND=',YCOMMAND
+WRITE (10,'(A100)') YCOMMAND
+!CALL FLUSH(10,IERR)
+!
+!* 6. UPDATING OF ARRAY NFITYP
+!
+IF (LFMMUL) CALL LOCKON(NFMLOC)
+NFITYP(INUMBR)=JPNIIL
+IF (LFMMUL) CALL LOCKOFF(NFMLOC)
+!
+!* 7. MESSAGE PRINTING WHATEVER THE ISSUE WAS
+!
+1000 CONTINUE
+
+IF (IRESP.NE.0) THEN
+YFNLFI=ADJUSTL(HFIPRI)
+DO J=1,JPNXLU
+ IF (CNAMFI(J).EQ.YFNLFI) THEN
+ ILUPRI=J
+ EXIT
+ ENDIF
+ENDDO
+WRITE (ILUPRI,*) ' exit from FMCLOS with IRESP:',IRESP
+WRITE (ILUPRI,*) ' | HFILEM = ',HFILEM
+WRITE (ILUPRI,*) ' | HSTATU = ',HSTATU
+ENDIF
+KRESP=IRESP
+
+! format: 10c for transfer.x and mesonh/nil
+! 32c for file name
+! if you have to change this format one day, don't forget the blank after 1H
+20 FORMAT(A10,1H ,A10,1H ,A32)
+
+RETURN
+ END SUBROUTINE FMCLOS
diff --git a/LIBTOOLS/tools/diachro/src/FM/fmfree.f90 b/LIBTOOLS/tools/diachro/src/FM/fmfree.f90
new file mode 100644
index 0000000000000000000000000000000000000000..03c68b8d2f4a80e6ec23cba2f0643fdb6262770d
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM/fmfree.f90
@@ -0,0 +1,132 @@
+! ######################################
+ SUBROUTINE FMFREE(HFILEM,HFIPRI,KRESP)
+! ######################################
+!
+!!**** *FMFREE* - routine to release a logical unit for FM
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMFREE is to free the logical unit attributed to
+! the file named HFILEM.
+!
+!!** METHOD
+!! ------
+!!
+!! The association between the file named HFILEM and its logical unit
+!! (ILOGIQ, say) was performed by a previous call to FMATTR. This link
+!! is broken by setting the value CNAMFI(ILOGIQ) back to CPUDFN, so that
+!! HFILEM does not appear anymore in CNAMFI.
+!!
+!! EXTERNAL
+!! --------
+!!
+!! LOCKON,LOCKOFF
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! MODULE: MODD_FMDECLAR contains management parameters and
+!! storage arrays to move information around at the
+!! level of all "FM"-routines.
+!! MODD_FMMULTI contains variables for multitasking
+!!
+!! REFERENCE
+!! ---------
+!!
+!! see the Technical Specifications Report for the Meso-nh project
+!! (in French)
+!!
+!! AUTHOR
+!! ------
+!!
+!! C. FISCHER *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/94
+!! modified by C. Fischer 5/7/95 (locks for multitasking)
+!! modified by V. Masson 16/09/96 (prints if error occurs)
+!!
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+USE MODD_FMMULTI
+
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*), INTENT(IN) ::HFILEM ! file name
+
+CHARACTER(LEN=*), INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER::IRESP=0,J,ILOGIQ=0,ILUPRI
+CHARACTER(LEN=JPFINL)::YLOCFN,YLOCFN2
+!
+!* 0.3 Taskcommon for logical units
+!
+COMMON/TASKFREE/ILUPRI
+!DIR$ TASKCOMMON TASKFREE
+!
+!----------------------------------------------------------------------------
+!
+!* 1. THE NAME IS SEARCHED IN CNAMFI AND ERASED
+!
+IRESP = 0 ; ILOGIQ = 0 ; ILUPRI = 6
+YLOCFN=HFILEM ; YLOCFN=ADJUSTL(YLOCFN)
+
+IF (LFMMUL) CALL LOCKON(NFMLOC)
+
+DO J=1,JPNXLU
+ IF (YLOCFN.EQ.CNAMFI(J)) THEN
+ ILOGIQ=J
+ CNAMFI(J)=CPUDFN
+ EXIT
+ ENDIF
+ENDDO
+IF (ILOGIQ.EQ.0) THEN
+ IRESP=-42
+ GOTO 1000
+ENDIF
+
+NOPEFI=NOPEFI-1
+
+IF (LFMMUL) CALL LOCKOFF(NFMLOC)
+
+!
+!* 2. MESSAGE PRINTING WHATEVER THE ISSUE WAS
+!
+1000 CONTINUE
+
+IF (IRESP.NE.0) THEN
+ YLOCFN2=ADJUSTL(HFIPRI)
+ IF (YLOCFN2.EQ.YLOCFN) THEN
+! special case where HFILEM is the output listing itself: no print in this case
+! because we do not know whether this file has already been closed or not
+ ILUPRI=ILOGIQ
+ ELSE
+! most common case is this one
+ DO J=1,JPNXLU
+ IF (CNAMFI(J).EQ.YLOCFN2) THEN
+ ILUPRI=J
+ EXIT
+ ENDIF
+ ENDDO
+ WRITE (ILUPRI,*) ' exit from FMFREE with IRESP:',IRESP
+ WRITE (ILUPRI,*) ' | HFILEM = ',HFILEM
+ ENDIF
+ENDIF
+KRESP=IRESP
+
+RETURN
+ END SUBROUTINE FMFREE
diff --git a/LIBTOOLS/tools/diachro/src/FM/fminit.f90 b/LIBTOOLS/tools/diachro/src/FM/fminit.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ec64adb3858ed7d82b832c54745118a1812d50e8
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM/fminit.f90
@@ -0,0 +1,72 @@
+! ######spl
+ SUBROUTINE FMINIT
+! #################
+!
+!!**** *FMINIT* - routine to initialize the management arrays used by the FM-routines
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMINIT is to initialize the management arrays used
+! by the other FM-routines. These arrays allow to associate each logical
+! unit number with the given file name.
+! FMINIT is only called when FMATTR is called for the very
+! first time.
+! Furthermore, FMINIT opens unit 10 which is dedicated to the pipe
+! in which the transfer orders are written (in FMCLOS). Thus, unit 10
+! is specific and unavailable for common file management.
+!
+!!** METHOD
+!! ------
+!!
+!! Array intrinsics of fortran 90 are used
+!!
+!! EXTERNAL
+!! --------
+!!
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! MODULE: MODD_FMDECLAR contains management parameters and
+!! storage arrays to move information around at the
+!! level of all "FM"-routines.
+!!
+!! REFERENCE
+!! ---------
+!!
+!! see the Technical Specifications Report for the Meso-nh project
+!! (in French)
+!!
+!! AUTHOR
+!! ------
+!!
+!! C. FISCHER *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/94
+!! modified by C. Fischer 22/11/94 (open unit 10)
+!!
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+
+IMPLICIT NONE
+!----------------------------------------------------------------------------
+
+NOPEFI=0
+
+NFITYP=JPNIIL
+
+CNAMFI=CPUDFN ; CNAMFI(1:10)=CPUNLU
+
+!OPEN(UNIT=10,FILE='pipe_name',FORM='FORMATTED')
+
+RETURN
+ END SUBROUTINE FMINIT
diff --git a/LIBTOOLS/tools/diachro/src/FM/fmlook.f90 b/LIBTOOLS/tools/diachro/src/FM/fmlook.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2a8a17bc9689724e608d08ed141bef2a9b337f68
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM/fmlook.f90
@@ -0,0 +1,120 @@
+! ######spl
+ SUBROUTINE FMLOOK(HFILEM,HFIPRI,KNUMBR,KRESP)
+! #############################################
+!
+!!**** *FMLOOK* - routine to look for the logical unit attributed to a file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMLOOK is to look for the logical unit (Fortran)
+! that is associated to the file named HFILEM. This unit was attributed
+! previously to HFILEM by FMATTR.
+!
+!!** METHOD
+!! ------
+!!
+!! The string HFILEM is searched in array CNAMFI which contains the
+!! names of all files that have been opened for the FM-routines.
+!! The place in array CNAMFI of HFILEM corresponds exactly to
+!! its logical unit.
+!!
+!! EXTERNAL
+!! --------
+!!
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! MODULE: MODD_FMDECLAR contains management parameters and
+!! storage arrays to move information around at the
+!! level of all "FM"-routines.
+!!
+!! REFERENCE
+!! ---------
+!!
+!! see the Technical Specifications Report for the Meso-nh project
+!! (in French)
+!!
+!! AUTHOR
+!! ------
+!!
+!! C. FISCHER *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 04/94
+!!
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*), INTENT(IN) ::HFILEM ! file name
+
+CHARACTER(LEN=*), INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(OUT)::KNUMBR ! logical unit number
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER::J,ILOGIQ=0,IRESP=0,ILUPRI
+CHARACTER(LEN=JPFINL)::YLOCFN
+!
+!* 0.3 Taskcommon for logical units
+!
+COMMON/TASKLOOK/ILUPRI
+!DIR$ TASKCOMMON TASKLOOK
+!
+!----------------------------------------------------------------------------
+!
+!* 1. WE LOOK FOR THE FILE NAME IN ARRAY CNAMFI
+!
+ILOGIQ = 0 ; IRESP = 0 ; ILUPRI = 6
+IF (NOPEFI.LT.1) THEN
+ IRESP=-53
+ GOTO 1000
+ENDIF
+YLOCFN=HFILEM ; YLOCFN=ADJUSTL(YLOCFN)
+DO J=1,JPNXLU
+ IF (YLOCFN.EQ.CNAMFI(J)) THEN
+ ILOGIQ=J
+ EXIT
+ ENDIF
+ENDDO
+IF (ILOGIQ.EQ.0) THEN
+ IRESP=-54
+ GOTO 1000
+ENDIF
+
+KNUMBR=ILOGIQ
+!
+!* 2. MESSAGE PRINTING WHATEVER THE ISSUE WAS
+!
+1000 CONTINUE
+
+IF (IRESP.NE.0) THEN
+YLOCFN=ADJUSTL(HFIPRI)
+DO J=1,JPNXLU
+ IF (CNAMFI(J).EQ.YLOCFN) THEN
+ ILUPRI=J
+ EXIT
+ ENDIF
+ENDDO
+WRITE (ILUPRI,*) ' exit from FMLOOK with IRESP:',IRESP
+WRITE (ILUPRI,*) ' | HFILEM = ',HFILEM
+ENDIF
+KRESP=IRESP
+
+RETURN
+ END SUBROUTINE FMLOOK
diff --git a/LIBTOOLS/tools/diachro/src/FM/fmopen.f90 b/LIBTOOLS/tools/diachro/src/FM/fmopen.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0e05895d5ebd35a61c0eb50e1dcfb4c3d75d5418
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM/fmopen.f90
@@ -0,0 +1,218 @@
+! ######spl
+ SUBROUTINE FMOPEN(HFILEM,HSTATU,HFIPRI,KNPRAR,KFTYPE,KVERB,&
+ KNINAR,KRESP)
+! ############################################################
+!
+!!**** *FMOPEN* - routine to open a meso-nh file (DESFM+LFIFM)
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMOPEN is to open a meso-nh file for the "FM"-routines.
+! It is composed of two distinct fortran files: DESFM and LFIFM. DESFM is
+! a namelist formatted file. LFIFM is a LFI file, managed by the LFI-package.
+! LFIFM is a fortran unformatted, direct access file which is
+! manipulated by the FM-routines FMREAD and FMWRIT.
+! The namelist file is a fortran 90 standard formatted file.
+!
+!!** METHOD
+!! ------
+!!
+!! The opening is performed in 4 main steps:
+!! 1. a logical unit is reserved for DESFM (first call to FMATTR)
+!! 2. the DESFM file is created by a
+!! formatted, fortran open. The name of the file is obtained by
+!! appending ".des" to HFILEM.
+!! 3. a logical unit is reserved for LFIFM (second call to FMATTR)
+!! 4. the LFIFM file is opened in the LFIOUV routine to
+!! which most of the explicit input arguments of FMOPEN are passed.
+!! The name of that file is obtained by appending ".lfi"
+!! to HFILEM.
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FMATTR,LFIOUV,OPEN,LOCKON,LOCKOFF
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! MODULE: MODD_FMDECLAR contains management parameters and
+!! storage arrays to move information around at the
+!! level of all "FM"-routines.
+!! MODD_FMMULTI contains variables for multitasking
+!!
+!! REFERENCE
+!! ---------
+!!
+!! see the Technical Specifications Report for the Meso-nh project
+!! (in French)
+!!
+!! AUTHOR
+!! ------
+!!
+!! C. FISCHER *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/94
+!! modified by C. Fischer 5/7/95 (locks for multitasking)
+!! modified by V. Masson 16/09/96 (prints if error occurs)
+!!
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+USE MODD_FMMULTI
+
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*), INTENT(IN) ::HFILEM ! name of the file
+CHARACTER(LEN=*), INTENT(IN) ::HSTATU ! status of the file at opening
+CHARACTER(LEN=*), INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KNPRAR ! number of predicted articles (not vital)
+INTEGER, INTENT(IN) ::KFTYPE ! type of FM-file
+INTEGER, INTENT(IN) ::KVERB ! level of verbose
+
+INTEGER, INTENT(OUT)::KNINAR ! number of articles initially present in the file
+INTEGER, INTENT(OUT)::KRESP ! return-code if a problem araised
+
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER::IRESOU,INPRAR,IROWF,IRESP,J,INUMBR,IFMFNL,IMELEV,ILUPRI
+CHARACTER(LEN=JPFINL)::YFNDES,YFNLFI
+CHARACTER(LEN=LEN(HFILEM))::YINTFN
+LOGICAL::GNEWFI,GNAMFI=.TRUE.,GFATER=.TRUE.,GSTATS
+!
+!* 0.3 Taskcommon for logical units
+!
+COMMON/TASKOPEN/ILUPRI,INUMBR,IRESP,YFNDES,YFNLFI
+!DIR$ TASKCOMMON TASKOPEN
+!
+!----------------------------------------------------------------------------
+!
+!* 1. INITIALIZATION
+!
+INPRAR=KNPRAR+0;KNINAR=0
+IRESOU = 0 ; IROWF = 0 ; IRESP = 0 ; ILUPRI = 6
+!
+!* the model's verbose level is connected to the LFI verbose
+!
+SELECT CASE (KVERB)
+CASE(:2)
+ GSTATS=.FALSE. ; IMELEV=0
+CASE(3:6)
+ GSTATS=.FALSE. ; IMELEV=1
+CASE(7:9)
+ GSTATS=.FALSE. ; IMELEV=2
+CASE(10:)
+ GSTATS=.TRUE. ; IMELEV=2
+END SELECT
+
+IF (NOPEFI.GE.JPNXFM) THEN
+ IRESP=-44
+ GOTO 1000
+ENDIF
+!
+!* 2. LOGICAL UNIT FOR DESFM
+!
+! the fortran name for DESFM
+!
+IFMFNL=JPFINL-4
+
+IROWF=LEN(HFILEM)
+
+IF (IROWF.EQ.0) THEN
+ IRESP=-45
+ GOTO 1000
+ELSEIF (IROWF.GT.IFMFNL) THEN
+ IRESP=-49
+ GOTO 1000
+ENDIF
+YINTFN=ADJUSTR(HFILEM)
+YFNDES=YINTFN//'.des'
+YFNDES=ADJUSTL(YFNDES)
+
+CALL FMATTR(YFNDES,HFIPRI,INUMBR,IRESP)
+IF (IRESP.NE.0) GOTO 1000
+
+!
+!* 3. FILE OPENING FOR DESFM
+!
+! case of a namelist: sequential, formatted fortran open
+!
+OPEN(UNIT=INUMBR,FILE=YFNDES,FORM='FORMATTED',DELIM='QUOTE',IOSTAT=IRESP)
+IF (IRESP.NE.0) GOTO 1000
+!
+!* 4. LOGICAL UNIT FOR LFIFM
+!
+! the fortran name for LFIFM
+!
+YFNLFI=YINTFN//'.lfi'
+YFNLFI=ADJUSTL(YFNLFI)
+
+CALL FMATTR(YFNLFI,HFIPRI,INUMBR,IRESP)
+IF (IRESP.NE.0) GOTO 1000
+!
+!* 5. FILE OPENING FOR LFIFM
+!
+! case of a LFI-file: direct access, unformatted open via LFIOUV
+!
+CALL LFIOUV(IRESOU,INUMBR,GNAMFI,YFNLFI,HSTATU,GFATER,GSTATS,IMELEV,INPRAR,&
+ KNINAR)
+IF (IRESOU.NE.0.AND.IRESOU.NE.-11) THEN
+ IRESP=IRESOU
+ GOTO 1000
+ENDIF
+
+!
+!* 6. TEST IF FILE IS NEWLY DEFINED
+!
+
+GNEWFI=(KNINAR.EQ.0).OR.(KVERB.LT.7)
+IF (.NOT.GNEWFI) THEN
+YFNLFI=ADJUSTL(HFIPRI)
+DO J=1,JPNXLU
+ IF (CNAMFI(J).EQ.YFNLFI) THEN
+ ILUPRI=J
+ EXIT
+ ENDIF
+ENDDO
+WRITE (ILUPRI,*) ' file ',INUMBR,'previously created with LFI'
+ENDIF
+!
+!* 7. UPDATE OF THE FILE TYPE ARRAY
+!
+!dino IF (LFMMUL) CALL LOCKON(NFMLOC)
+NFITYP(INUMBR)=KFTYPE
+!dino IF (LFMMUL) CALL LOCKOFF(NFMLOC)
+!
+!* 8. MESSAGE PRINTING WHATEVER THE ISSUE WAS
+!
+1000 CONTINUE
+
+IF (IRESP.NE.0) THEN
+YFNLFI=ADJUSTL(HFIPRI)
+DO J=1,JPNXLU
+ IF (CNAMFI(J).EQ.YFNLFI) THEN
+ ILUPRI=J
+ EXIT
+ ENDIF
+ENDDO
+WRITE (ILUPRI,*) ' exit from FMOPEN with IRESP:',IRESP
+WRITE (ILUPRI,*) ' | HFILEM = ',HFILEM
+WRITE (ILUPRI,*) ' | HSTATU = ',HSTATU
+WRITE (ILUPRI,*) ' | KNPRAR = ',KNPRAR
+WRITE (ILUPRI,*) ' | KFTYPE = ',KFTYPE
+ENDIF
+KRESP=IRESP
+
+RETURN
+ END SUBROUTINE FMOPEN
diff --git a/LIBTOOLS/tools/diachro/src/FM/fmread.f90 b/LIBTOOLS/tools/diachro/src/FM/fmread.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5ff148d8809b7c385f8e544897f848cca7214a25
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM/fmread.f90
@@ -0,0 +1,1428 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/mesonh/sources/dataio/fmf90_cray/s.fmread.f90, Version:1.2.1.2, Date:98/09/16, Last modified:98/06/04
+!-----------------------------------------------------------------
+!##################
+MODULE MODI_FMREAD
+!##################
+!
+INTERFACE FMREAD
+ SUBROUTINE FMREADX0(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADX0
+!
+ SUBROUTINE FMREADX1(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:), &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADX1
+!
+!
+ SUBROUTINE FMREADX2(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:), &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADX2
+!
+!
+ SUBROUTINE FMREADX3(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:), &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADX3
+!
+!
+ SUBROUTINE FMREADX4(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:,:), &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADX4
+!
+!
+ SUBROUTINE FMREADX5(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:,:,:), &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADX5
+!
+!
+ SUBROUTINE FMREADX6(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:,:,:,:), &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADX6
+!
+ SUBROUTINE FMREADN0(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER, &
+ INTENT(OUT)::KFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADN0
+!
+ SUBROUTINE FMREADN1(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER, DIMENSION(:), &
+ INTENT(OUT)::KFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADN1
+!
+ SUBROUTINE FMREADN2(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER, DIMENSION(:,:), &
+ INTENT(OUT)::KFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADN2
+!
+ SUBROUTINE FMREADL0(HFILEM,HRECFM,HFIPRI,KLENG,OFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+LOGICAL, &
+ INTENT(OUT)::OFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADL0
+!
+ SUBROUTINE FMREADL1(HFILEM,HRECFM,HFIPRI,KLENG,OFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+LOGICAL, DIMENSION(:), &
+ INTENT(OUT)::OFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADL1
+!
+ SUBROUTINE FMREADC0(HFILEM,HRECFM,HFIPRI,KLENG,HFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+CHARACTER(LEN=*), &
+ INTENT(OUT)::HFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADC0
+!
+ SUBROUTINE FMREADT0(HFILEM,HRECFM,HFIPRI,KLENG,TFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+USE MODD_TYPE_DATE
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+TYPE (DATE_TIME), &
+ INTENT(OUT)::TFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMREADT0
+!
+END INTERFACE
+!
+END MODULE MODI_FMREAD
+! #############################################################
+ SUBROUTINE FMREADX0(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADX0* - routine to read a real scalar into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADX0 is to convert the real into integer(kind=8)
+! by calling FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*), INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+REAL(KIND=8) :: ZFIELD
+!
+!-------------------------------------------------------------------------------
+CALL FM_READ(HFILEM,HRECFM,HFIPRI,1,ZFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+IF(KRESP==0) PFIELD = ZFIELD
+IF(KRESP==0) HCOMMENT=YCOMMENT
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADX0
+! #############################################################
+ SUBROUTINE FMREADX1(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADX1* - routine to read a real 1D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADX0 is to convert the real into integer(kind=8)
+! by calling FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:), &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+INTEGER :: ILENG
+REAL(KIND=8),DIMENSION(SIZE(PFIELD)) :: ZFIELD
+!-------------------------------------------------------------------------------
+!
+ILENG=SIZE(PFIELD)
+CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+IF(KRESP==0) PFIELD = ZFIELD
+IF(KRESP==0) HCOMMENT = YCOMMENT
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADX1
+! #############################################################
+ SUBROUTINE FMREADX2(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADX2* - routine to read a real 2D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADX0 is to convert the real into integer(kind=8)
+! by calling FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!! Modification 15/10/97 (V.Masson) 1D and 2D cases
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+USE MODD_CONF
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:), &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+INTEGER :: ILENG
+REAL(KIND=8),DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2)) :: ZFIELD
+!-------------------------------------------------------------------------------
+IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==3 .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/9
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(2,2),KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) PFIELD(:,:)=SPREAD(SPREAD(ZFIELD(2,2),DIM=1,NCOPIES=3),DIM=2,NCOPIES=3)
+ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/3
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(:,2),KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) PFIELD(:,:)=SPREAD(ZFIELD(:,2),DIM=2,NCOPIES=3)
+ELSE
+ ILENG=SIZE(PFIELD)
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) PFIELD = ZFIELD
+END IF
+IF(KRESP==0) HCOMMENT = YCOMMENT
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADX2
+! #############################################################
+ SUBROUTINE FMREADX3(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADX1* - routine to read a real 3D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADX0 is to convert the real into integer(kind=8)
+! by calling FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!! Modification 15/10/97 (V.Masson) 1D and 2D cases
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+USE MODD_CONF
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:), &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+INTEGER :: ILENG
+REAL(KIND=8),DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3)) :: ZFIELD
+!-------------------------------------------------------------------------------
+IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==3 .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/9
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(2,2,:),KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) PFIELD(:,:,:)=SPREAD(SPREAD(ZFIELD(2,2,:),DIM=1,NCOPIES=3),DIM=2,NCOPIES=3)
+ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/3
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(:,2,:),KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) PFIELD(:,:,:)=SPREAD(ZFIELD(:,2,:),DIM=2,NCOPIES=3)
+ELSE
+ ILENG=SIZE(PFIELD)
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) PFIELD = ZFIELD
+END IF
+IF(KRESP==0) HCOMMENT = YCOMMENT
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADX3
+! #############################################################
+ SUBROUTINE FMREADX4(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADX4* - routine to read a real 4D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADX0 is to convert the real into integer(kind=8)
+! by calling FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!! Modification 15/10/97 (V.Masson) 1D and 2D cases
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+USE MODD_CONF
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:,:), &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: ILENG
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+REAL(KIND=8),DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2), &
+ SIZE(PFIELD,3),SIZE(PFIELD,4)) :: ZFIELD
+!-------------------------------------------------------------------------------
+IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==3 .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/9
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(2,2,:,:),KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) PFIELD(:,:,:,:)=SPREAD(SPREAD(ZFIELD(2,2,:,:),DIM=1,NCOPIES=3),DIM=2,NCOPIES=3)
+ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/3
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(:,2,:,:),KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) PFIELD(:,:,:,:)=SPREAD(ZFIELD(:,2,:,:),DIM=2,NCOPIES=3)
+ELSE
+ ILENG=SIZE(PFIELD)
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) PFIELD = ZFIELD
+END IF
+IF(KRESP==0) HCOMMENT = YCOMMENT
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADX4
+! #############################################################
+ SUBROUTINE FMREADX5(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADX5* - routine to read a real 5D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADX0 is to convert the real into integer(kind=8)
+! by calling FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!! Modification 15/10/97 (V.Masson) 1D and 2D cases
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+USE MODD_CONF
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:,:,:), &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: ILENG
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+REAL(KIND=8),DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2), &
+ SIZE(PFIELD,3),SIZE(PFIELD,4),SIZE(PFIELD,5)) :: ZFIELD
+!-------------------------------------------------------------------------------
+IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==3 .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/9
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(2,2,:,:,:),KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) PFIELD(:,:,:,:,:)=SPREAD(SPREAD(ZFIELD(2,2,:,:,:),DIM=1,NCOPIES=3),DIM=2,NCOPIES=3)
+ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/3
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(:,2,:,:,:),KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) PFIELD(:,:,:,:,:)=SPREAD(ZFIELD(:,2,:,:,:),DIM=2,NCOPIES=3)
+ELSE
+ ILENG=SIZE(PFIELD)
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) PFIELD = ZFIELD
+END IF
+IF(KRESP==0) HCOMMENT = YCOMMENT
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADX5
+! #############################################################
+ SUBROUTINE FMREADX6(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADX6* - routine to read a real 6D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADX0 is to convert the real into integer(kind=8)
+! by calling FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:,:,:,:), &
+ INTENT(OUT)::PFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: ILENG
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+REAL(KIND=8),DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2), &
+ SIZE(PFIELD,3),SIZE(PFIELD,4),SIZE(PFIELD,5),SIZE(PFIELD,6)) :: ZFIELD
+!-------------------------------------------------------------------------------
+ILENG=SIZE(PFIELD)
+CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+IF(KRESP==0) PFIELD = ZFIELD
+IF(KRESP==0) HCOMMENT = YCOMMENT
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADX6
+! #############################################################
+ SUBROUTINE FMREADN0(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADN0* - routine to read a integer scalar into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADN0 is to convert the integer into integer(kind=8)
+! by calling FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER, &
+ INTENT(OUT)::KFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+INTEGER(KIND=8) :: IFIELD
+!-------------------------------------------------------------------------------
+CALL FM_READ(HFILEM,HRECFM,HFIPRI,1,IFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+IF(KRESP==0) KFIELD = IFIELD
+IF(KRESP==0) HCOMMENT = YCOMMENT
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADN0
+! #############################################################
+ SUBROUTINE FMREADN1(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADN1* - routine to read a integer 1D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADN1 is to convert the integer into integer(kind=8)
+! by calling FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER, DIMENSION(:), &
+ INTENT(OUT)::KFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+INTEGER(KIND=8), DIMENSION(SIZE(KFIELD)) :: IFIELD
+INTEGER :: ILENG
+!-------------------------------------------------------------------------------
+ILENG=SIZE(KFIELD)
+CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,IFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+IF(KRESP==0) KFIELD(:)=IFIELD(:)
+IF(KRESP==0) HCOMMENT = YCOMMENT
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADN1
+! #############################################################
+ SUBROUTINE FMREADN2(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADN2* - routine to read a integer 2D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADN1 is to convert the integer into integer(kind=8)
+! by calling FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!! Modification 15/10/97 (V.Masson) 1D and 2D cases
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+USE MODD_CONF
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER, DIMENSION(:,:), &
+ INTENT(OUT)::KFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+INTEGER(KIND=8), DIMENSION(SIZE(KFIELD,1),SIZE(KFIELD,2)) :: IFIELD
+INTEGER :: ILENG
+!-------------------------------------------------------------------------------
+IF (LPACK .AND. L1D .AND. SIZE(KFIELD,1)==3 .AND. SIZE(KFIELD,2)==3) THEN
+ ILENG=SIZE(KFIELD)/9
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,IFIELD(2,2),KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) KFIELD(:,:)=SPREAD(SPREAD(IFIELD(2,2),DIM=1,NCOPIES=3),DIM=2,NCOPIES=3)
+ELSE IF (LPACK .AND. L2D .AND. SIZE(KFIELD,2)==3) THEN
+ ILENG=SIZE(KFIELD)/3
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,IFIELD(:,2),KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) KFIELD(:,:)=SPREAD(IFIELD(:,2),DIM=2,NCOPIES=3)
+ELSE
+ ILENG=SIZE(KFIELD)
+ CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,IFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+ IF(KRESP==0) KFIELD(:,:)=IFIELD(:,:)
+END IF
+IF(KRESP==0) HCOMMENT = YCOMMENT
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADN2
+! #############################################################
+ SUBROUTINE FMREADL0(HFILEM,HRECFM,HFIPRI,KLENG,OFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADL0* - routine to read a logical scalar into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADN0 is to convert the integer into integer(kind=8)
+! by calling FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+LOGICAL, &
+ INTENT(OUT)::OFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+INTEGER(KIND=8) :: IFIELD
+!-------------------------------------------------------------------------------
+!
+CALL FM_READ(HFILEM,HRECFM,HFIPRI,1,IFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+!
+IF(KRESP==0) THEN
+ IF (IFIELD==1) THEN
+ OFIELD=.TRUE.
+ ELSE
+ OFIELD=.FALSE.
+ END IF
+ HCOMMENT = YCOMMENT
+END IF
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADL0
+! #############################################################
+ SUBROUTINE FMREADL1(HFILEM,HRECFM,HFIPRI,KLENG,OFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADL1* - routine to read a logical array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADN0 is to convert the integer into integer(kind=8)
+! by calling FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+LOGICAL, DIMENSION(:), &
+ INTENT(OUT)::OFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+INTEGER(KIND=8), DIMENSION(SIZE(OFIELD)) :: IFIELD
+!-------------------------------------------------------------------------------
+!
+CALL FM_READ(HFILEM,HRECFM,HFIPRI,SIZE(IFIELD),IFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+!
+IF(KRESP==0) THEN
+ WHERE (IFIELD==1)
+ OFIELD=.TRUE.
+ ELSEWHERE
+ OFIELD=.FALSE.
+ END WHERE
+ HCOMMENT = YCOMMENT
+END IF
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADL1
+! #############################################################
+ SUBROUTINE FMREADC0(HFILEM,HRECFM,HFIPRI,KLENG,HFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADL1* - routine to read a logical scalar into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADL0 is to convert the string into arrayr of
+! integer(kind=8) and to call FM_READ without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+CHARACTER(LEN=*), &
+ INTENT(OUT)::HFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: JLOOP
+CHARACTER(LEN=JPXKRK) ::YCOMMENT
+INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: IFIELD
+INTEGER :: ILENG
+!-------------------------------------------------------------------------------
+!
+ILENG=LEN(HFIELD)
+ALLOCATE(IFIELD(ILENG))
+!
+CALL FM_READ(HFILEM,HRECFM,HFIPRI,ILENG,IFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+!
+IF(KRESP==0) THEN
+ DO JLOOP=1,ILENG
+ HFIELD(JLOOP:JLOOP)=ACHAR(IFIELD(JLOOP))
+ END DO
+ HCOMMENT = YCOMMENT
+END IF
+!
+DEALLOCATE(IFIELD)
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADC0
+! #############################################################
+ SUBROUTINE FMREADT0(HFILEM,HRECFM,HFIPRI,KLENG,TFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMREADT0* - routine to read a date_time scalar into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMREADT0 is to call FM_READ without interface module
+! and to retrieve the date_time information
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_READ
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 18/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+USE MODD_TYPE_DATE
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+TYPE (DATE_TIME), &
+ INTENT(OUT)::TFIELD ! array containing the data field
+INTEGER, INTENT(OUT)::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(OUT)::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(OUT)::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+CHARACTER(LEN=16) :: YRECFM ! Name of the article to be read
+CHARACTER(LEN=JPXKRK) :: YCOMMENT
+INTEGER(KIND=8), DIMENSION(3) :: ITDATE
+REAL(KIND=8) :: ZFIELD
+!-------------------------------------------------------------------------------
+!
+YRECFM=TRIM(HRECFM)//'%TDATE'
+CALL FM_READ(HFILEM,YRECFM,HFIPRI,3,ITDATE,KGRID,KLENCH,YCOMMENT,KRESP)
+TFIELD%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+HCOMMENT = YCOMMENT
+!
+YRECFM=TRIM(HRECFM)//'%TIME'
+CALL FM_READ(HFILEM,YRECFM,HFIPRI,1,ZFIELD,KGRID,KLENCH,YCOMMENT,KRESP)
+TFIELD%TIME=ZFIELD
+HCOMMENT = YCOMMENT
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMREADT0
diff --git a/LIBTOOLS/tools/diachro/src/FM/fmwrit.f90 b/LIBTOOLS/tools/diachro/src/FM/fmwrit.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ef51417168bc1f58d13eaf3f5c4eb88585ca6926
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM/fmwrit.f90
@@ -0,0 +1,1390 @@
+!##################
+MODULE MODI_FMWRIT
+!##################
+!
+INTERFACE FMWRIT
+ SUBROUTINE FMWRITX0(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITX0
+!
+ SUBROUTINE FMWRITX1(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:), &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITX1
+!
+!
+ SUBROUTINE FMWRITX2(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:), &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITX2
+!
+!
+ SUBROUTINE FMWRITX3(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:), &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITX3
+!
+!
+ SUBROUTINE FMWRITX4(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:,:), &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITX4
+!
+!
+ SUBROUTINE FMWRITX5(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:,:,:), &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITX5
+!
+!
+ SUBROUTINE FMWRITX6(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:,:,:,:), &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITX6
+!
+ SUBROUTINE FMWRITN0(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER, &
+ INTENT(IN) ::KFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITN0
+!
+ SUBROUTINE FMWRITN1(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER, DIMENSION(:), &
+ INTENT(IN) ::KFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITN1
+!
+ SUBROUTINE FMWRITN2(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER, DIMENSION(:,:), &
+ INTENT(IN) ::KFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITN2
+!
+ SUBROUTINE FMWRITL0(HFILEM,HRECFM,HFIPRI,KLENG,OFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+LOGICAL, &
+ INTENT(IN) ::OFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITL0
+!
+ SUBROUTINE FMWRITL1(HFILEM,HRECFM,HFIPRI,KLENG,OFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+LOGICAL,DIMENSION(:), &
+ INTENT(IN) ::OFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITL1
+!
+ SUBROUTINE FMWRITC0(HFILEM,HRECFM,HFIPRI,KLENG,HFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+CHARACTER(LEN=*), &
+ INTENT(IN) ::HFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITC0
+!
+ SUBROUTINE FMWRITT0(HFILEM,HRECFM,HFIPRI,KLENG,TFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+USE MODD_TYPE_DATE
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+TYPE (DATE_TIME), &
+ INTENT(IN) ::TFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+END SUBROUTINE FMWRITT0
+!
+END INTERFACE
+!
+END MODULE MODI_FMWRIT
+! #############################################################
+ SUBROUTINE FMWRITX0(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITX0* - routine to write a real scalar into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITX0 is to convert the real into integer(kind=8)
+! by calling FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+!
+CHARACTER(LEN=*), INTENT(IN) ::HCOMMENT ! comment string
+!
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+REAL(KIND=8) :: ZFIELD
+!
+!-------------------------------------------------------------------------------
+ZFIELD=PFIELD
+CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,1,ZFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITX0
+!
+! #############################################################
+ SUBROUTINE FMWRITX1(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITX1* - routine to write a real 1D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITX0 is to convert the real into integer(kind=8)
+! by calling FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:), &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: ILENG
+REAL(KIND=8), DIMENSION(SIZE(PFIELD)) :: ZFIELD
+!-------------------------------------------------------------------------------
+!
+ILENG=SIZE(PFIELD)
+ZFIELD=PFIELD
+CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITX1
+!
+! #############################################################
+ SUBROUTINE FMWRITX2(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITX2* - routine to write a real 2D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITX0 is to convert the real into integer(kind=8)
+! by calling FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!! Modification 15/10/97 (V.Masson) 1D and 2D cases
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:), &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: ILENG
+REAL(KIND=8), DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2)) :: ZFIELD
+!-------------------------------------------------------------------------------
+!
+ZFIELD=PFIELD
+IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==3 .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/9
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(2:2,2:2),KGRID,KLENCH,HCOMMENT,KRESP)
+ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/3
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(:,2),KGRID,KLENCH,HCOMMENT,KRESP)
+ELSE
+ ILENG=SIZE(PFIELD)
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+END IF
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITX2
+!
+! #############################################################
+ SUBROUTINE FMWRITX3(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITX1* - routine to write a real 3D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITX0 is to convert the real into integer(kind=8)
+! by calling FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!! Modification 15/10/97 (V.Masson) 1D and 2D cases
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:), &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: ILENG
+REAL(KIND=8), DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3)) :: ZFIELD
+!-------------------------------------------------------------------------------
+!
+ZFIELD=PFIELD
+IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==3 .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/9
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(2,2,:),KGRID,KLENCH,HCOMMENT,KRESP)
+ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/3
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(:,2,:),KGRID,KLENCH,HCOMMENT,KRESP)
+ELSE
+ ILENG=SIZE(PFIELD)
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+END IF
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITX3
+!
+! #############################################################
+ SUBROUTINE FMWRITX4(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITX4* - routine to write a real 4D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITX0 is to convert the real into integer(kind=8)
+! by calling FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!! Modification 15/10/97 (V.Masson) 1D and 2D cases
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:,:), &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: ILENG
+REAL(KIND=8), &
+DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3),SIZE(PFIELD,4)) :: ZFIELD
+!-------------------------------------------------------------------------------
+!
+ZFIELD=PFIELD
+IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==3 .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/9
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(2,2,:,:),KGRID,KLENCH,HCOMMENT,KRESP)
+ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/3
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(:,2,:,:),KGRID,KLENCH,HCOMMENT,KRESP)
+ELSE
+ ILENG=SIZE(PFIELD)
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+END IF
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITX4
+!
+! #############################################################
+ SUBROUTINE FMWRITX5(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITX5* - routine to write a real 5D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITX0 is to convert the real into integer(kind=8)
+! by calling FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!! Modification 15/10/97 (V.Masson) 1D and 2D cases
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:,:,:), &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: ILENG
+REAL(KIND=8), &
+DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3),SIZE(PFIELD,4),SIZE(PFIELD,5)) :: ZFIELD
+!-------------------------------------------------------------------------------
+!
+ZFIELD=PFIELD
+IF (LPACK .AND. L1D .AND. SIZE(PFIELD,1)==3 .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/9
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(2,2,:,:,:),KGRID,KLENCH,HCOMMENT,KRESP)
+ELSE IF (LPACK .AND. L2D .AND. SIZE(PFIELD,2)==3) THEN
+ ILENG=SIZE(PFIELD)/3
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD(:,2,:,:,:),KGRID,KLENCH,HCOMMENT,KRESP)
+ELSE
+ ILENG=SIZE(PFIELD)
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+END IF
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITX5
+!
+! #############################################################
+ SUBROUTINE FMWRITX6(HFILEM,HRECFM,HFIPRI,KLENG,PFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITX6* - routine to write a real 6D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITX0 is to convert the real into integer(kind=8)
+! by calling FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+REAL, DIMENSION(:,:,:,:,:,:), &
+ INTENT(IN) ::PFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: ILENG
+REAL(KIND=8), &
+DIMENSION(SIZE(PFIELD,1),SIZE(PFIELD,2),SIZE(PFIELD,3),SIZE(PFIELD,4),SIZE(PFIELD,5),SIZE(PFIELD,6)) :: ZFIELD
+!-------------------------------------------------------------------------------
+!
+ZFIELD=PFIELD
+ILENG=SIZE(PFIELD)
+CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,ZFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITX6
+!
+! #############################################################
+ SUBROUTINE FMWRITN0(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITN0* - routine to write a integer scalar into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITN0 is to convert the integer into integer(kind=8)
+! by calling FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER, &
+ INTENT(IN) ::KFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER(KIND=8) :: IFIELD
+!-------------------------------------------------------------------------------
+IFIELD=KFIELD
+CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,1,IFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITN0
+!
+! #############################################################
+ SUBROUTINE FMWRITN1(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITN1* - routine to write a integer 1D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITN1 is to convert the integer into integer(kind=8)
+! by calling FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER, DIMENSION(:), &
+ INTENT(IN) ::KFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER(KIND=8), DIMENSION(SIZE(KFIELD)) :: IFIELD
+INTEGER :: ILENG
+!-------------------------------------------------------------------------------
+!
+ILENG=SIZE(KFIELD)
+IFIELD(:)=KFIELD(:)
+CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,IFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITN1
+!
+! #############################################################
+ SUBROUTINE FMWRITN2(HFILEM,HRECFM,HFIPRI,KLENG,KFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITN2* - routine to write a integer 2D array into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITN1 is to convert the integer into integer(kind=8)
+! by calling FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!! Modification 15/10/97 (V.Masson) 1D and 2D cases
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+INTEGER, DIMENSION(:,:), &
+ INTENT(IN) ::KFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER(KIND=8), DIMENSION(SIZE(KFIELD,1),SIZE(KFIELD,2)) :: IFIELD
+INTEGER :: ILENG
+!-------------------------------------------------------------------------------
+!
+IFIELD(:,:)=KFIELD(:,:)
+!
+IF (LPACK .AND. L1D .AND. SIZE(KFIELD,1)==3 .AND. SIZE(KFIELD,2)==3) THEN
+ ILENG=SIZE(KFIELD)/9
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,IFIELD(2,2),KGRID,KLENCH,HCOMMENT,KRESP)
+ELSE IF (LPACK .AND. L2D .AND. SIZE(KFIELD,2)==3) THEN
+ ILENG=SIZE(KFIELD)/3
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,IFIELD(:,2),KGRID,KLENCH,HCOMMENT,KRESP)
+ELSE
+ ILENG=SIZE(KFIELD)
+ CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,IFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+END IF
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITN2
+!
+! #############################################################
+ SUBROUTINE FMWRITL0(HFILEM,HRECFM,HFIPRI,KLENG,OFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITL0* - routine to write a logical scalar into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITN0 is to convert the integer into integer(kind=8)
+! by calling FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+LOGICAL, &
+ INTENT(IN) ::OFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER(KIND=8) :: IFIELD
+!-------------------------------------------------------------------------------
+!
+IF (OFIELD) THEN
+ IFIELD=1
+ELSE
+ IFIELD=0
+END IF
+!
+CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,1,IFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITL0
+! #############################################################
+ SUBROUTINE FMWRITL1(HFILEM,HRECFM,HFIPRI,KLENG,OFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITL0* - routine to write a logical scalar into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITN0 is to convert the integer into integer(kind=8)
+! by calling FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+LOGICAL, DIMENSION(:), &
+ INTENT(IN) ::OFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER(KIND=8), DIMENSION(SIZE(OFIELD)) :: IFIELD
+!-------------------------------------------------------------------------------
+!
+WHERE (OFIELD)
+ IFIELD=1
+ ELSEWHERE
+ IFIELD=0
+END WHERE
+!
+CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,SIZE(IFIELD),IFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITL1
+! #############################################################
+ SUBROUTINE FMWRITC0(HFILEM,HRECFM,HFIPRI,KLENG,HFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITC0* - routine to write a string scalar into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITL0 is to convert the string into arrayr of
+! integer(kind=8) and to call FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+CHARACTER(LEN=*), &
+ INTENT(IN) ::HFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: JLOOP
+INTEGER(KIND=8), DIMENSION(:), ALLOCATABLE :: IFIELD
+INTEGER :: ILENG
+!-------------------------------------------------------------------------------
+!
+ILENG=LEN(HFIELD)
+ALLOCATE(IFIELD(ILENG))
+DO JLOOP=1,ILENG
+ IFIELD(JLOOP)=IACHAR(HFIELD(JLOOP:JLOOP))
+END DO
+!
+CALL FM_WRIT(HFILEM,HRECFM,HFIPRI,ILENG,IFIELD,KGRID,KLENCH,HCOMMENT,KRESP)
+!
+DEALLOCATE(IFIELD)
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITC0
+! #############################################################
+ SUBROUTINE FMWRITT0(HFILEM,HRECFM,HFIPRI,KLENG,TFIELD,KGRID,&
+ KLENCH,HCOMMENT,KRESP)
+! #############################################################
+!
+!!**** *FMWRITT0* - routine to write a date scalar into a "FM"-file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMWRITT0 is to split a date_time scalar
+! and to call FM_WRIT without interface module
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FM_WRIT
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. MASSON *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 18/08/97
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_FMDECLAR
+USE MODD_TYPE_DATE
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*) ,INTENT(IN) ::HFILEM ! file name
+CHARACTER(LEN=*) ,INTENT(IN) ::HRECFM ! name of the article to be written
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HFIPRI ! file for prints in FM
+
+INTEGER, INTENT(IN) ::KLENG ! length of the data field
+TYPE (DATE_TIME), &
+ INTENT(IN) ::TFIELD ! array containing the data field
+INTEGER, INTENT(IN) ::KGRID ! C-grid indicator (u,v,w,T)
+INTEGER, INTENT(IN) ::KLENCH ! length of comment string
+
+CHARACTER(LEN=*) ,INTENT(IN) ::HCOMMENT ! comment string
+
+INTEGER, INTENT(OUT)::KRESP ! return-code if problems araised
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER(KIND=8), DIMENSION(3) :: ITDATE ! date array
+CHARACTER(LEN=16) :: YRECFM ! Name of the article to be written
+CHARACTER(LEN=JPXKRK) :: YCOMMENT ! Comment string
+!
+!-------------------------------------------------------------------------------
+!
+YRECFM=TRIM(HRECFM)//'%TDATE' ! array of rank 3 for date is written in file
+YCOMMENT='YYYYMMDD'
+ITDATE(1)=TFIELD%TDATE%YEAR
+ITDATE(2)=TFIELD%TDATE%MONTH
+ITDATE(3)=TFIELD%TDATE%DAY
+CALL FM_WRIT(HFILEM,YRECFM,HFIPRI,3,ITDATE,0,8,YCOMMENT,KRESP)
+!
+YRECFM=TRIM(HRECFM)//'%TIME'
+YCOMMENT='SECONDS'
+CALL FM_WRIT(HFILEM,YRECFM,HFIPRI,1,TFIELD%TIME,0,7,YCOMMENT,KRESP)
+!
+!
+!-------------------------------------------------------------------------------
+END SUBROUTINE FMWRITT0
+
+
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/alloc_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/FM2DIA/alloc_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a6fae5cdb323885648ce57d13414462d8f0c6325
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/alloc_fordiachro.f90
@@ -0,0 +1,197 @@
+! ######spl
+ MODULE MODI_ALLOC_FORDIACHRO
+! #############################
+!
+INTERFACE
+!
+SUBROUTINE ALLOC_FORDIACHRO(KI,KJ,KK,KT,KN,KP,KOP,KNTRAJT,KKTRAJX, &
+ KKTRAJY,KKTRAJZ,KTTRAJX,KTTRAJY,KTTRAJZ,KNTRAJX,KNTRAJY,KNTRAJZ,KIMASK, &
+ KJMASK,KKMASK,KTMASK,KNMASK,KPMASK)
+INTEGER :: KI,KJ,KK,KT,KN,KP,KOP
+INTEGER,OPTIONAL :: KNTRAJT,KKTRAJX,KKTRAJY,KKTRAJZ,KTTRAJX, &
+ KTTRAJY,KTTRAJZ,KNTRAJX,KNTRAJY,KNTRAJZ,KIMASK, &
+ KJMASK,KKMASK,KTMASK,KNMASK,KPMASK
+END SUBROUTINE ALLOC_FORDIACHRO
+!
+END INTERFACE
+!
+END MODULE MODI_ALLOC_FORDIACHRO
+! ######spl
+ SUBROUTINE ALLOC_FORDIACHRO(KI,KJ,KK,KT,KN,KP,KOP,KNTRAJT,KKTRAJX, &
+ KKTRAJY,KKTRAJZ,KTTRAJX,KTTRAJY,KTTRAJZ,KNTRAJX,KNTRAJY,KNTRAJZ,KIMASK, &
+ KJMASK,KKMASK,KTMASK,KNMASK,KPMASK)
+! #########################################################################
+!
+!!**** *ALLOC_FORDIACHRO* - Allocation de tableaux dont les dimensions
+! sont fournies en arguments de la routine
+! (VALABLE UNIQUEMENT DANS LE CADRE DU TRAITEMENT D'1 FICHIER
+! DIACHRONIQUE : lecture ou/et ecriture)
+!!
+!! PURPOSE
+!! -------
+! En fonction d'un code operation transmis dans l'argument KOP
+! alloue ou desalloue des tableaux
+!
+!!** METHOD
+!! ------
+!!
+!! KOP=1
+! Alloue des tableaux (en utilisant les 6 1ers arguments qui sont des
+! dimensions fournies par l'utilisateur) destines a etre charges par
+! l'utilisateur et ecrits dans 1 fichier diachronique.
+! Le nombre, le nom et le profil de ces tableaux est dependant du
+! type d'informations a ecrire (CTYPE du MODULE : MODD_TYPE_AND_LH)
+!
+! KOP=2
+! Alloue des tableaux (dont les dimensions ont ete lues dans un
+! enregistrement d'1 fichier diachronique et transmis en arguments)
+! destines a lire les valeurs du champ correspondant au groupe
+! demande dans le meme fichier diachronique
+!
+! KOP=3
+! Desalloue les tableaux alloues avec KOP=1 ou 2
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/01/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_ALLOC_FORDIACHRO
+USE MODD_TYPE_AND_LH
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+INTEGER :: KI, KJ, KK, KT, KN,KP, KOP
+INTEGER,OPTIONAL :: KNTRAJT,KKTRAJX,KKTRAJY,KKTRAJZ,KTTRAJX, &
+ KTTRAJY,KTTRAJZ,KNTRAJX,KNTRAJY,KNTRAJZ,KIMASK, &
+ KJMASK,KKMASK,KTMASK,KNMASK,KPMASK
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+!------------------------------------------------------------------------------
+!
+IF (KOP == 1)THEN
+
+ ALLOCATE(XDATIME(16,KT))
+ ALLOCATE(NGRIDIA(KP))
+ SELECT CASE (CTYPE)
+ CASE ('CART','SPXY')
+ ALLOCATE(XVAR(KI,KJ,KK,KT,KN,KP))
+ ALLOCATE(XTRAJT(KT,KN))
+ CASE ('MASK','SSOL')
+ ALLOCATE(XVAR(1,1,KK,KT,KN,KP))
+ ALLOCATE(XTRAJT(KT,1))
+ CASE ('DRST','RAPL')
+ ALLOCATE(XVAR(1,1,KK,KT,KN,KP))
+ ALLOCATE(XTRAJT(KT,KN))
+ CASE ('RSPL')
+ ALLOCATE(XVAR(1,1,1,KT,KN,KP))
+ ALLOCATE(XTRAJT(KT,KN))
+ END SELECT
+
+ ALLOCATE(CTITRE(KP),CUNITE(KP),CCOMMENT(KP))
+
+ IF (CTYPE == 'SSOL')THEN
+ ALLOCATE(XTRAJX(1,1,KN),XTRAJY(1,1,KN),XTRAJZ(KK,1,KN))
+ ENDIF
+ IF (CTYPE == 'DRST')THEN
+ ALLOCATE(XTRAJX(1,KT,KN),XTRAJY(1,KT,KN),XTRAJZ(KK,KT,KN))
+ ENDIF
+ IF (CTYPE == 'RSPL')THEN
+ ALLOCATE(XTRAJX(1,KT,KN),XTRAJY(1,KT,KN),XTRAJZ(1,KT,KN))
+ ENDIF
+ IF (CTYPE == 'RAPL')THEN
+ ALLOCATE(XTRAJX(KK,KT,KN),XTRAJY(KK,KT,KN),XTRAJZ(KK,KT,KN))
+ ENDIF
+
+ IF (CTYPE == 'MASK')THEN
+ ALLOCATE(XMASK(KI,KJ,1,KT,KN,1))
+ ENDIF
+
+ELSE IF(KOP == 2)THEN
+
+ ALLOCATE(XDATIME(16,KT))
+ ALLOCATE(XVAR(KI,KJ,KK,KT,KN,KP))
+ ALLOCATE(XTRAJT(KT,KNTRAJT))
+ ALLOCATE(CTITRE(KP),CUNITE(KP),CCOMMENT(KP))
+ CTITRE(:)(1:LEN(CTITRE))=' '
+ CUNITE(:)(1:LEN(CUNITE))=' '
+ CCOMMENT(:)(1:LEN(CCOMMENT))=' '
+ ALLOCATE(NGRIDIA(KP))
+ IF(KKTRAJX /= 0 .AND. KTTRAJX /= 0 .AND. KNTRAJX /=0 )THEN
+ ALLOCATE(XTRAJX(KKTRAJX,KTTRAJX,KNTRAJX))
+ ENDIF
+ IF(KKTRAJY /= 0 .AND. KTTRAJY /= 0 .AND. KNTRAJY /=0 )THEN
+ ALLOCATE(XTRAJY(KKTRAJY,KTTRAJY,KNTRAJY))
+ ENDIF
+ IF(KKTRAJZ /= 0 .AND. KTTRAJZ /= 0 .AND. KNTRAJZ /=0 )THEN
+ ALLOCATE(XTRAJZ(KKTRAJZ,KTTRAJZ,KNTRAJZ))
+ ENDIF
+ IF(KIMASK /= 0 .AND. KJMASK /= 0 .AND. KKMASK/= 0 .AND. &
+ KTMASK /= 0 .AND. KNMASK /= 0 .AND. KPMASK/= 0 )THEN
+ ALLOCATE(XMASK(KIMASK,KJMASK,KKMASK,KTMASK,KNMASK,KPMASK))
+ ENDIF
+
+ELSE
+
+ IF(ALLOCATED(XDATIME))DEALLOCATE(XDATIME)
+ IF(ALLOCATED(XVAR))DEALLOCATE(XVAR)
+ IF(ALLOCATED(XTRAJT))DEALLOCATE(XTRAJT)
+ IF(ALLOCATED(CTITRE))DEALLOCATE(CTITRE)
+ IF(ALLOCATED(CUNITE))DEALLOCATE(CUNITE)
+ IF(ALLOCATED(CCOMMENT))DEALLOCATE(CCOMMENT)
+! DEALLOCATE(XVAR,XTRAJT,CTITRE,CUNITE,CCOMMENT)
+
+ IF (CTYPE == 'SSOL' .OR. &
+ CTYPE == 'DRST' .OR. &
+ CTYPE == 'RSPL' .OR. &
+ CTYPE == 'RAPL')THEN
+ IF(ALLOCATED(XTRAJX)) DEALLOCATE(XTRAJX)
+ IF(ALLOCATED(XTRAJY)) DEALLOCATE(XTRAJY)
+ IF(ALLOCATED(XTRAJZ)) DEALLOCATE(XTRAJZ)
+ ENDIF
+
+ IF (CTYPE == 'MASK')THEN
+ IF(ALLOCATED(XMASK)) DEALLOCATE(XMASK)
+ ENDIF
+
+ IF(ALLOCATED(NGRIDIA))THEN
+ DEALLOCATE(NGRIDIA)
+ ENDIF
+
+ENDIF
+
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE ALLOC_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/conv2dia.elim.f90 b/LIBTOOLS/tools/diachro/src/FM2DIA/conv2dia.elim.f90
new file mode 100644
index 0000000000000000000000000000000000000000..307ccc2ac8a3cf6233eaebaf9fe1e25685d610b4
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/conv2dia.elim.f90
@@ -0,0 +1,557 @@
+! ######spl
+ PROGRAM FM2DIACHRO
+! ###################
+!
+!!**** *FM2DIACHRO* - Conversion des fichiers synchrones LFIFM en
+!! fichiers de type diachronique (LFIFM egalement)
+!!
+!!
+!! PURPOSE
+!! -------
+!
+! Convertit 1 (ou plusieurs fichiers synchrones correspondant a
+! des sorties successives d'un meme run) en 1 fichier diachronique
+!
+!!** METHOD
+!! ------
+!!
+! La routine LFILAF (du logiciel LFI) modifiee (--> JDLFILAF) pour
+! l'ouverture d'un fichier FICJD ecrit dans celui-ci le numero,
+! le nom et la longueur totale des enregistrements.
+! Puis un appel a la routine LFILEC permet de lire dans le 2eme mot
+! de chaque enregistrement la longueur du champ commentaire (qui n'est
+! pas necessairement constante) et donc de deduire par soustraction
+! la longueur du champ physique enregistre
+! de sorte que l'on possede toutes les informations necessaires a la
+! lecture avec FMREAD des enregistrements d'un fichier LFIFM dont on ne
+! connait pas a priori le contenu. (du moins pour les infos reelles)
+! Dans un premier temps, on ecrit dans le fichier diachonique avec
+! la routine WRITE_LFIFM1_FORDIACHRO_CV l'entete des fichiers d'entree
+! en particulier les parametres de grille, l'etat de reference ...
+! Puis en bouclant sur le nombre de fichiers a traiter et le nombre
+! d'enregistrements de chacun, on lit chaque champ et on regroupe
+! progressivement dans un enregistrement du fichier diachronique unique
+! pour un meme parametre les differentes echeances trouvees.
+! ACTUELLEMENT (Avril 97) SONT PRIS EN COMPTE LES CHAMPS DE LONGUEUR
+! IIU*IJU*IKU , IIU*IJU et 1
+!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHORS
+!! -------
+!! J. Duron *Lab. Aerologie*
+!!
+!! Copyright 1994, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/01/96
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF
+USE MODD_DIM1, ONLY: NIMAX,NJMAX,NKMAX
+USE MODD_GRID ! XLON0,XLAT0, XBETA,XRPK
+USE MODD_GRID1 ! XLONOR,XLATOR
+USE MODD_TIME1 ! TDTCUR
+!
+USE MODD_DIACHRO
+USE MODD_OUT_DIA
+USE MODD_REA_LFI
+USE MODD_DIMGRID_FORDIACHRO
+!USE MODI_READ_DESFM
+USE MODI_READ_DIMGRIDREF_FM2DIA
+USE MODI_WRITE_DIMGRIDREF
+USE MODI_WRITE_OTHERSFIELDS
+USE MODI_MENU_DIACHRO
+USE MODI_INI_CST
+
+IMPLICIT NONE
+!
+!* 0.1 Local variables declarations
+!
+INTEGER :: ILUDES ! Logical unit number for the DES file
+INTEGER :: INUMER
+
+INTEGER,DIMENSION(50) :: IFICJD
+
+INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE :: IWORK
+
+INTEGER :: INUM, ISIZ, INBM
+
+INTEGER :: IRESP, IVAR
+INTEGER :: INEWSIZE, ITYPCOD
+
+INTEGER :: JJ, J, JA
+INTEGER :: INB, IID, JI, JIP1, ICODEL, IL, IDA
+INTEGER :: I4
+INTEGER,DIMENSION(:), ALLOCATABLE :: IIMAX, IJMAX, IKMAX
+REAL,DIMENSION(:), ALLOCATABLE :: ZTIMECUR,ZLON0,ZRPK,ZLONOR,ZLATOR,ZLAT0,ZBETA
+LOGICAL,DIMENSION(:), ALLOCATABLE :: OCARTESIAN
+LOGICAL :: GDTOUT, GOK
+
+CHARACTER(LEN=16) :: YRECFM, YRECFM2
+CHARACTER(LEN=3) :: YREPON
+CHARACTER(LEN=16) :: YREF
+CHARACTER(LEN=16) :: YCOMMENT
+CHARACTER(LEN=80) :: YCAR80
+CHARACTER(LEN=16),DIMENSION(50) :: YFICJD, YFICJDOUT
+CHARACTER(LEN=16),DIMENSION(:), ALLOCATABLE,SAVE :: YRECT, YRECID
+CHARACTER(LEN=16),DIMENSION(4) :: YPRI
+!-------------------------------------------------------------------------------
+!
+!* 1. Definition du type de traitement et init du fichier de constantes
+! -----------------------------------------------------------------
+!
+CPROGRAM='FM2DIA'
+!
+CCONF='POSTP'
+CALL INI_CST
+OPEN(80,FILE='dirconv.elim',FORM='FORMATTED')
+!
+!
+!* 2. Lecture du nombre de fichiers a regrouper et de leur nom
+! --------------------------------------------------------
+! Doivent etre dissocies en *.des et *.lfi et
+! rentres en ordre chronologique (1 / 1 ligne)
+!
+PRINT *,' ENTER NUMBER OF INPUT FM FILES'
+READ(5,*)NNBF
+YCAR80(1:LEN(YCAR80))=' '
+WRITE(YCAR80,*)NNBF
+YCAR80=ADJUSTL(YCAR80)
+WRITE(80,'(A80)')YCAR80
+
+DO J=1,NNBF
+ PRINT *,' ENTER FM FILE NAME'
+ READ(5,'(A28)')CNAMFILED(J)
+ YCAR80(1:LEN(YCAR80))=' '
+ YCAR80=CNAMFILED(J)
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ENDDO
+!
+!
+!* 3. Lecture du nom du fichier diachronique a creer
+! ----------------------------------------------
+!
+
+PRINT *,' ENTER DIACHRONIC FILE NAME'
+READ(5,'(A28)')CFILEDIA
+YCAR80(1:LEN(YCAR80))=' '
+YCAR80=CFILEDIA
+YCAR80=ADJUSTL(YCAR80)
+WRITE(80,'(A80)')YCAR80
+!
+!* 4. Ouverture du fichier correspondant au listing
+! ---------------------------------------------
+!
+CLUOUTD='LISTING_DIA'
+CALL FMATTR(CLUOUTD,CLUOUTD,NLUOUTD,NRESP)
+OPEN(UNIT=NLUOUTD,FILE=CLUOUTD,FORM='FORMATTED')
+!
+!* 5. Boucle sur les fichiers a lire
+! ------------------------------
+!
+DO J=1,NNBF
+
+ CLFIFMD(J)=ADJUSTL(ADJUSTR(CNAMFILED(J))//'.lfi')
+ CDESFMD(J)=ADJUSTL(ADJUSTR(CNAMFILED(J))//'.des')
+
+!
+!* 5.1 Ouverture des fichiers LFIFM et DESFM
+!
+ CSTATU='OLD'
+ NVERB=5
+! Modif demandee par Nicole Asencio. 28/9/98
+ NFTYPE=2
+! NFTYPE=0
+ CALL FMOPEN(CNAMFILED(J),CSTATU,CLUOUTD,NNPRAR,NFTYPE,NVERB,NNINAR,NRESP)
+ IF(NRESP.NE.0)THEN
+ WRITE(0,*)'BUG OPENING LFIFM FILE ',CLFIFMD(J),' RETURN CODE= ',NRESP
+ END IF
+!
+!* 5.2 Fermeture du fichier DESFM (ACTUELLEMENT NON INTEGRE DANS LE
+! FICHIER DIACHRONIQUE)
+! en 5.6 avec LFIFM par FMCLOS
+!
+!* 5.3 Lecture du numero, nom et longueur des enregistrements
+! Memorisation dans les tableaux NNUMT,CRECFM2T,NSIZT
+!
+!
+ GDTOUT=.TRUE.
+ CALL FMLOOK(CLFIFMD(J),CLUOUTD,INUMER,NRESP)
+ CALL JDLFILAF(NRESP,INUMER,GDTOUT)
+!
+ YFICJD(J)='FICJD'
+ YFICJDOUT(J)='FICJDOUT'
+ CALL FMATTR(YFICJD(J),YFICJDOUT(J),IFICJD(J),NRESP)
+ OPEN(UNIT=IFICJD(J),FILE=YFICJD(J),FORM='FORMATTED',STATUS='OLD')
+!
+ NNB=0
+ DO JJ=1,10000
+ READ(IFICJD(J),*,END=99)INUM,YRECFM2,ISIZ
+ NNB=NNB+1
+ ENDDO
+99 CONTINUE
+
+ IF(J == 1)THEN
+ INBM=NNB
+ ENDIF
+
+ WRITE(NLUOUTD,*)' ******** FICHIER N: ',J,CNAMFILED(J)(1:LEN_TRIM(CNAMFILED(J))), &
+ ' NB ENR. ',NNB
+ WRITE(NLUOUTD,*)' ******** '
+!
+ REWIND(IFICJD(J))
+!
+ IF(J == 1)THEN
+ ALLOCATE(NNUMT(NNB+100,50),NSIZT(NNB+100,50),NLENC(NNB+100,50))
+ ALLOCATE(CRECFM2T(NNB+100,50))
+ ENDIF
+!
+ DO JJ=1,NNB
+ READ(IFICJD(J),*)NNUMT(JJ,J),CRECFM2T(JJ,J),NSIZT(JJ,J)
+ ALLOCATE(IWORK(NSIZT(JJ,J)))
+ CALL LFILEC(NRESP,INUMER,CRECFM2T(JJ,J),IWORK,NSIZT(JJ,J))
+ NLENC(JJ,J)=IWORK(2) ! longueur de la zone commentaire
+! Determination de la longueur de la zone de donnees
+! 2 = 1er mot : numero de grille et 2eme mot : longueur de la zone commentaire
+ NSIZT(JJ,J)=NSIZT(JJ,J)-2-NLENC(JJ,J)
+ CALL GET_COMPHEADER(IWORK(3+NLENC(JJ,J)),NSIZT(JJ,J),INEWSIZE,ITYPCOD)
+ IF (INEWSIZE >= 0) THEN ! compressed field found
+ WRITE (NLUOUTD,*) TRIM(CRECFM2T(JJ,J)),' is compressed (old/new SIZE):',NSIZT(JJ,J),INEWSIZE
+ NSIZT(JJ,J)=INEWSIZE
+ END IF
+ DEALLOCATE(IWORK)
+ ENDDO
+!
+ CLOSE (IFICJD(J))
+ CALL FMFREE(YFICJD(J),YFICJDOUT(J),NRESP)
+
+! Verification de l'egalite du nombre d'enregistrements dans les differents
+! fichiers
+
+ IF(J > 1)THEN
+ IF(INBM /= NNB)THEN
+ WRITE(NLUOUTD,*)' ******************************************'
+ WRITE(NLUOUTD,*)' Nb enregistrents different (/ 1er fichier)'
+ WRITE(NLUOUTD,*)' ******************************************'
+ WRITE(NLUOUTD,*)' ( - = absence par rapport au 1er fichier, + = ajout)'
+ WRITE(NLUOUTD,*)' ( + ne sont pas integres dans le fichier diachronique)'
+ ENDIF
+ ENDIF
+
+! Verification de l'identite des enregistrements dans les differents fichiers
+
+ IF(J > 1)THEN
+ IF(INBM /= NNB)THEN
+ IF (INBM > NNB)THEN
+ DO JJ=1,INBM
+ GOK=.FALSE.
+ DO JA=1,NNB
+ IF(CRECFM2T(JJ,1) == CRECFM2T(JA,J))THEN
+ GOK=.TRUE.
+ EXIT
+ ELSE
+ CYCLE
+ ENDIF
+ ENDDO
+ IF(.NOT.GOK)THEN
+ NNUMT(JJ,1)=0
+ WRITE(NLUOUTD,*)' - ',CRECFM2T(JJ,1)
+ ENDIF
+ ENDDO
+
+ ELSE
+
+ DO JJ=1,NNB
+ GOK=.FALSE.
+ DO JA=1,INBM
+ IF(CRECFM2T(JJ,J) == CRECFM2T(JA,1))THEN
+ GOK=.TRUE.
+ EXIT
+ ELSE
+ CYCLE
+ ENDIF
+ ENDDO
+ IF(.NOT.GOK)THEN
+ WRITE(NLUOUTD,*)' + ',CRECFM2T(JJ,J)
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+!
+!* 5.4 Lecture et ecriture des parametres "intouchables"
+!
+ CALL READ_DIMGRIDREF_FM2DIA(J,CNAMFILED(J),CLUOUTD)
+!
+! 5.41 Writing or checking DIM., GRID., REF. VARIABLES
+!
+ IF(J == 1)THEN ! premier fichier
+ CALL WRITE_DIMGRIDREF
+ ALLOCATE(IIMAX(NNBF),IJMAX(NNBF),IKMAX(NNBF),ZTIMECUR(NNBF))
+ ALLOCATE(ZLON0(NNBF),ZLAT0(NNBF),ZLONOR(NNBF),ZLATOR(NNBF), &
+ ZRPK(NNBF),ZBETA(NNBF) )
+ ALLOCATE(OCARTESIAN(NNBF))
+ ENDIF
+!
+ IIMAX(J)=NIMAX ; IJMAX(J)=NJMAX ; IKMAX(J)=NKMAX
+ ZTIMECUR(J)=TDTCUR%TIME
+ ZLON0(J)=XLON0 ; ZLAT0(J)=XLAT0
+ ZLONOR(J)=XLONOR ; ZLATOR(J)=XLATOR
+ ZRPK(J)=XRPK ; ZBETA(J)=XBETA
+ OCARTESIAN(J)=LCARTESIAN
+!
+ IF(J > 1)THEN ! fichiers suivants
+ !
+ IF(IIMAX(J) /= IIMAX(1))THEN
+ PRINT *,' J IIMAX(J) IIMAX(1) ',J,IIMAX(J),IIMAX(1)
+ ENDIF
+ IF(IJMAX(J) /= IJMAX(1))THEN
+ PRINT *,' J IJMAX(J) IJMAX(1) ',J,IJMAX(J),IJMAX(1)
+ ENDIF
+ IF(IKMAX(J) /= IKMAX(1))THEN
+ PRINT *,' J IKMAX(J) IKMAX(1) ',J,IKMAX(J),IKMAX(1)
+ ENDIF
+ IF(ZTIMECUR(J) /= ZTIMECUR(1))THEN
+ PRINT *,' J ZTIMECUR(J) ZTIMECUR(1) ',J,ZTIMECUR(J),ZTIMECUR(1)
+ ENDIF
+ IF(ZLON0(J) /= ZLON0(1))THEN
+ PRINT *,' J ZLON0(J) ZLON0(1) ',J,ZLON0(J),ZLON0(1)
+ ENDIF
+ IF(ZRPK(J) /= ZRPK(1))THEN
+ PRINT *,' J ZRPK(J) ZRPK(1) ',J,ZRPK(J),ZRPK(1)
+ ENDIF
+ IF(ZLONOR(J) /= ZLONOR(1))THEN
+ PRINT *,' J ZLONOR(J) ZLONOR(1) ',J,ZLONOR(J),ZLONOR(1)
+ ENDIF
+ IF(ZLATOR(J) /= ZLATOR(1))THEN
+ PRINT *,' J ZLATOR(J) ZLATOR(1) ',J,ZLATOR(J),ZLATOR(1)
+ ENDIF
+ IF(ZLAT0(J) /= ZLAT0(1))THEN
+ PRINT *,' J ZLAT0(J) ZLAT0(1) ',J,ZLAT0(J),ZLAT0(1)
+ ENDIF
+ IF(ZBETA(J) /= ZBETA(1))THEN
+ PRINT *,' J ZBETA(J) ZBETA(1) ',J,ZBETA(J),ZBETA(1)
+ ENDIF
+ IF((OCARTESIAN(J) .AND..NOT. OCARTESIAN(1)) .OR. &
+ (.NOT. OCARTESIAN(J) .AND. OCARTESIAN(1)))THEN
+ PRINT *,' J OCARTESIAN(J) OCARTESIAN(1) ',J,OCARTESIAN(J),OCARTESIAN(1)
+ ENDIF
+ !
+ ENDIF
+!
+ IF(J == NNBF)THEN ! dernier fichier
+ DEALLOCATE(IIMAX,IJMAX,IKMAX,ZTIMECUR)
+ DEALLOCATE(ZLON0,ZRPK,ZLONOR,ZLATOR,ZLAT0,ZBETA)
+ DEALLOCATE(OCARTESIAN)
+ END IF
+!
+! 5.42 Eventuelle eliminination de certains parametres ds le fic. diach.
+!
+ IF(J == 1)THEN
+
+
+ ALLOCATE(YRECT(SIZE(CRECFM2T,1)))
+ YRECT(:)(1:LEN(YRECT))=' '
+ INB=0
+ DO JI=1,NNB
+ IF(NNUMT(JI,J) /= 0)THEN
+ INB=INB+1
+ YRECT(INB)=CRECFM2T(JI,J)
+ YRECT(INB)=ADJUSTL(YRECT(INB))
+! print *,' INB, YRECT ',INB,YRECT(INB)
+ ENDIF
+ ENDDO
+ ALLOCATE(YRECID(INB))
+ YRECID(:)(1:LEN(YRECID))=' '
+ IID=0
+ DO JI = 1,INB-1
+ YREF(1:LEN(YREF))=' '
+ IL=LEN_TRIM(YRECT(JI))-1
+ YREF(1:IL)=YRECT(JI)(1:IL)
+! YREF=ADJUSTL(YREF)
+ IF(YRECT(JI)(IL+1:IL+1) == 'M')THEN
+ DO JIP1=JI+1,INB
+! DO JIP1=2,INB
+ IL=LEN_TRIM(YRECT(JIP1))-1
+ IF(YRECT(JIP1)(1:IL) == YREF)THEN
+ IID=IID+1
+ YRECID(IID)=' '
+ YRECID(IID)=YREF
+ YRECID(IID)=ADJUSTL(YRECID(IID))
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+ print *,' DELETION OF PARAMETERS AT TIME t-dt ? (enter 1) '
+ print *,' DELETION OF PARAMETERS AT TIME t ? (enter 2) '
+ print *,' NO DELETION ? (enter 0) '
+ READ(5,*)ICODEL
+ YCAR80(1:LEN(YCAR80))=' '
+ WRITE(YCAR80,*)ICODEL
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ IF(ICODEL == 0)THEN
+ ELSE IF(ICODEL == 1)THEN
+ DO JI=1,IID
+ YRECID(JI)=ADJUSTL(ADJUSTR(YRECID(JI))//'M')
+! YRECID(1:IID)=ADJUSTL(ADJUSTR(YRECID(1:IID))//'M')
+ ENDDO
+ ELSE IF(ICODEL == 2)THEN
+ DO JI=1,IID
+ YRECID(JI)=ADJUSTL(ADJUSTR(YRECID(JI))//'T')
+! YRECID(1:IID)=ADJUSTL(ADJUSTR(YRECID(1:IID))//'T')
+ ENDDO
+ ENDIF
+
+ I4=0
+ YPRI=' '
+ IF(ICODEL /= 0)THEN
+
+ print *,' PARAMETRES RESTANTS'
+ DO JI = 1,NNB
+ DO JIP1 = 1,IID
+ IF(CRECFM2T(JI,J) == YRECID(JIP1))THEN
+ NNUMT(JI,J)=0
+ EXIT
+ ENDIF
+ ENDDO
+ IF(NNUMT(JI,J) /= 0)THEN
+ I4=I4+1
+ YPRI(I4)=CRECFM2T(JI,J)
+ IF(I4 == 4 .OR. JI == NNB)THEN
+ print 10,YPRI
+ I4=0
+ YPRI=' '
+ ENDIF
+ ENDIF
+ ENDDO
+
+ YREPON(1:LEN(YREPON))=' '
+ print *,' Do you want to suppress others parameters ? (y/n) '
+ READ(5,*)YREPON
+ YCAR80(1:LEN(YCAR80))=' '
+ YCAR80=YREPON
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ IF(YREPON == 'y' .OR. YREPON == 'yes' .OR. YREPON == 'o' .OR. &
+ YREPON == 'oui')THEN
+ print *,'Enter their names in UPPERCASE (1/1 line) '
+ print *,'End by END '
+ DO JI=1,1000
+ IID=IID+1
+ YRECID(IID)=' '
+ READ(5,*)YRECID(IID)
+ YRECID(IID)=ADJUSTL(YRECID(IID))
+ YCAR80(1:LEN(YCAR80))=' '
+ YCAR80=YRECID(IID)
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ IF(YRECID(IID) == 'END')THEN
+ CLOSE(80)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+! print *,' YRECID'
+! print 10,YRECID(1:IID)
+! print *,' CRECFM2T'
+! print 10,CRECFM2T(1:NNB,J)
+! print *,' PARAMETRES RESTANTS'
+ 10 FORMAT(1X,4A19)
+ I4=0
+! YPRI(:)=' '
+ IF(ICODEL /= 0)THEN
+ DO JI = 1,NNB
+ DO JIP1 = 1,IID
+ IF(CRECFM2T(JI,J) == YRECID(JIP1))THEN
+ NNUMT(JI,J)=0
+ EXIT
+ ENDIF
+ ENDDO
+ IF(NNUMT(JI,J) /= 0)THEN
+ IF(I4 == 4)THEN
+ print 10,YPRI
+ I4=0
+! YPRI(1:4)=' '
+ ENDIF
+ I4=I4+1
+ YPRI(I4)=CRECFM2T(JI,J)
+ ENDIF
+ ENDDO
+! print 10,YPRI
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+!
+ IF(J == 1)THEN
+ DO JI=1,NNB
+! 5.43 Elimination des dates
+!
+ IDA=INDEX(CRECFM2T(JI,J),'%TDA')
+ IF(IDA /= 0)THEN
+ NNUMT(JI,J)=0
+ ENDIF
+ IDA=INDEX(CRECFM2T(JI,J),'%TIM')
+ IF(IDA /= 0)THEN
+ NNUMT(JI,J)=0
+ ENDIF
+! 5.44 Elimination des champs dont le nom depasse 13 caracteres
+! (13 = 16 (=max.LEN(RECFM)=JPNCPN) -3 (=LEN('.TYpe','.DIm','.TItre',
+! '.UNite','.COmment','.PRoc1','.TRajt','.DAtim'))
+ IF (LEN_TRIM(CRECFM2T(JI,J))>13 .AND. NNUMT(JI,J)/=0) THEN
+ NNUMT(JI,J)=0
+ print*,'Variable ',CRECFM2T(JI,J), ' not written (name too long)'
+ WRITE(NLUOUTD,*)'Variable ',CRECFM2T(JI,J), ' not written (name too long)'
+ END IF
+ ENDDO
+ ENDIF
+!
+!
+!* 5.5 Lecture et ecriture des autres champs
+!
+ CALL WRITE_OTHERSFIELDS(J,CFILEDIA,CLUOUTDIA)
+!
+!* 5.6 Fermeture du Fichier d'entree traite et liberation des unites
+! logiques correspondantes (DES et LFI)
+!
+ CALL FMCLOS(CNAMFILED(J),'KEEP',CLUOUTD,NRESP)
+!
+ENDDO
+!
+!* 6. Terminaison du fichier diachronique et impression du nom des
+! groupes enregistres
+! -------------------------------------------------------------
+!
+CALL MENU_DIACHRO(CFILEDIA,CLUOUTDIA,'END')
+CALL MENU_DIACHRO(CFILEDIA,CLUOUTDIA,'READ')
+
+CLOSE(NLUOUTD)
+CALL FMFREE(CLUOUTD,CLUOUTD,NRESP)
+!
+!* 7. Fermeture du fichier diachronique
+! ---------------------------------
+!
+CALL FMCLOS(CFILEDIA,'KEEP',CLUOUTDIA,NRESP)
+!
+!------------------------------------------------------------------------------
+!
+!* 4. EPILOGUE
+! --------
+
+STOP
+
+END PROGRAM FM2DIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/conv2dia.f90 b/LIBTOOLS/tools/diachro/src/FM2DIA/conv2dia.f90
new file mode 100644
index 0000000000000000000000000000000000000000..693db0aca25cc537b27fbe0c917871a857631542
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/conv2dia.f90
@@ -0,0 +1,807 @@
+! ######spl
+ PROGRAM FM2DIACHRO
+! ###################
+!
+!!**** *FM2DIACHRO* - Conversion des fichiers synchrones LFIFM en
+!! fichiers de type diachronique (LFIFM egalement)
+!!
+!!
+!! PURPOSE
+!! -------
+!
+! Convertit 1 (ou plusieurs fichiers synchrones correspondant a
+! des sorties successives d'un meme run) en 1 fichier diachronique
+!
+!!** METHOD
+!! ------
+!!
+! La routine LFILAF (du logiciel LFI) modifiee (--> JDLFILAF) pour
+! l'ouverture d'un fichier FICJD ecrit dans celui-ci le numero,
+! le nom et la longueur totale des enregistrements.
+! Puis un appel a la routine LFILEC permet de lire dans le 2eme mot
+! de chaque enregistrement la longueur du champ commentaire (qui n'est
+! pas necessairement constante) et donc de deduire par soustraction
+! la longueur du champ physique enregistre
+! de sorte que l'on possede toutes les informations necessaires a la
+! lecture avec FMREAD des enregistrements d'un fichier LFIFM dont on ne
+! connait pas a priori le contenu. (du moins pour les infos reelles)
+! Dans un premier temps, on ecrit dans le fichier diachonique avec
+! la routine WRITE_LFIFM1_FORDIACHRO_CV l'entete des fichiers d'entree
+! en particulier les parametres de grille, l'etat de reference ...
+! Puis en bouclant sur le nombre de fichiers a traiter et le nombre
+! d'enregistrements de chacun, on lit chaque champ et on regroupe
+! progressivement dans un enregistrement du fichier diachronique unique
+! pour un meme parametre les differentes echeances trouvees.
+! ACTUELLEMENT (Avril 97) SONT PRIS EN COMPTE LES CHAMPS DE LONGUEUR
+! IIU*IJU*IKU , IIU*IJU et 1
+!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHORS
+!! -------
+!! J. Duron *Lab. Aerologie*
+!!
+!! Copyright 1994, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/01/96
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF
+USE MODD_PARAMETERS, ONLY: JPHEXT,JPVEXT
+USE MODD_DIM1, ONLY: NIMAX,NJMAX,NKMAX
+USE MODD_GRID ! XLON0,XLAT0, XBETA,XRPK
+USE MODD_GRID1 ! XLONOR,XLATOR
+USE MODD_TIME1 ! TDTCUR
+!
+USE MODD_DIACHRO
+USE MODD_OUT_DIA
+USE MODD_REA_LFI
+USE MODD_DIMGRID_FORDIACHRO
+!USE MODI_READ_DESFM
+USE MODI_READ_DIMGRIDREF_FM2DIA
+USE MODI_WRITE_DIMGRIDREF
+USE MODI_WRITE_OTHERSFIELDS
+USE MODI_MENU_DIACHRO
+USE MODI_INI_CST
+
+IMPLICIT NONE
+!
+!* 0.1 Local variables declarations
+!
+INTEGER :: ILUDES ! Logical unit number for the DES file
+INTEGER :: INUMER
+
+INTEGER,DIMENSION(100) :: IFICJD
+
+INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE :: IWORK
+
+INTEGER :: INUM, ISIZ, INBM
+
+INTEGER :: IRESP, IVAR, IEL_OR_SEL
+INTEGER :: INEWSIZE, ITYPCOD
+
+INTEGER :: JJ, J, JA, J1, J2, I2
+INTEGER :: INB, IID, JI, JIP1, ICODEL, IL, IDA
+INTEGER :: I4, IOK, IKEEP
+INTEGER :: IX,IY,IZ,ixyz ! resolution degradee
+INTEGER :: IIMAXIN,IJMAXIN,IKMAXIN,IIMAXOUT,IJMAXOUT,IKMAXOUT ! "
+REAL,DIMENSION(:), ALLOCATABLE :: ZXHAT,ZYHAT !,ZZHAT ! "
+REAL,DIMENSION(:,:), ALLOCATABLE :: ZZS ! "
+INTEGER,DIMENSION(:), ALLOCATABLE :: IIMAX, IJMAX, IKMAX
+REAL,DIMENSION(:), ALLOCATABLE :: ZTIMECUR,ZLON0,ZRPK,ZLONOR,ZLATOR,ZLAT0,ZBETA
+LOGICAL,DIMENSION(:), ALLOCATABLE :: OCARTESIAN
+LOGICAL :: GDTOUT, GOK
+
+CHARACTER(LEN=16) :: YRECFM, YRECFM2
+CHARACTER(LEN=3) :: YREPON
+CHARACTER(LEN=16) :: YREF
+CHARACTER(LEN=16) :: YCOMMENT
+CHARACTER(LEN=80) :: YCAR80
+CHARACTER(LEN=16),DIMENSION(100) :: YFICJD, YFICJDOUT
+CHARACTER(LEN=16),DIMENSION(:), ALLOCATABLE,SAVE :: YRECT, YRECID, YKEEP
+CHARACTER(LEN=16),DIMENSION(5) :: YPRI
+!-------------------------------------------------------------------------------
+!
+!* 1. Definition du type de traitement et init du fichier de constantes
+! -----------------------------------------------------------------
+!
+CPROGRAM='FM2DIA'
+!
+CCONF='POSTP'
+CALL INI_CST
+OPEN(80,FILE='dirconv',FORM='FORMATTED')
+!
+!
+!* 2. Lecture du nombre de fichiers a regrouper et de leur nom
+! --------------------------------------------------------
+! Doivent etre dissocies en *.des et *.lfi et
+! rentres en ordre chronologique (1 / 1 ligne)
+!
+PRINT *,' ENTER NUMBER OF INPUT FM FILES'
+READ(5,*)NNBF
+YCAR80(1:LEN(YCAR80))=' '
+WRITE(YCAR80,*)NNBF
+YCAR80=ADJUSTL(YCAR80)
+WRITE(80,'(A80)')YCAR80
+
+DO J=1,NNBF
+ PRINT *,' ENTER FM FILE NAME'
+ READ(5,'(A28)')CNAMFILED(J)
+ YCAR80(1:LEN(YCAR80))=' '
+ YCAR80=CNAMFILED(J)
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ENDDO
+!
+!
+!* 3. Lecture du nom du fichier diachronique a creer
+! ----------------------------------------------
+!
+
+PRINT *,' ENTER DIACHRONIC FILE NAME'
+READ(5,'(A28)')CFILEDIA
+YCAR80(1:LEN(YCAR80))=' '
+YCAR80=CFILEDIA
+YCAR80=ADJUSTL(YCAR80)
+WRITE(80,'(A80)')YCAR80
+!
+!* 4. Ouverture du fichier correspondant au listing
+! ---------------------------------------------
+!
+CLUOUTD='LISTING_DIA'
+CALL FMATTR(CLUOUTD,CLUOUTD,NLUOUTD,NRESP)
+OPEN(UNIT=NLUOUTD,FILE=CLUOUTD,FORM='FORMATTED')
+!
+!* 5. Boucle sur les fichiers a lire
+! ------------------------------
+!
+DO J=1,NNBF
+
+ CLFIFMD(J)=ADJUSTL(ADJUSTR(CNAMFILED(J))//'.lfi')
+ CDESFMD(J)=ADJUSTL(ADJUSTR(CNAMFILED(J))//'.des')
+
+!
+!* 5.1 Ouverture des fichiers LFIFM et DESFM
+!
+ CSTATU='OLD'
+ NVERB=5
+! Modif demandee par Nicole Asencio. 28/9/98
+ NFTYPE=2
+! NFTYPE=0
+ CALL FMOPEN(CNAMFILED(J),CSTATU,CLUOUTD,NNPRAR,NFTYPE,NVERB,NNINAR,NRESP)
+ IF(NRESP.NE.0)THEN
+ WRITE(0,*)'BUG OPENING LFIFM FILE ',CLFIFMD(J),' RETURN CODE= ',NRESP
+ END IF
+!
+!* 5.2 Fermeture du fichier DESFM (ACTUELLEMENT NON INTEGRE DANS LE
+! FICHIER DIACHRONIQUE)
+! en 5.6 avec LFIFM par FMCLOS
+!
+!* 5.3 Lecture du numero, nom et longueur des enregistrements
+! Memorisation dans les tableaux NNUMT,CRECFM2T,NSIZT
+!
+!
+ GDTOUT=.TRUE.
+ CALL FMLOOK(CLFIFMD(J),CLUOUTD,INUMER,NRESP)
+ CALL JDLFILAF(NRESP,INUMER,GDTOUT)
+!
+ YFICJD(J)='FICJD'
+ YFICJDOUT(J)='FICJDOUT'
+ CALL FMATTR(YFICJD(J),YFICJDOUT(J),IFICJD(J),NRESP)
+ OPEN(UNIT=IFICJD(J),FILE=YFICJD(J),FORM='FORMATTED',STATUS='OLD')
+!
+ NNB=0
+ DO JJ=1,10000
+ READ(IFICJD(J),*,END=99)INUM,YRECFM2,ISIZ
+ NNB=NNB+1
+ ENDDO
+99 CONTINUE
+
+ IF(J == 1)THEN
+ INBM=NNB
+ ENDIF
+
+ WRITE(NLUOUTD,*)' ******** FICHIER N: ',J,CNAMFILED(J)(1:LEN_TRIM(CNAMFILED(J))), &
+ ' NB ENR. ',NNB
+ WRITE(NLUOUTD,*)' ******** '
+!
+ REWIND(IFICJD(J))
+!
+ IF(J == 1)THEN
+ ALLOCATE(NNUMT(NNB+100,100),NSIZT(NNB+100,100),NLENC(NNB+100,100))
+ ALLOCATE(CRECFM2T(NNB+100,100))
+ ENDIF
+!
+ DO JJ=1,NNB
+ READ(IFICJD(J),*)NNUMT(JJ,J),CRECFM2T(JJ,J),NSIZT(JJ,J)
+ ALLOCATE(IWORK(NSIZT(JJ,J)))
+ CALL LFILEC(NRESP,INUMER,CRECFM2T(JJ,J),IWORK,NSIZT(JJ,J))
+ NLENC(JJ,J)=IWORK(2) ! longueur de la zone commentaire
+! Determination de la longueur de la zone de donnees
+! 2 = 1er mot : numero de grille et 2eme mot : longueur de la zone commentaire
+ NSIZT(JJ,J)=NSIZT(JJ,J)-2-NLENC(JJ,J)
+ CALL GET_COMPHEADER(IWORK(3+NLENC(JJ,J)),NSIZT(JJ,J),INEWSIZE,ITYPCOD)
+ IF (INEWSIZE >= 0) THEN ! compressed field found
+ WRITE (NLUOUTD,*) TRIM(CRECFM2T(JJ,J)),' is compressed (old/new SIZE):',NSIZT(JJ,J),INEWSIZE
+ NSIZT(JJ,J)=INEWSIZE
+ END IF
+ DEALLOCATE(IWORK)
+ ENDDO
+!
+ CLOSE (IFICJD(J))
+ CALL FMFREE(YFICJD(J),YFICJDOUT(J),NRESP)
+
+! Verification de l'egalite du nombre d'enregistrements dans les differents
+! fichiers
+
+ IF(J > 1)THEN
+ IF(INBM /= NNB)THEN
+ WRITE(NLUOUTD,*)' ******************************************'
+ WRITE(NLUOUTD,*)' Nb enregistrents different (/ 1er fichier)'
+ WRITE(NLUOUTD,*)' ******************************************'
+ WRITE(NLUOUTD,*)' ( - = absence par rapport au 1er fichier, + = ajout)'
+ WRITE(NLUOUTD,*)' ( + ne sont pas integres dans le fichier diachronique)'
+ ENDIF
+ ENDIF
+
+! Verification de l'identite des enregistrements dans les differents fichiers
+
+ IF(J > 1)THEN
+ IF(INBM /= NNB)THEN
+ IF (INBM > NNB)THEN
+ DO JJ=1,INBM
+ GOK=.FALSE.
+ DO JA=1,NNB
+ IF(CRECFM2T(JJ,1) == CRECFM2T(JA,J))THEN
+ GOK=.TRUE.
+ EXIT
+ ELSE
+ CYCLE
+ ENDIF
+ ENDDO
+ IF(.NOT.GOK)THEN
+ NNUMT(JJ,1)=0
+ WRITE(NLUOUTD,*)' - ',CRECFM2T(JJ,1)
+ ENDIF
+ ENDDO
+
+ ELSE
+
+ DO JJ=1,NNB
+ GOK=.FALSE.
+ DO JA=1,INBM
+ IF(CRECFM2T(JJ,J) == CRECFM2T(JA,1))THEN
+ GOK=.TRUE.
+ EXIT
+ ELSE
+ CYCLE
+ ENDIF
+ ENDDO
+ IF(.NOT.GOK)THEN
+ WRITE(NLUOUTD,*)' + ',CRECFM2T(JJ,J)
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+!
+!* 5.4 Lecture et ecriture des parametres "intouchables"
+! 5.40 lecture
+!
+ CALL READ_DIMGRIDREF_FM2DIA(J,CNAMFILED(J),CLUOUTD)
+!
+! 5.41 Writing or checking DIM., GRID., REF. VARIABLES
+!
+ IF(J == 1)THEN ! premier fichier
+! resolution degradee
+ IX=1 ; IY=1 ; IZ=1
+ IF (NIMAX>1) THEN
+ print *,'- DO YOU WANT COARSER RESOLUTION along X ? (y/n)'
+ READ(5,*)YREPON
+ YCAR80(1:LEN(YCAR80))=' '
+ YCAR80=YREPON
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ IF(YREPON == 'y' .OR. YREPON == 'yes' .OR. YREPON == 'o' .OR. &
+ YREPON == 'oui')THEN
+ print *,' Enter the ratio IX (1 point on IX points kept) '
+ READ(5,*) IX
+ YCAR80(1:LEN(YCAR80))=' '
+ WRITE(YCAR80,*)IX
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ ENDIF
+ ENDIF
+ IF (IX>1) THEN
+ IIMAXOUT=((NIMAX+2*JPHEXT-1)/IX +1) -2*JPHEXT
+ IF (IIMAXOUT<=0) THEN
+ print *,'TOO COARSER RESOLUTION along X for ',NIMAX,'points'
+ STOP
+ ENDIF
+ print*,'old X physical domain: ',NIMAX,'pts - new one: ',IIMAXOUT
+ ENDIF
+ !
+ IF (NJMAX>1) THEN
+ print *,'- DO YOU WANT COARSER RESOLUTION along Y ? (y/n)'
+ READ(5,*)YREPON
+ YCAR80(1:LEN(YCAR80))=' '
+ YCAR80=YREPON
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ IF(YREPON == 'y' .OR. YREPON == 'yes' .OR. YREPON == 'o' .OR. &
+ YREPON == 'oui')THEN
+ print *,' Enter the ratio IY (1 point on IY points kept) '
+ READ(5,*) IY
+ YCAR80(1:LEN(YCAR80))=' '
+ WRITE(YCAR80,*)IY
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ ENDIF
+ ENDIF
+ IF (IY>1) THEN
+ IJMAXOUT=((NJMAX+2*JPHEXT-1)/IY +1) -2*JPHEXT
+ IF (IJMAXOUT<=0) THEN
+ print *,'TOO COARSER RESOLUTION along Y for ',NJMAX,'points'
+ STOP
+ ENDIF
+ print*,'old Y physical domain: ',NJMAX,'pts - new one: ',IJMAXOUT
+ ENDIF
+ !
+ !print *,'- DO YOU WANT COARSER RESOLUTION along Z ? (y/n)'
+ !READ(5,*)YREPON
+ !IF(YREPON == 'y' .OR. YREPON == 'yes' .OR. YREPON == 'o' .OR. &
+ ! YREPON == 'oui')THEN
+ ! print *,' Enter the ratio IZ (1 point on IZ points kept) '
+ ! READ(5,*) IZ
+ !ENDIF
+ !IF (IZ>1) THEN
+ ! IKMAXOUT=((NKMAX+2*JPVEXT-1)/IZ +1) -2*JPVEXT
+ ! IF (IKMAXOUT<=0) THEN
+ ! print *,'TOO COARSER RESOLUTION along Y for ',NKMAX,'points'
+ ! STOP
+ ! ENDIF
+ ! print*,'old Z physical domain: ',NKMAX,'pts - new one: ',IKMAXOUT
+ !ENDIF
+ !
+ IF (IX>1) THEN
+ ALLOCATE(ZXHAT(SIZE(XXHAT)))
+ ZXHAT(:)=XXHAT(:)
+ DEALLOCATE(XXHAT)
+ ALLOCATE(XXHAT(IIMAXOUT+2*JPHEXT))
+ XXHAT(:)=ZXHAT(1:NIMAX+2*JPHEXT:IX)
+ ENDIF
+ IF (IY>1) THEN
+ ALLOCATE(ZYHAT(SIZE(XYHAT)))
+ ZYHAT(:)=XYHAT(:)
+ DEALLOCATE(XYHAT)
+ ALLOCATE(XYHAT(IJMAXOUT+2*JPHEXT))
+ XYHAT(:)=ZYHAT(1:NJMAX+2*JPHEXT:IY)
+ ENDIF
+ ixyz=0
+ IF (IX>1) ixyz=1
+ IF (IY>1) ixyz=ixyz+10
+ IF (ixyz>0) THEN
+ ALLOCATE(ZZS(SIZE(XZS,1),SIZE(XZS,2)))
+ ZZS(:,:)=XZS(:,:)
+ DEALLOCATE(XZS)
+ ENDIF
+ SELECT CASE(ixyz)
+ CASE (1) !X
+ ALLOCATE(XZS(IIMAXOUT+2*JPHEXT,SIZE(ZZS,2)))
+ DO J2=1,SIZE(ZZS,2)
+ XZS(:,J2)=ZZS(1:NIMAX+2*JPHEXT:IX,J2)
+ END DO
+ IIMAXIN=NIMAX
+ NIMAX =IIMAXOUT
+ CASE (10) !Y
+ ALLOCATE(XZS(SIZE(ZZS,1),IJMAXOUT+2*JPHEXT))
+ DO J1=1,SIZE(ZZS,1)
+ XZS(J1,:)=ZZS(J1,1:NJMAX+2*JPHEXT:IY)
+ END DO
+ IJMAXIN=NJMAX
+ NJMAX =IJMAXOUT
+ CASE (11) !X et Y
+ ALLOCATE(XZS(IIMAXOUT+2*JPHEXT,IJMAXOUT+2*JPHEXT))
+ I2=0
+ DO J2=1,SIZE(ZZS,2),IY
+ I2=I2+1
+ XZS(:,I2)=ZZS(1:NIMAX+2*JPHEXT:IX,J2)
+ END DO
+ IIMAXIN=NIMAX
+ NIMAX =IIMAXOUT
+ IJMAXIN=NJMAX
+ NJMAX =IJMAXOUT
+ END SELECT
+ !IF (IZ>1) THEN
+ ! ALLOCATE(ZZHAT(SIZE(XZHAT)))
+ ! ZZHAT(:)=XZHAT(:)
+ ! DEALLOCATE(XZHAT)
+ ! ALLOCATE(XZHAT(IKMAXOUT+2*JPVEXT))
+ ! XZHAT(:)=ZZHAT(1:NKMAX+2*JPVEXT:IZ)
+ ! IKMAXIN=NKMAX
+ ! NKMAX =IKMAXOUT
+ !ENDIF
+ !
+ CALL WRITE_DIMGRIDREF
+ !
+ IF (IX>1) THEN
+ NIMAX=IIMAXIN
+ DEALLOCATE(XXHAT)
+ ALLOCATE(XXHAT(SIZE(ZXHAT)))
+ XXHAT(:)=ZXHAT(:)
+ DEALLOCATE(ZXHAT)
+ ENDIF
+ IF (IY>1) THEN
+ NJMAX=IJMAXIN
+ DEALLOCATE(XYHAT)
+ ALLOCATE(XYHAT(SIZE(ZYHAT)))
+ XYHAT(:)=ZYHAT(:)
+ DEALLOCATE(ZYHAT)
+ ENDIF
+ !IF (IZ>1) THEN
+ ! NKMAX=IKMAXIN
+ ! DEALLOCATE(XZHAT)
+ ! ALLOCATE(XZHAT(SIZE(ZZHAT)))
+ ! XZHAT(:)=ZZHAT(:)
+ ! DEALLOCATE(ZZHAT)
+ !ENDIF
+ IF (ixyz>0) THEN
+ DEALLOCATE(XZS)
+ ALLOCATE(XZS(SIZE(ZZS,1),SIZE(ZZS,2)))
+ XZS(:,:)=ZZS(:,:)
+ DEALLOCATE(ZZS)
+ ENDIF
+ !
+ ALLOCATE(IIMAX(NNBF),IJMAX(NNBF),IKMAX(NNBF),ZTIMECUR(NNBF))
+ ALLOCATE(ZLON0(NNBF),ZLAT0(NNBF),ZLONOR(NNBF),ZLATOR(NNBF), &
+ ZRPK(NNBF),ZBETA(NNBF) )
+ ALLOCATE(OCARTESIAN(NNBF))
+ ENDIF
+!
+ IIMAX(J)=NIMAX ; IJMAX(J)=NJMAX ; IKMAX(J)=NKMAX
+ ZTIMECUR(J)=TDTCUR%TIME
+ ZLON0(J)=XLON0 ; ZLAT0(J)=XLAT0
+ ZLONOR(J)=XLONOR ; ZLATOR(J)=XLATOR
+ ZRPK(J)=XRPK ; ZBETA(J)=XBETA
+ OCARTESIAN(J)=LCARTESIAN
+!
+ IF(J > 1)THEN ! fichiers suivants
+ !
+ IF(IIMAX(J) /= IIMAX(1))THEN
+ PRINT *,' J IIMAX(J) IIMAX(1) ',J,IIMAX(J),IIMAX(1)
+ ENDIF
+ IF(IJMAX(J) /= IJMAX(1))THEN
+ PRINT *,' J IJMAX(J) IJMAX(1) ',J,IJMAX(J),IJMAX(1)
+ ENDIF
+ IF(IKMAX(J) /= IKMAX(1))THEN
+ PRINT *,' J IKMAX(J) IKMAX(1) ',J,IKMAX(J),IKMAX(1)
+ ENDIF
+ IF(ZTIMECUR(J) /= ZTIMECUR(1))THEN
+ PRINT *,' J ZTIMECUR(J) ZTIMECUR(1) ',J,ZTIMECUR(J),ZTIMECUR(1)
+ ENDIF
+ IF(ZLON0(J) /= ZLON0(1))THEN
+ PRINT *,' J ZLON0(J) ZLON0(1) ',J,ZLON0(J),ZLON0(1)
+ ENDIF
+ IF(ZRPK(J) /= ZRPK(1))THEN
+ PRINT *,' J ZRPK(J) ZRPK(1) ',J,ZRPK(J),ZRPK(1)
+ ENDIF
+ IF(ZLONOR(J) /= ZLONOR(1))THEN
+ PRINT *,' J ZLONOR(J) ZLONOR(1) ',J,ZLONOR(J),ZLONOR(1)
+ ENDIF
+ IF(ZLATOR(J) /= ZLATOR(1))THEN
+ PRINT *,' J ZLATOR(J) ZLATOR(1) ',J,ZLATOR(J),ZLATOR(1)
+ ENDIF
+ IF(ZLAT0(J) /= ZLAT0(1))THEN
+ PRINT *,' J ZLAT0(J) ZLAT0(1) ',J,ZLAT0(J),ZLAT0(1)
+ ENDIF
+ IF(ZBETA(J) /= ZBETA(1))THEN
+ PRINT *,' J ZBETA(J) ZBETA(1) ',J,ZBETA(J),ZBETA(1)
+ ENDIF
+ IF((OCARTESIAN(J) .AND..NOT. OCARTESIAN(1)) .OR. &
+ (.NOT. OCARTESIAN(J) .AND. OCARTESIAN(1)))THEN
+ PRINT *,' J OCARTESIAN(J) OCARTESIAN(1) ',J,OCARTESIAN(J),OCARTESIAN(1)
+ ENDIF
+ !
+ ENDIF
+!
+ IF(J == NNBF)THEN ! dernier fichier
+ DEALLOCATE(IIMAX,IJMAX,IKMAX,ZTIMECUR)
+ DEALLOCATE(ZLON0,ZRPK,ZLONOR,ZLATOR,ZLAT0,ZBETA)
+ DEALLOCATE(OCARTESIAN)
+ END IF
+!
+! 5.42 Eventuelle eliminination de certains parametres ds le fic. diach.
+!
+ IF(J == 1)THEN
+
+ print *,'- DELETION OF PARAMETERS AT TIME t-dt ? (enter 1) '
+ print *,'- DELETION OF PARAMETERS AT TIME t ? (enter 2) '
+ print *,'- NO DELETION ? (enter 0) '
+ READ(5,*)ICODEL
+ YCAR80(1:LEN(YCAR80))=' '
+ WRITE(YCAR80,*)ICODEL
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+
+ IF(ICODEL == 0)THEN
+ IEL_OR_SEL=0 ! conv2dia.elim
+ ELSE
+ print *,'- Do you want to ELIM or to SELECT parameters ? (E/S)'
+ READ(5,*)YREPON
+ YCAR80(1:LEN(YCAR80))=' '
+ YCAR80=YREPON
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ IF(YREPON == 'E' .OR. YREPON == 'e')THEN
+ IEL_OR_SEL=0 ! conv2dia.elim
+ print*,'as conv2dia.elim'
+ ELSE IF(YREPON == 'S' .OR. YREPON == 's')THEN
+ IEL_OR_SEL=1 ! conv2dia.select
+ print*,'as conv2dia.select'
+ ELSE
+ STOP 'Bad answer'
+ ENDIF
+ ENDIF
+ !
+ ALLOCATE(YRECT(SIZE(CRECFM2T,1)))
+ YRECT(:)(1:LEN(YRECT))=' '
+ INB=0
+ DO JI=1,NNB
+ IF(NNUMT(JI,J) /= 0)THEN
+ INB=INB+1
+ YRECT(INB)=CRECFM2T(JI,J)
+ YRECT(INB)=ADJUSTL(YRECT(INB))
+! print *,' INB, YRECT ',INB,YRECT(INB)
+ ENDIF
+ ENDDO
+ ALLOCATE(YRECID(INB))
+ YRECID(:)(1:LEN(YRECID))=' '
+ IF (IEL_OR_SEL==1) THEN ! conv2dia.select
+ ALLOCATE(YKEEP(INB))
+ YKEEP(:)(1:LEN(YKEEP))=' '
+ IKEEP=1
+ YKEEP(IKEEP)='ZS'
+ YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
+ IKEEP=IKEEP+1
+ YKEEP(IKEEP)='ZSMT'
+ YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
+ ENDIF
+ !
+ IID=0
+ DO JI = 1,INB-1
+ YREF(1:LEN(YREF))=' '
+ IL=LEN_TRIM(YRECT(JI))-1
+ YREF(1:IL)=YRECT(JI)(1:IL)
+! YREF=ADJUSTL(YREF)
+ IF(YRECT(JI)(IL+1:IL+1) == 'M')THEN
+ DO JIP1=JI+1,INB
+ IL=LEN_TRIM(YRECT(JIP1))-1
+ IF(YRECT(JIP1)(1:IL) == YREF .AND. YRECT(JIP1)(IL+1:IL+1)=='T' )THEN
+ IF ( IEL_OR_SEL==0 .OR. & ! conv2dia.elim
+ (IEL_OR_SEL==1 & ! conv2dia.select
+ .AND.(YREF(1:IL)=='PABS' & ! et PABS
+ .OR.YREF(1:IL)=='POVO' & ! ou POVO
+ .OR.YREF(1:IL)=='TH' ))) THEN ! ou TH
+ IID=IID+1
+ YRECID(IID)=' '
+ YRECID(IID)=YREF
+ YRECID(IID)=ADJUSTL(YRECID(IID))
+ !
+ IF (IEL_OR_SEL==1) THEN ! conv2dia.select
+ IKEEP=IKEEP+1
+ YKEEP(IKEEP)=YREF
+ YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
+ ENDIF
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDDO
+ IF(ICODEL == 0)THEN
+ ELSE IF(ICODEL == 1)THEN
+ DO JI=1,IID
+ YRECID(JI)=ADJUSTL(ADJUSTR(YRECID(JI))//'M')
+ ENDDO
+ IF (IEL_OR_SEL==1) THEN ! conv2dia.select
+ DO JI=3,IKEEP
+ YKEEP(JI)=ADJUSTL(ADJUSTR(YKEEP(JI))//'T')
+ ENDDO
+ ENDIF
+ ELSE IF(ICODEL == 2)THEN
+ DO JI=1,IID
+ YRECID(JI)=ADJUSTL(ADJUSTR(YRECID(JI))//'T')
+ ENDDO
+ IF (IEL_OR_SEL==1) THEN ! conv2dia.select
+ DO JI=3,IKEEP
+ YKEEP(JI)=ADJUSTL(ADJUSTR(YKEEP(JI))//'M')
+ ENDDO
+ ENDIF
+ ENDIF
+ !
+ I4=0
+ YPRI=' '
+ IF(ICODEL /= 0)THEN
+
+ print *,' PARAMETRES RESTANTS'
+ DO JI = 1,NNB
+ DO JIP1 = 1,IID
+ IF(CRECFM2T(JI,J) == YRECID(JIP1))THEN
+ NNUMT(JI,J)=0
+ EXIT
+ ENDIF
+ ENDDO
+ IF(NNUMT(JI,J) /= 0)THEN
+ I4=I4+1
+ YPRI(I4)=CRECFM2T(JI,J)
+ IF(I4 == 5 .OR. JI == NNB)THEN
+ print 10,YPRI
+ I4=0
+ YPRI=' '
+ ENDIF
+ ENDIF
+ ENDDO
+
+ IF (IEL_OR_SEL==1) THEN ! conv2dia.select
+ print *,' '
+ print *,' Some parameters are automatically recorded (for vert. interpolations):'
+ print *,' --> ',(YKEEP(JI)(1:LEN_TRIM(YKEEP(JI))+1),JI=1,IKEEP)
+ print *,' '
+ ENDIF
+
+ YREPON(1:LEN(YREPON))=' '
+ IF (IEL_OR_SEL==0) THEN ! conv2dia.elim
+ print *,'- Do you want to SUPPRESS others parameters ? (y/n) '
+ ELSE IF (IEL_OR_SEL==1) THEN ! conv2dia.select
+ print *,'- Do you want to KEEP others parameters ? (y/n) '
+ ENDIF
+ READ(5,*)YREPON
+ YCAR80(1:LEN(YCAR80))=' '
+ YCAR80=YREPON
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ IF(YREPON == 'y' .OR. YREPON == 'yes' .OR. YREPON == 'o' .OR. &
+ YREPON == 'oui' .OR. YREPON =='Y' .OR. YREPON =='YES' )THEN
+ print *,'- Enter their names in UPPERCASE (1/1 line) '
+ print *,'End by END '
+ IF (IEL_OR_SEL==1) THEN ! conv2dia.select
+ IF(ICODEL == 1)THEN
+ print *,' NOTA: if you want to plot RS ,don''t forget : RVT,UT,VT'
+ ELSE IF(ICODEL == 2)THEN
+ print *,' NOTA: if you want to plot RS ,don''t forget : RVM,UM,VM'
+ ENDIF
+ print *,' '
+ ENDIF
+ DO JI=1,1000
+ YREF=' '
+ READ(5,*)YREF
+ YCAR80(1:LEN(YCAR80))=' '
+ IF (IEL_OR_SEL==0) THEN ! conv2dia.elim
+ IID=IID+1
+ YRECID(IID)=' '
+ YRECID(IID)=ADJUSTL(YREF)
+ YCAR80=YRECID(IID)
+ ELSE IF (IEL_OR_SEL==1) THEN ! conv2dia.select
+ IKEEP=IKEEP+1
+ YKEEP(IKEEP)=' '
+ YKEEP(IKEEP)=ADJUSTL(YREF)
+ YCAR80=YKEEP(IKEEP)
+ ENDIF
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ IF(YREF == 'END')THEN
+ CLOSE(80)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ !
+ 10 FORMAT(1X,5A15)
+ I4=0
+! YPRI(:)=' '
+ DO JI = 1,NNB
+ IF (IEL_OR_SEL==0) THEN ! conv2dia.elim
+ DO JIP1 = 1,IID
+ IF(CRECFM2T(JI,J) == YRECID(JIP1))THEN
+ NNUMT(JI,J)=0
+ EXIT
+ ENDIF
+ ENDDO
+ ELSE IF (IEL_OR_SEL==1) THEN ! conv2dia.select
+ IF(NNUMT(JI,J) /=0) THEN
+ IOK=0
+ DO JIP1 = 1,IKEEP
+ IF(CRECFM2T(JI,J) == YKEEP(JIP1))THEN
+ IOK=1
+ EXIT
+ ENDIF
+ ENDDO
+ IF(IOK==0)THEN
+ NNUMT(JI,J)=0
+ ENDIF
+ ENDIF
+ ENDIF
+ IF(NNUMT(JI,J) /= 0)THEN
+ IF(I4 == 5)THEN
+ print 10,YPRI
+ I4=0
+! YPRI(1:5)=' '
+ ENDIF
+ I4=I4+1
+ YPRI(I4)=CRECFM2T(JI,J)
+ ENDIF
+ IF(JI == NNB)THEN
+ print 10,YPRI(1:I4)
+ ENDIF
+ ENDDO
+
+ ENDIF ! (ICODEL/=0)
+!
+!
+! 5.43 Elimination des dates
+!
+ DO JI=1,NNB
+ IDA=INDEX(CRECFM2T(JI,J),'%TDA')
+ IF(IDA /= 0)THEN
+ NNUMT(JI,J)=0
+ ENDIF
+ IDA=INDEX(CRECFM2T(JI,J),'%TIM')
+ IF(IDA /= 0)THEN
+ NNUMT(JI,J)=0
+ ENDIF
+! 5.44 Elimination des champs dont le nom depasse 13 caracteres
+! (13 = 16 (=max.LEN(RECFM)=JPNCPN) -3 (=LEN('.TYpe','.DIm','.TItre',
+! '.UNite','.COmment','.PRoc1','.TRajt','.DAtim'))
+ IF (LEN_TRIM(CRECFM2T(JI,J))>13 .AND. NNUMT(JI,J)/=0) THEN
+ NNUMT(JI,J)=0
+ print*,'Variable ',CRECFM2T(JI,J), ' not written (name too long)'
+ WRITE(NLUOUTD,*)'Variable ',CRECFM2T(JI,J), ' not written (name too long)'
+ END IF
+ ENDDO
+ ENDIF !(J==1)
+!
+!
+!* 5.5 Lecture et ecriture des autres champs
+!
+ CALL WRITE_OTHERSFIELDS(J,CFILEDIA,CLUOUTDIA,IX,IY,IZ)
+!
+!* 5.6 Fermeture du Fichier d'entree traite et liberation des unites
+! logiques correspondantes (DES et LFI)
+!
+ CALL FMCLOS(CNAMFILED(J),'KEEP',CLUOUTD,NRESP)
+!
+ENDDO
+!
+!* 6. Terminaison du fichier diachronique et impression du nom des
+! groupes enregistres
+! -------------------------------------------------------------
+!
+CALL MENU_DIACHRO(CFILEDIA,CLUOUTDIA,'END')
+CALL MENU_DIACHRO(CFILEDIA,CLUOUTDIA,'READ')
+
+CLOSE(NLUOUTD)
+CALL FMFREE(CLUOUTD,CLUOUTD,NRESP)
+!
+!* 7. Fermeture du fichier diachronique
+! ---------------------------------
+!
+CALL FMCLOS(CFILEDIA,'KEEP',CLUOUTDIA,NRESP)
+!
+!------------------------------------------------------------------------------
+!
+!* 4. EPILOGUE
+! --------
+
+STOP
+
+END PROGRAM FM2DIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/conv2dia.select.f90 b/LIBTOOLS/tools/diachro/src/FM2DIA/conv2dia.select.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e3e2f8f69ae40e8b33c83d232c7aa07df4322275
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/conv2dia.select.f90
@@ -0,0 +1,641 @@
+! ######spl
+ PROGRAM FM2DIACHRO
+! ###################
+!
+!!**** *FM2DIACHRO* - Conversion des fichiers synchrones LFIFM en
+!! fichiers de type diachronique (LFIFM egalement)
+!!
+!!
+!! PURPOSE
+!! -------
+!
+! Convertit 1 (ou plusieurs fichiers synchrones correspondant a
+! des sorties successives d'un meme run) en 1 fichier diachronique
+!
+!!** METHOD
+!! ------
+!!
+! La routine LFILAF (du logiciel LFI) modifiee (--> JDLFILAF) pour
+! l'ouverture d'un fichier FICJD ecrit dans celui-ci le numero,
+! le nom et la longueur totale des enregistrements.
+! Puis un appel a la routine LFILEC permet de lire dans le 2eme mot
+! de chaque enregistrement la longueur du champ commentaire (qui n'est
+! pas necessairement constante) et donc de deduire par soustraction
+! la longueur du champ physique enregistre
+! de sorte que l'on possede toutes les informations necessaires a la
+! lecture avec FMREAD des enregistrements d'un fichier LFIFM dont on ne
+! connait pas a priori le contenu. (du moins pour les infos reelles)
+! Dans un premier temps, on ecrit dans le fichier diachonique avec
+! la routine WRITE_LFIFM1_FORDIACHRO_CV l'entete des fichiers d'entree
+! en particulier les parametres de grille, l'etat de reference ...
+! Puis en bouclant sur le nombre de fichiers a traiter et le nombre
+! d'enregistrements de chacun, on lit chaque champ et on regroupe
+! progressivement dans un enregistrement du fichier diachronique unique
+! pour un meme parametre les differentes echeances trouvees.
+! ACTUELLEMENT (Avril 97) SONT PRIS EN COMPTE LES CHAMPS DE LONGUEUR
+! IIU*IJU*IKU , IIU*IJU et 1
+!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHORS
+!! -------
+!! J. Duron *Lab. Aerologie*
+!!
+!! Copyright 1994, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/01/96
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF
+USE MODD_DIM1, ONLY: NIMAX,NJMAX,NKMAX
+USE MODD_GRID ! XLON0,XLAT0, XBETA,XRPK
+USE MODD_GRID1 ! XLONOR,XLATOR
+USE MODD_TIME1 ! TDTCUR
+!
+USE MODD_DIACHRO
+USE MODD_OUT_DIA
+USE MODD_REA_LFI
+USE MODD_DIMGRID_FORDIACHRO
+!USE MODI_READ_DESFM
+USE MODI_READ_DIMGRIDREF_FM2DIA
+USE MODI_WRITE_DIMGRIDREF
+USE MODI_WRITE_OTHERSFIELDS
+USE MODI_MENU_DIACHRO
+USE MODI_INI_CST
+
+IMPLICIT NONE
+!
+!* 0.1 Local variables declarations
+!
+INTEGER :: ILUDES ! Logical unit number for the DES file
+INTEGER :: INUMER
+
+INTEGER,DIMENSION(50) :: IFICJD
+
+INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE :: IWORK
+
+INTEGER :: INUM, ISIZ, INBM, IKEEP, IOK
+
+INTEGER :: IRESP, IVAR
+INTEGER :: INEWSIZE, ITYPCOD
+
+INTEGER :: JJ, J, JA
+INTEGER :: INB, IID, JI, JIP1, ICODEL, IL, IDA
+INTEGER :: I4
+INTEGER,DIMENSION(:), ALLOCATABLE :: IIMAX, IJMAX, IKMAX
+REAL,DIMENSION(:), ALLOCATABLE :: ZTIMECUR,ZLON0,ZRPK,ZLONOR,ZLATOR,ZLAT0,ZBETA
+LOGICAL,DIMENSION(:), ALLOCATABLE :: OCARTESIAN
+LOGICAL :: GDTOUT, GOK
+
+CHARACTER*16 :: YRECFM, YRECFM2
+CHARACTER*3 :: YREPON
+CHARACTER*16 :: YREF
+CHARACTER*16 :: YCOMMENT
+CHARACTER*80 :: YCAR80
+CHARACTER*16,DIMENSION(50) :: YFICJD, YFICJDOUT
+CHARACTER*16,DIMENSION(:), ALLOCATABLE,SAVE :: YRECT, YRECID, YKEEP
+CHARACTER*16,DIMENSION(4) :: YPRI
+
+!-------------------------------------------------------------------------------
+!
+!* 1. Definition du type de traitement et init du fichier de constantes
+! -----------------------------------------------------------------
+!
+CPROGRAM='FM2DIA'
+!
+CCONF='POSTP'
+CALL INI_CST
+OPEN(80,FILE='dirconv.select',FORM='FORMATTED')
+!
+!
+!* 2. Lecture du nombre de fichiers a regrouper et de leur nom
+! --------------------------------------------------------
+! Doivent etre dissocies en *.des et *.lfi et
+! rentres en ordre chronologique (1 / 1 ligne)
+!
+PRINT *,' ENTER NUMBER OF INPUT FM FILES'
+READ(5,*)NNBF
+YCAR80(1:LEN(YCAR80))=' '
+WRITE(YCAR80,*)NNBF
+YCAR80=ADJUSTL(YCAR80)
+WRITE(80,'(A80)')YCAR80
+
+DO J=1,NNBF
+ PRINT *,' ENTER FM FILE NAME'
+ READ(5,'(A28)')CNAMFILED(J)
+ YCAR80(1:LEN(YCAR80))=' '
+ YCAR80=CNAMFILED(J)
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ENDDO
+!
+!
+!* 3. Lecture du nom du fichier diachronique a creer
+! ----------------------------------------------
+!
+
+PRINT *,' ENTER DIACHRONIC FILE NAME'
+READ(5,'(A28)')CFILEDIA
+YCAR80(1:LEN(YCAR80))=' '
+YCAR80=CFILEDIA
+YCAR80=ADJUSTL(YCAR80)
+WRITE(80,'(A80)')YCAR80
+!
+!* 4. Ouverture du fichier correspondant au listing
+! ---------------------------------------------
+!
+CLUOUTD='LISTING_DIA'
+CALL FMATTR(CLUOUTD,CLUOUTD,NLUOUTD,NRESP)
+OPEN(UNIT=NLUOUTD,FILE=CLUOUTD,FORM='FORMATTED')
+! print *,' CLUOUT ',CLUOUTD
+!
+!* 5. Boucle sur les fichiers a lire
+! ------------------------------
+!
+DO J=1,NNBF
+
+ CLFIFMD(J)=ADJUSTL(ADJUSTR(CNAMFILED(J))//'.lfi')
+ CDESFMD(J)=ADJUSTL(ADJUSTR(CNAMFILED(J))//'.des')
+
+!
+!* 5.1 Ouverture des fichiers LFIFM et DESFM
+!
+ CSTATU='OLD'
+ NVERB=5
+! Modif demandee par Nicole Asencio. 28/9/98
+ NFTYPE=2
+! NFTYPE=0
+ CALL FMOPEN(CNAMFILED(J),CSTATU,CLUOUTD,NNPRAR,NFTYPE,NVERB,NNINAR,NRESP)
+ IF(NRESP.NE.0)THEN
+ WRITE(0,*)'BUG OPENING LFIFM FILE ',CLFIFMD(J),' RETURN CODE= ',NRESP
+ END IF
+!
+!* 5.2 Fermeture du fichier DESFM (ACTUELLEMENT NON INTEGRE DANS LE
+! FICHIER DIACHRONIQUE)
+!
+! (Contains namelists: Nam_lunitn + Nam_confn
+! + Nam_dynn + Nam_paramn + Nam_conf + Nam_dyn)
+!
+ CALL FMLOOK(CDESFMD(J),CDESFMD(J),ILUDES,NRESP)
+ CLOSE(ILUDES)
+!
+!* 5.3 Lecture du numero, nom et longueur des enregistrements
+! Memorisation dans les tableaux NNUMT,CRECFM2T,NSIZT
+!
+!
+ GDTOUT=.TRUE.
+ CALL FMLOOK(CLFIFMD(J),CLUOUTD,INUMER,NRESP)
+ CALL JDLFILAF(NRESP,INUMER,GDTOUT)
+!
+ YFICJD(J)='FICJD'
+ YFICJDOUT(J)='FICJDOUT'
+ CALL FMATTR(YFICJD(J),YFICJDOUT(J),IFICJD(J),NRESP)
+ OPEN(UNIT=IFICJD(J),FILE=YFICJD(J),FORM='FORMATTED',STATUS='OLD')
+!
+ NNB=0
+ DO JJ=1,10000
+ READ(IFICJD(J),*,END=99)INUM,YRECFM2,ISIZ
+ NNB=NNB+1
+ ENDDO
+99 CONTINUE
+
+ IF(J == 1)THEN
+ INBM=NNB
+ ENDIF
+
+ WRITE(NLUOUTD,*)' ******** FICHIER N: ',J,CNAMFILED(J)(1:LEN_TRIM(CNAMFILED(J))), &
+ ' NB ENR. ',NNB
+ WRITE(NLUOUTD,*)' ******** '
+
+ REWIND(IFICJD(J))
+!
+ IF(J == 1)THEN
+ ALLOCATE(NNUMT(NNB+100,50),NSIZT(NNB+100,50),NLENC(NNB+100,50))
+ ALLOCATE(CRECFM2T(NNB+100,50))
+ ENDIF
+ !
+ DO JJ=1,NNB
+ READ(IFICJD(J),*)NNUMT(JJ,J),CRECFM2T(JJ,J),NSIZT(JJ,J)
+ ALLOCATE(IWORK(NSIZT(JJ,J)))
+ CALL LFILEC(NRESP,INUMER,CRECFM2T(JJ,J),IWORK,NSIZT(JJ,J))
+ NLENC(JJ,J)=IWORK(2) ! longueur de la zone commentaire
+! Determination de la longueur de la zone de donnees
+! 2 = 1er mot : numero de grille et 2eme mot : longueur de la zone commentaire
+ NSIZT(JJ,J)=NSIZT(JJ,J)-2-NLENC(JJ,J)
+ CALL GET_COMPHEADER(IWORK(3+NLENC(JJ,J)),NSIZT(JJ,J),INEWSIZE,ITYPCOD)
+ IF (INEWSIZE >= 0) THEN ! compressed field found
+ WRITE (NLUOUTD,*) TRIM(CRECFM2T(JJ,J)),' is compressed (old/new SIZE):',NSIZT(JJ,J),INEWSIZE
+ NSIZT(JJ,J)=INEWSIZE
+ END IF
+ DEALLOCATE(IWORK)
+ ENDDO
+!
+ CLOSE (IFICJD(J))
+ CALL FMFREE(YFICJD(J),YFICJDOUT(J),NRESP)
+
+! Verification de l'egalite du nombre d'enregistrements dans les differents
+! fichiers
+
+ IF(J > 1)THEN
+ IF(INBM /= NNB)THEN
+ WRITE(NLUOUTD,*)' ******************************************'
+ WRITE(NLUOUTD,*)' Nb enregistrents different (/ 1er fichier)'
+ WRITE(NLUOUTD,*)' ******************************************'
+ WRITE(NLUOUTD,*)' ( - = absence par rapport au 1er fichier, + = ajout)'
+ WRITE(NLUOUTD,*)' ( + ne sont pas integres dans le fichier diachronique)'
+ ENDIF
+ ENDIF
+
+! Verification de l'identite des enregistrements dans les differents fichiers
+
+ IF(J > 1)THEN
+ IF(INBM /= NNB)THEN
+ IF (INBM > NNB)THEN
+ DO JJ=1,INBM
+ GOK=.FALSE.
+ DO JA=1,NNB
+ IF(CRECFM2T(JJ,1) == CRECFM2T(JA,J))THEN
+ GOK=.TRUE.
+ EXIT
+ ELSE
+ CYCLE
+ ENDIF
+ ENDDO
+ IF(.NOT.GOK)THEN
+ NNUMT(JJ,1)=0
+ WRITE(NLUOUTD,*)' - ',CRECFM2T(JJ,1)
+ ENDIF
+ ENDDO
+
+ ELSE
+
+ DO JJ=1,NNB
+ GOK=.FALSE.
+ DO JA=1,INBM
+ IF(CRECFM2T(JJ,J) == CRECFM2T(JA,1))THEN
+ GOK=.TRUE.
+ EXIT
+ ELSE
+ CYCLE
+ ENDIF
+ ENDDO
+ IF(.NOT.GOK)THEN
+ WRITE(NLUOUTD,*)' + ',CRECFM2T(JJ,J)
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+!
+!* 5.4 Lecture et ecriture des parametres "intouchables"
+!
+ CALL READ_DIMGRIDREF_FM2DIA(J,CNAMFILED(J),CLUOUTD)
+!
+! 5.41 Writing or checking DIM., GRID., REF. VARIABLES
+!
+ IF(J == 1)THEN ! premier fichier
+ CALL WRITE_DIMGRIDREF
+ ALLOCATE(IIMAX(NNBF),IJMAX(NNBF),IKMAX(NNBF),ZTIMECUR(NNBF))
+ ALLOCATE(ZLON0(NNBF),ZLAT0(NNBF),ZLONOR(NNBF),ZLATOR(NNBF), &
+ ZRPK(NNBF),ZBETA(NNBF) )
+ ALLOCATE(OCARTESIAN(NNBF))
+ ENDIF
+!
+ IIMAX(J)=NIMAX ; IJMAX(J)=NJMAX ; IKMAX(J)=NKMAX
+ ZTIMECUR(J)=TDTCUR%TIME
+ ZLON0(J)=XLON0 ; ZLAT0(J)=XLAT0
+ ZLONOR(J)=XLONOR ; ZLATOR(J)=XLATOR
+ ZRPK(J)=XRPK ; ZBETA(J)=XBETA
+ OCARTESIAN(J)=LCARTESIAN
+!
+ IF(J > 1)THEN ! fichiers suivants
+ !
+ IF(IIMAX(J) /= IIMAX(1))THEN
+ PRINT *,' J IIMAX(J) IIMAX(1) ',J,IIMAX(J),IIMAX(1)
+ ENDIF
+ IF(IJMAX(J) /= IJMAX(1))THEN
+ PRINT *,' J IJMAX(J) IJMAX(1) ',J,IJMAX(J),IJMAX(1)
+ ENDIF
+ IF(IKMAX(J) /= IKMAX(1))THEN
+ PRINT *,' J IKMAX(J) IKMAX(1) ',J,IKMAX(J),IKMAX(1)
+ ENDIF
+ IF(ZTIMECUR(J) /= ZTIMECUR(1))THEN
+ PRINT *,' J ZTIMECUR(J) ZTIMECUR(1) ',J,ZTIMECUR(J),ZTIMECUR(1)
+ ENDIF
+ IF(ZLON0(J) /= ZLON0(1))THEN
+ PRINT *,' J ZLON0(J) ZLON0(1) ',J,ZLON0(J),ZLON0(1)
+ ENDIF
+ IF(ZRPK(J) /= ZRPK(1))THEN
+ PRINT *,' J ZRPK(J) ZRPK(1) ',J,ZRPK(J),ZRPK(1)
+ ENDIF
+ IF(ZLONOR(J) /= ZLONOR(1))THEN
+ PRINT *,' J ZLONOR(J) ZLONOR(1) ',J,ZLONOR(J),ZLONOR(1)
+ ENDIF
+ IF(ZLATOR(J) /= ZLATOR(1))THEN
+ PRINT *,' J ZLATOR(J) ZLATOR(1) ',J,ZLATOR(J),ZLATOR(1)
+ ENDIF
+ IF(ZLAT0(J) /= ZLAT0(1))THEN
+ PRINT *,' J ZLAT0(J) ZLAT0(1) ',J,ZLAT0(J),ZLAT0(1)
+ ENDIF
+ IF(ZBETA(J) /= ZBETA(1))THEN
+ PRINT *,' J ZBETA(J) ZBETA(1) ',J,ZBETA(J),ZBETA(1)
+ ENDIF
+ IF((OCARTESIAN(J) .AND..NOT. OCARTESIAN(1)) .OR. &
+ (.NOT. OCARTESIAN(J) .AND. OCARTESIAN(1)))THEN
+ PRINT *,' J OCARTESIAN(J) OCARTESIAN(1) ',J,OCARTESIAN(J),OCARTESIAN(1)
+ ENDIF
+ !
+ ENDIF
+!
+ IF(J == NNBF)THEN ! dernier fichier
+ DEALLOCATE(IIMAX,IJMAX,IKMAX,ZTIMECUR)
+ DEALLOCATE(ZLON0,ZRPK,ZLONOR,ZLATOR,ZLAT0,ZBETA)
+ DEALLOCATE(OCARTESIAN)
+ END IF
+!
+! 5.42 Eventuelle eliminination de certains parametres ds le fic. diach.
+!
+ IF(J == 1)THEN
+
+
+ ALLOCATE(YRECT(SIZE(CRECFM2T,1)))
+ YRECT(1:LEN(YRECT))(:)=' '
+ INB=0
+ DO JI=1,NNB
+ IF(NNUMT(JI,J) /= 0)THEN
+ INB=INB+1
+ YRECT(INB)=CRECFM2T(JI,J)
+ YRECT(INB)=ADJUSTL(YRECT(INB))
+! print *,' INB, YRECT ',INB,YRECT(INB)
+ ENDIF
+ ENDDO
+
+ ALLOCATE(YRECID(NNB+100),YKEEP(NNB+100))
+ YRECID(:)(1:LEN(YRECID))=' '
+ YKEEP(:)(1:LEN(YRECID))=' '
+
+ IID=0
+ DO JI = 1,INB-1
+ YREF(1:LEN(YREF))=' '
+ IL=LEN_TRIM(YRECT(JI))-1
+ IF (IL > 15)THEN
+ print *,' Len GROUPE -1 > 15 ',IL,YRECT(JI)
+ ENDIF
+ YREF(1:IL)=YRECT(JI)(1:IL)
+! YREF=ADJUSTL(YREF)
+ IF(YREF(1:IL) == 'PABS' .OR. YREF(1:IL) == 'POVO' .OR. &
+ YREF(1:IL) == 'TH')THEN
+ IF(YRECT(JI)(IL+1:IL+1) == 'M')THEN
+ DO JIP1=JI+1,INB
+! DO JIP1=2,INB
+ IL=LEN_TRIM(YRECT(JIP1))-1
+ IF(YRECT(JIP1)(1:IL) == YREF .AND. YRECT(JIP1)(IL+1:IL+1) == 'T')THEN
+ IID=IID+1
+ YRECID(IID)=' '
+ YRECID(IID)=YREF
+ YRECID(IID)=ADJUSTL(YRECID(IID))
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+ ENDIF
+ ENDDO
+ print *,' DELETION OF PARAMETERS AT TIME t-dt ? (enter 1) '
+ print *,' DELETION OF PARAMETERS AT TIME t ? (enter 2) '
+ print *,' NO DELETION ? (enter 0) '
+ print *,' (Question to select automatically parameters for vertical interpolations)'
+ READ(5,*)ICODEL
+ YCAR80(1:LEN(YCAR80))=' '
+ WRITE(YCAR80,*)ICODEL
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ IF(ICODEL == 0)THEN
+ ELSE IF(ICODEL == 1)THEN
+ DO JI=1,IID
+ YRECID(JI)=ADJUSTL(ADJUSTR(YRECID(JI))//'M')
+! YRECID(1:IID)=ADJUSTL(ADJUSTR(YRECID(1:IID))//'M')
+ ENDDO
+ ELSE IF(ICODEL == 2)THEN
+ DO JI=1,IID
+ YRECID(JI)=ADJUSTL(ADJUSTR(YRECID(JI))//'T')
+! YRECID(1:IID)=ADJUSTL(ADJUSTR(YRECID(1:IID))//'T')
+ ENDDO
+ ENDIF
+
+! print *,' ICODEL,IID,YRECID ',ICODEL,IID,YRECID(1:IID)
+
+ I4=0
+ YPRI=' '
+! IF(ICODEL /= 0)THEN
+
+ print *,' PARAMETRES RESTANTS'
+ DO JI = 1,NNB
+ DO JIP1 = 1,IID
+ IF(CRECFM2T(JI,J) == YRECID(JIP1))THEN
+ NNUMT(JI,J)=0
+ EXIT
+ ENDIF
+ ENDDO
+ IF(NNUMT(JI,J) /= 0)THEN
+ I4=I4+1
+ YPRI(I4)=CRECFM2T(JI,J)
+ IF(I4 == 4 .OR. JI == NNB)THEN
+ print 10,YPRI
+ I4=0
+ YPRI=' '
+ ENDIF
+ ENDIF
+ ENDDO
+! Donc ICI ds YRECID(1:IID), il y avait les parametres a supprimer et
+! qui viennent de l'etre en mettant le NNUMT(,) correspondant a zero.
+! Dec 2000
+ IKEEP=0
+ IKEEP=IKEEP+1
+ YKEEP(IKEEP)='ZS'
+ YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
+ DO JI = 1,NNB
+ IF(NNUMT(JI,J) /= 0)THEN
+ IF(CRECFM2T(JI,J) == 'PABSM')THEN
+ IKEEP=IKEEP+1
+ YKEEP(IKEEP)='PABSM'
+ YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
+ ELSEIF(CRECFM2T(JI,J) == 'PABST')THEN
+ IKEEP=IKEEP+1
+ YKEEP(IKEEP)='PABST'
+ YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
+ ELSEIF(CRECFM2T(JI,J) == 'THM')THEN
+ IKEEP=IKEEP+1
+ YKEEP(IKEEP)='THM'
+ YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
+ ELSEIF(CRECFM2T(JI,J) == 'THT')THEN
+ IKEEP=IKEEP+1
+ YKEEP(IKEEP)='THT'
+ YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
+ ELSEIF(CRECFM2T(JI,J) == 'POVOM')THEN
+ IKEEP=IKEEP+1
+ YKEEP(IKEEP)='POVOM'
+ YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
+ ELSEIF(CRECFM2T(JI,J) == 'POVOT')THEN
+ IKEEP=IKEEP+1
+ YKEEP(IKEEP)='POVOT'
+ YKEEP(IKEEP)=ADJUSTL(YKEEP(IKEEP))
+ ENDIF
+ ENDIF
+ ENDDO
+! ENDIF
+
+ print *,' '
+ print *,' Some parameters(if exist) are automatically recorded (for vert. interpolations):'
+ print *,' --> ',(YKEEP(JI)(1:LEN_TRIM(YKEEP(JI))+1),JI=1,IKEEP)
+ print *,' '
+! Dec 2000
+
+ YREPON(1:LEN(YREPON))=' '
+ print *,' Do you want to KEEP others parameters ? (y/n) '
+ READ(5,*)YREPON
+ YCAR80(1:LEN(YCAR80))=' '
+ YCAR80=YREPON
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+ IF(YREPON == 'y' .OR. YREPON == 'yes' .OR. YREPON == 'o' .OR. &
+ YREPON == 'oui' .OR. YREPON == 'Y' .OR. YREPON == 'YES' .OR. YREPON == &
+ 'O' .OR. YREPON == 'OUI')THEN
+ print *,' '
+ print *,' Enter their names in UPPERCASE (1/1 line) '
+ print *,' End by END '
+ print *,' '
+ print *,' NOTA: if you want to plot RS ,don''t forget : RVM,UM,VM or RVT,UT,VT'
+ print *,' '
+ DO JI=1,10000
+! IID=IID+1
+ IKEEP=IKEEP+1
+! YRECID(IID)=' '
+ YKEEP(IKEEP)=' '
+ READ(5,*)YKEEP(IKEEP)
+! READ(5,*)YRECID(IID)
+! YRECID(IID)=ADJUSTL(YRECID(IID))
+ YKEEP(IID)=ADJUSTL(YKEEP(IID))
+ YCAR80(1:LEN(YCAR80))=' '
+! YCAR80=YRECID(IID)
+ YCAR80=YKEEP(IKEEP)
+ YCAR80=ADJUSTL(YCAR80)
+ WRITE(80,'(A80)')YCAR80
+! IF(YRECID(IID) == 'END')THEN
+ IF(YKEEP(IKEEP) == 'END')THEN
+ CLOSE(80)
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+! Donc ICI ds YKEEP(1:IKEEP), on a les variables =/= intouchables a garder
+! print *,' YRECID'
+! print 10,YRECID(1:IID)
+! print *,' CRECFM2T'
+! print 10,CRECFM2T(1:NNB,J)
+! print *,' PARAMETRES RESTANTS'
+ 10 FORMAT(1X,4A19)
+ I4=0
+! YPRI(:)=' '
+! IF(ICODEL /= 0)THEN
+ DO JI = 1,NNB
+! Dec 2000
+ IF(NNUMT(JI,J) /= 0)THEN
+ IOK=0
+! DO JIP1 = 1,IID
+ DO JIP1 = 1,IKEEP
+ IF(CRECFM2T(JI,J) == YKEEP(JIP1))THEN
+ IOK=1
+ EXIT
+ ENDIF
+ ENDDO
+ IF(IOK == 0)THEN
+ NNUMT(JI,J)=0
+ ENDIF
+ ENDIF
+! Dec 2000
+ IF(NNUMT(JI,J) /= 0)THEN
+ IF(I4 == 4)THEN
+ print 10,YPRI(1:I4)
+ I4=0
+ YPRI(1:4)=' '
+ ENDIF
+ I4=I4+1
+ YPRI(I4)=CRECFM2T(JI,J)
+ ENDIF
+ IF(JI == NNB)THEN
+ print 10,YPRI(1:I4)
+ ENDIF
+ ENDDO
+
+! ENDIF
+
+
+ ENDIF
+!
+ IF(J == 1)THEN
+ DO JI=1,NNB
+! 5.43 Elimination des dates
+!
+ IDA=INDEX(CRECFM2T(JI,J),'%TDA')
+ IF(IDA /= 0)THEN
+ NNUMT(JI,J)=0
+ ENDIF
+ IDA=INDEX(CRECFM2T(JI,J),'%TIM')
+ IF(IDA /= 0)THEN
+ NNUMT(JI,J)=0
+ ENDIF
+! 5.44 Elimination des champs dont le nom depasse 13 caracteres
+! (13 = 16 (=max.LEN(RECFM)=JPNCPN) -3 (=LEN('.TYpe','.DIm','.TItre',
+! '.UNite','.COmment','.PRoc1','.TRajt','.DAtim'))
+ IF (LEN_TRIM(CRECFM2T(JI,J))>13 .AND. NNUMT(JI,J)/=0) THEN
+ NNUMT(JI,J)=0
+ print*,'Variable ',CRECFM2T(JI,J), ' not written (name too long)'
+ WRITE(NLUOUTD,*)'Variable ',CRECFM2T(JI,J), ' not written (name too long)'
+ END IF
+
+ ENDDO
+ENDIF
+!
+!* 5.5 Lecture et ecriture des autres champs
+!
+ CALL WRITE_OTHERSFIELDS(J,CFILEDIA,CLUOUTDIA)
+!
+!* 5.6 Fermeture du Fichier d'entree traite et liberation de l'unite
+! logique correspondante
+!
+ CALL FMCLOS(CNAMFILED(J),'KEEP',CLUOUTD,NRESP)
+
+ENDDO
+!
+!* 6. Terminaison du fichier diachronique et impression du nom des
+! groupes enregistres
+! -------------------------------------------------------------
+!
+CALL MENU_DIACHRO(CFILEDIA,CLUOUTDIA,'END')
+CALL MENU_DIACHRO(CFILEDIA,CLUOUTDIA,'READ')
+
+CLOSE(NLUOUTD)
+CALL FMFREE(CLUOUTD,CLUOUTD,NRESP)
+!
+!* 7. Fermeture du fichier diachronique
+! ---------------------------------
+!
+CALL FMCLOS(CFILEDIA,'KEEP',CLUOUTDIA,NRESP)
+!------------------------------------------------------------------------------
+!
+!* 4. EPILOGUE
+! --------
+
+STOP
+
+END PROGRAM FM2DIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/elim.f90 b/LIBTOOLS/tools/diachro/src/FM2DIA/elim.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1d4a9a7907824f63fc0d0634d8db7bfc4d6e7b42
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/elim.f90
@@ -0,0 +1,59 @@
+! ######spl
+ SUBROUTINE ELIM(HRECFM)
+! #######################
+!
+!!**** *ELIM* - Mise a 0 des numeros d'enregistrements lus correspondant
+! aux parametres "intouchables"
+!!
+!! PURPOSE
+!! -------
+! On met arbitrairement a 0 les numeros d'enregistrements lus correspon-
+! -dant aux parametres "intouchables" pour les eliminer du traitement
+! realise dans la routine WRITE_OTHERFIELDS
+!
+!!** METHOD
+!! ------
+! On met a une valeur nulle les numeros d'enregistrements correspon-
+! -dant aux parametres "intouchables" ecrits dans le fichier
+! diachronique une fois pour toutes avec la routine
+! WRITE_LFIFM1_FORDIACHRO_CV pour ne pas les prendre en compte dans
+! la routine WRITE_OTHERFIELDS
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHORS
+!! -------
+!! J. Duron *Lab. Aerologie*
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/01/96
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_DIMGRID_FORDIACHRO
+!
+!* 0.1 Dummy arguments
+!
+CHARACTER(LEN=*) :: HRECFM
+!
+!* 0.2 Local variables declarations
+!
+INTEGER :: J
+!
+!----------------------------------------------------------------------------
+!
+DO J=1,NNB
+ IF(HRECFM == CRECFM2T(J,1))NNUMT(J,1)=0
+ENDDO
+!
+!----------------------------------------------------------------------------
+
+RETURN
+
+END SUBROUTINE ELIM
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/jdlfilaf_fuji.f b/LIBTOOLS/tools/diachro/src/FM2DIA/jdlfilaf_fuji.f
new file mode 100644
index 0000000000000000000000000000000000000000..73658d2631da4978dd126eb5ba86617f81a3594a
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/jdlfilaf_fuji.f
@@ -0,0 +1,812 @@
+ SUBROUTINE JDLFILAF ( KREP, KNUMER, LDTOUT )
+C****
+C !--------------------------------------------------!
+C ! Sous-programme du logiciel LFI !
+C ! (Logiciel de Fichiers Indexes par nom d'article) !
+C !--------------------------------------------------!
+C
+C - Version originale de LFI: Octobre 1989, auteur:
+C Jean CLOCHARD, METEO FRANCE.
+C
+C - Aout 1991: Ajout de la notion de "facteur multiplicatif"
+C (on sait traiter un fichier dont la longueur d'article
+C "physique" est multiple de la longueur elementaire JPLARD),
+C et (sur option) toute la messagerie peut etre en anglais.
+C
+C - Janvier 1996 : ajout ecriture dans 1 fichier de nom FICJD
+C du numero des enregistrements, de leur nom et de leur longueur
+C totale (CCCCCCCCCCCCCCCCCC JDJD CCCCCCCCCCCCCCCCCCCCCCC)
+C
+C
+C****
+C Sous-programme donnant, pour une unite logique ouverte au sens
+C du logiciel de fichiers indexes *LFI*, la Liste des Articles logi-
+C ques de donnees presents dans le Fichier, liste donnee toutefois
+C dans l'ordre PHYSIQUE ou ceux-ci figurent dans le fichier.
+C Sur option on donne aussi des renseignements sur les articles
+C (physiques) de gestion propres au logiciel, ainsi que sur les
+C trous repertories dans l'index.
+C**
+C Arguments : KREP (Sortie) ==> Code-reponse du sous-programme;
+C KNUMER (Entree) ==> Numero de l'unite logique;
+C LDTOUT (Entree) ==> Vrai si on doit donner les rensei-
+C gnements optionnels (qui ne concer-
+C nent pas directement les articles
+C logiques de donnees).
+C
+C
+#include "lficom0.h"
+C
+C
+C----- DESCRIPTION DES "PARAMETER" DU LOGICIEL DE FICHIERS INDEXES -----
+C
+C JPDBLE= PRECISION UTILISE POUR LES ENTIERS
+C * SI JPDBLE=8 COMPILER EN INTEGER 32 BITS
+C * SI JPDBLE=4 COMPILER EN INTEGER 64 BITS
+C
+ INTEGER JPDBLE
+C
+ PARAMETER (JPDBLE=8)
+C
+C--- DESCRIPTIF DES TABLES CONCERNANT LES (PAIRES DE) PAGES D'INDEX ----
+C ( ALIAS "P.P.I." )
+C
+C CNOMAR = TABLE DES PAGES D'INDEX DE TYPE "NOMS D'ARTICLES"
+C MLGPOS = TABLE DES PAGES D'INDEX DE TYPE "LONGUEUR/POSITION"
+C MRGPIF = TABLE DES RANGS DES P.P.I. DANS LEUR FICHIER RESPECTIF
+C MCOPIF = TABLE DE CORRESPONDANCE PAGES D'INDEX/UNITES LOGIQUES
+C MRGPIM = TABLE DES RANGS EN MEMOIRE DES P.P.I. AFFECTEES
+C ( DANS *MCOPIF,MRGPIF,CNOMAR,MLGPOS,LECRPI,LPHASP* )
+C LECRPI = VRAI SI LA PAGE D'INDEX CORRESP. DOIT ETRE (RE)ECRITE
+C (.,1) ==> PAGE "NOM", (.,2) ==> PAGE "LONGUEUR/POSITION"
+C LPHASP = VRAI SI LA PAGE D'INDEX "LONG/POS" EST PHASEE EN MEMOIRE
+C AVEC LA PAGE D'INDEX "NOM" CORRESPONDANTE
+C
+C---------------- VARIABLES "SIMPLES" GLOBALES -------------------------
+C
+C NBFIOU = Nombre d'Unites Logiques ouvertes
+C NFACTM = Somme des Facteurs Multiplicatifs utilises
+C NIMESG = NIVEAU *GLOBAL* DE LA MESSAGERIE
+C NERFAG = NIVEAU DE FILTRAGE GLOBAL DES ERREURS FATALES
+C NISTAG = NIVEAU D'IMPRESSION GLOBAL DES STATISTIQUES
+C NPISAF = NBRE DE PAIRES DE PAGES D'INDEX SUPPLEMENTAIRES AFFECTEES
+C LMULTI = VRAI SI ON DOIT TRAVAILLER EN MODE MULTI-TACHES
+C LTAMLG = OPTION PAR DEFAUT D'UTILISATION DE LA MEMOIRE TAMPON EN
+C LECTURE; VRAIE ==> UTILISATION MAXIMUM
+C LTAMEG = CF. CI-DESSUS, EN ECRITURE
+C VERGLA = VERROU GLOBAL (EN MULTI-TASKING)
+C NULOFM = Nombre d'Unites LOgiques a Facteur Multiplicat. predefini
+C CHINCO = Nom par defaut d'une variable qui devrait etre CHaracter
+C NUIMEX = Nombre d'Unites LOgiques en cours d'IMport/EXport
+C
+C--------- DESCRIPTIF DES ELEMENTS CONCERNANT UNE UNITE LOGIQUE --------
+C
+C NUMIND = TABLE D'ADRESSAGE INDIRECT DANS LES TABLEAUX CI-DESSOUS
+C NUMERO = NUMERO DE L'UNITE LOGIQUE
+C MFACTM = FACteur Multiplicatif de la longueur physique elementaire
+C CNOMFI = NOM eventuel du FIchier associe a l'unite logique
+C CNOMSY = Idem pour le systeme, ou a defaut pour l'utilisateur.
+C NLNOMF = LONGUEUR (CARACTERES) DU NOM EVENTUEL
+C NLNOMS = Longueur (en caracteres) du Nom SYSTEME eventuel
+C NDEROP = CODE DE LA DERNIERE ACTION EFFECTUEE
+C CSTAOP = 'STATUS' DE L'OUVERTURE
+C LNOUFI = VRAI SI LE FICHIER EST NOUVEAU (AU SENS DU LOGICIEL)
+C LMODIF = " " " " A ETE MODIFIE DEPUIS L'OUVERTURE
+C NDERCO = DERNIER CODE-REPONSE (CORRESPONDANT A LA DERNIERE ACTION)
+C MTAMPD = PAGES DE DONNEES "TAMPON"
+C NUMAPD = NUMERO D'ARTICLE PHYSIQUE CORRESPONDANT A CES PAGES
+C LECRPD = VRAI SI LA PAGE DE DONNEES CORRESP. DOIT ETRE ECRITE
+C NLONPD = LONGUEUR DE PAGE DE DONNEES REELLEMENT REMPLIE
+C NDERPD = NUMERO DE LA DERNIERE PAGE DE DONNEES UTILISEE
+C NPODPI = RANG DE LA DERNIERE PAGE D'INDEX DANS LA TABLE *MRGPIM*
+C NALDPI = NOMBRE D'ARTICLES LOGIQUES DANS LA DERNIERE PAGE D'INDEX
+C NBLECT = " DE LECTURES EFFECTUEES DEPUIS L'OUVERTURE
+C NBNECR = " " NOUVELLES ECRITURES " " "
+C NREESP = " " "VRAIES" REECRITURES SUR PLACE " "
+C NREECO = " " REECRITURES PLUS COURTES " "
+C NREELO = " " " PLUS LONGUES " "
+C NBRENO = " " FOIS OU ON A RENOMME UN ARTICLE " "
+C NBSUPP = " " " " " " " SUPPRIME " " " "
+C NBTROU = " " TROUS D'INDEX CREES " "
+C NIVMES = NIVEAU DE LA MESSAGERIE
+C LERFAT = VRAI SI TOUTE ERREUR DOIT ETRE FATALE
+C LISTAT = OPTION D'IMPRESSION DES STATISTIQUES ( A LA FERMETURE )
+C VERRUE = VERROU DE L'UNITE LOGIQUE (EN MODE MULTI-TASKING)
+C NPPIMM = NBRE DE PAIRES DE PAGES D'INDEX EN MEMOIRE
+C MDES1D = TABLE CONTENANT LE 1ER ARTICLE ("DESCRIPTIF")
+C NTRULZ = NOMBRE DE TROUS D'INDEX DE LONGUEUR NULLE
+C NRFPTZ = RANG PREMIERE ARTICLE AYANT LA CARACTERISTIQUE CI-DESSUS
+C NRFDTZ = " DERNIER " " " " "
+C NBREAD = NOMBRE DE "READ" FORTRAN REELLEMENT EXECUTES (DEPUIS L'
+C NBWRIT = " "WRITE" " " " OUVERTURE)
+C NBMOLU = NOMBRE DE MOTS UTILISATEUR LUS CORRECTEMENT (DEPUIS L'
+C NBMOEC = " " " " ECRITS " OUVERTURE)
+C LTAMPL = OPTION D'UTILISATION MAXI DE LA MEMOIRE TAMPON EN LECTURE
+C LTAMPE = " " " " " " " " " ECRITURE
+C NDERGF = RANG DANS LE FICHIER DU DERNIER ARTICLE LOGIQUE LU
+C ou dont on a demande les caracteristiques (LFICAS/LFICAP)
+C CNDERA = NOM de ce dernier article logique de donnees
+C NSUIVF = RANG DANS LE FICHIER DU PROCHAIN ARTICLE LOGIQUE A LIRE
+C "SEQUENTIELLEMENT"
+C NPRECF = RANG DANS LE FICHIER DU PROCHAIN ARTICLE LOGIQUE
+C "PRECEDENT" A LIRE
+C LMIMAL = VRAI SI ON DOIT RECALCULER LES LONGUEURS MINI. ET MAXI.
+C DES ARTICLES LOGIQUES DE DONNEES
+C NUMAPH = NUMero d'Article PHysique (pour messages d'erreur E/S).
+C NEXPOR = Rang eventuel (d'EXPORt) dans les tables MNUIEX,NDIMPL,
+C NIMPOR = " " (d'IMPORt) NDEXPL,NREXPL,CNEXPL,NIMPEX...
+C
+C------------------------ VARIABLES DIVERSES ---------------------------
+C
+C MULOFM = Table des Unites LOgiques avec Facteur Multip. predefini
+C MFACTU = " " FActeurs mUltiplicatifs associes a ces Unites
+C MNUIEX = " " Numeros d'Unites logiques en Import/EXport
+C NINIEX = " d'adressage INdirect dans MNUIEX
+C NDIMPL = Descripteurs IMPLicites d'import/export en memoire
+C NDEXPL = " EXPLicites " " / " " "
+C CNIMPL = Profil des articles a description IMPLicite
+C NAEXPL = Nombre d'articles decrits EXPLicitement
+C CNEXPL = Noms des articles decrits dans NDEXPL
+C NREXPL = Rang " " " " NDEXPL
+C NIMPEX = Numero d'unite logique associee a l'IMPort ou l'EXport.
+C NUTRAV = " " " " de TRAVail pour import ou export.
+C NLAPFD = Longueur d'Article Physique du fichier d'export/import.
+C NXCNLD = Nb.maX. Caracteres/Nom d'article du logiciel LFI Distant.
+C NRCFMX = Rang de la config. Imp/eXport dans CFGMXD, NBMOSD, NBCASD
+C CFGMXD = ConFiGuration pour iMport/eXport des systemes Distants.
+C NBMOSD = Nombre de Bits par MOt des systemes Distants.
+C NBCASD = " " " " CAractere " " " .
+C CTYPMX = Liste des types de variables valides pour Import/eXport.
+C
+ CHARACTER*(JPNCPN) CNOMAR (JPNXNA*JPNXPI), CNDERA (JPNXFI), CHINCO
+ CHARACTER*(JPLFTX) CNOMFI (JPNXFI), CNOMSY (JPNXFI), CLACTI
+ CHARACTER CSTAOP (JPNXFI)*(JPLSTX), CLNSPR*(JPLSPX), CLMESS*132
+ CHARACTER CNEXPL (JPXDAM,JPIMEX)*(JPNCPN), CTYPMX*(JPTYMX)
+ CHARACTER CNIMPL (JPIMEX)*(JPXMET), CFGMXD (0:JPCFMX)*(JPXCCF)
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ CHARACTER*16 CFICJD,CFICJDOUT
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C
+ COMMON /LFICHA/ CNOMAR, CNDERA, CNOMFI, CNOMSY, CSTAOP, CHINCO
+ S , CNEXPL, CNIMPL, CFGMXD, CTYPMX
+C
+ INTEGER NBFIOU, NFACTM, NIMESG, NERFAG, NISTAG, NPISAF, NULOFM
+ INTEGER (KIND=JPDBLE) MLGPOS (JPLARD*JPNXPI)
+ INTEGER (KIND=JPDBLE) MTAMPD (JPLARD*JPNPDF*JPNXFI)
+ INTEGER (KIND=JPDBLE) MDES1D (JPLARD*JPNXFI)
+ INTEGER MRGPIM (JPNPIA+JPNPIS,JPNXFI), NDERPD (JPNXFI)
+ INTEGER MCOPIF (JPNXPI), MRGPIF (JPNXPI), NLNOMS (JPNXFI)
+ INTEGER NUMERO (JPNXFI), NLNOMF (JPNXFI), NDERCO (JPNXFI)
+ INTEGER NPODPI (JPNXFI), NUMAPH (0:JPNXFI)
+ INTEGER NALDPI (JPNXFI), NBLECT (JPNXFI), NBNECR (JPNXFI)
+ INTEGER NREESP (JPNXFI), NREECO (JPNXFI), NREELO (JPNXFI)
+ INTEGER NIVMES (0:JPNXFI), NDEROP (JPNXFI), NPPIMM (JPNXFI)
+ INTEGER NUMAPD (0:JPNPDF-1,JPNXFI), NLONPD (0:JPNPDF-1,JPNXFI)
+ INTEGER NTRULZ (JPNXFI), NRFPTZ (JPNXFI), NRFDTZ (JPNXFI)
+ INTEGER NBTROU (JPNXFI), NUMIND (JPNXFI), NBREAD (JPNXFI)
+ INTEGER NBWRIT (JPNXFI), NBMOLU (JPNXFI), NBMOEC (JPNXFI)
+ INTEGER NDERGF (JPNXFI), NSUIVF (JPNXFI), NPRECF (JPNXFI)
+ INTEGER NBRENO (JPNXFI), NBSUPP (JPNXFI), MFACTM (0:JPNXFI)
+ INTEGER MULOFM (JPXUFM), MFACTU (0:JPXUFM)
+ INTEGER NIMPEX (JPIMEX), NUTRAV (JPIMEX), NBMOSD (0:JPCFMX)
+ INTEGER NBCASD (0:JPCFMX), NLAPFD (JPIMEX)
+ INTEGER MNUIEX (JPIMEX), NINIEX (JPIMEX), NDEXPL (JPDEXP,JPIMEX)
+ INTEGER NDIMPL (JPDIMP,JPIMEX), NXCNLD (JPIMEX), NAEXPL (JPIMEX)
+ INTEGER NEXPOR (JPNXFI), NIMPOR (JPNXFI), NUIMEX, NRCFMX (JPIMEX)
+ INTEGER NREXPL (0:JPXDAM,JPIMEX)
+C
+ REAL VERRUE (JPNXFI), VERGLA
+C
+ LOGICAL LLFATA, LMULTI, LTAMLG, LTAMEG, LECRPI (JPNXPI,2)
+ LOGICAL LTAMPL (JPNXFI), LTAMPE (JPNXFI), LMODIF (JPNXFI)
+ LOGICAL LNOUFI (JPNXFI), LERFAT (0:JPNXFI), LISTAT (JPNXFI)
+ LOGICAL LPHASP (JPNXPI), LECRPD (0:JPNPDF-1,JPNXFI)
+ LOGICAL LMIMAL (JPNXFI)
+C
+ COMMON /LFIDIV/ NBFIOU, NIMESG, NERFAG, NISTAG, NPISAF, LMULTI
+ S , VERGLA, LTAMLG, LTAMEG, MRGPIM, MRGPIF, NUMIND
+ S , VERRUE, MLGPOS, MDES1D, MCOPIF, LECRPI, LPHASP
+ S , NUMERO, NLNOMF, LNOUFI, NDERCO, MTAMPD, NUMAPD
+ S , NPODPI, NALDPI, NBLECT, NBNECR, NREESP, NREECO
+ S , NREELO, NIVMES, LERFAT, LISTAT, NDEROP, LMODIF
+ S , NPPIMM, NRFPTZ, NRFDTZ, NTRULZ, NBREAD, NBWRIT
+ S , LECRPD, NLONPD, NDERPD, NBTROU, NBMOLU, NBMOEC
+ S , LTAMPL, LTAMPE, NDERGF, NSUIVF, NBRENO, NBSUPP
+ S , LMIMAL, NPRECF, MFACTM, NULOFM, MULOFM, MFACTU
+ S , NLNOMS, NFACTM, NUMAPH, NEXPOR, NIMPOR, NIMPEX
+ S , NUTRAV, NBMOSD, NBCASD, NLAPFD, NXCNLD, NUIMEX
+ S , MNUIEX, NINIEX, NDEXPL, NREXPL, NDIMPL, NAEXPL
+ S , NRCFMX
+C
+C
+ INTEGER KREP, KNUMER, IMDESC, IREP, IRANG, INTROU, INBPIR, INBALO
+ INTEGER INALDO, IFACTM, ILARPH, INALPP, INTPPI, INPPIM, INIMES, J
+ INTEGER INAGES, IRESER, INUTIL, IPERTE, IPOSFI, IPOSDE, INEXCE
+ INTEGER INABAL, INALDI, INTROI, INPIMD, INPIMF, INPILE, JRGPIF
+ INTEGER IRGPFS, IRGPIM, IRANGM, IRPIMS, INALPI, ILONGA, IRECPI
+ INTEGER IDERPU, IREC, IRETIN
+C
+ LOGICAL LDTOUT
+C
+C
+C FONCTION SERVANT A RENDRE FATALE OU NON UNE ERREUR DETECTEE,
+C A L'AIDE DU CODE-REPONSE COURANT, DU NIVEAU DE FILTRAGE GLOBAL,
+C ET DE L'OPTION D'ERREUR FATALE PROPRE AU FICHIER.
+C S'IL N'Y A PAS DE FICHIER (I5678=0, D'OU DIMENSIONNEMENT DE
+C *LERFAT*), LE NIVEAU DE FILTRAGE JOUE LE ROLE PRINCIPAL.
+C
+ INTEGER IXNIMS, I1234, I5678, I3456, IXC, IXM, IXT, IABCDE, IFGHIJ
+ INTEGER IKLMNO, IPQRST, IUVWXY, IZABCD, IEFGHI
+C
+ LOGICAL LLMOER
+C
+ LLMOER (I1234,I5678)=I1234.EQ.-16.OR.
+ S (I1234.NE.0.AND.(NERFAG.EQ.0.OR.(NERFAG.EQ.1.AND.LERFAT(I5678))))
+C
+C FONCTION DONNANT LE PLUS HAUT NIVEAU DE MESSAGERIE ACCEPTABLE
+C POUR L'UNITE LOGIQUE DE RANG "I3456" .
+C (UTILISATION DES NIVEAUX DE MESSAGERIE GLOBAL ET PROPRE AU
+C FICHIER - MEME REMARQUE QUE CI-DESSUS SI I3456=0, POUR NIVMES)
+C
+ IXNIMS (I3456)=MIN0 (2,2*NIMESG,MAX0 (2*NIMESG-2,NIVMES(I3456)))
+C
+C Fonctions servant a l'adressage 1D dans les tableaux CNOMAR,
+C MLGPOS et MDES1D, MTAMPD.
+C
+ IXC (IABCDE,IFGHIJ) = IABCDE + JPNXNA * ( IFGHIJ - 1 )
+ IXM (IKLMNO,IPQRST) = IKLMNO + JPLARD * ( IPQRST - 1 )
+ IXT (IUVWXY,IZABCD,IEFGHI) = IUVWXY + JPLARD *
+ S ( MFACTM(IEFGHI) * IZABCD + JPNPDF * ( IEFGHI - 1 ) )
+C
+C**
+C 1. - CONTROLES DES PARAMETRES D'APPEL, PUIS INITIALISATIONS.
+C-----------------------------------------------------------------------
+C
+ IREP=0
+ IRANG=0
+ CLNSPR='LFILAF'
+ print *,' jdlfilaf BALISE 1 KNUMER,IRANG',KNUMER,IRANG
+ CALL LFINUM (KNUMER,IRANG)
+ print *,' jdlfilaf BALISE 1 Bis LMULTI',LMULTI,KNUMER,IRANG
+C
+ IF (IRANG.EQ.0) THEN
+ IREP=-1
+ GOTO 1001
+ ENDIF
+C
+ IF (LMULTI) CALL LFIVER (VERRUE(IRANG),'ON')
+ INTROU=MDES1D(IXM(JPNTRU,IRANG))+NBTROU(IRANG)
+ INBPIR=MDES1D(IXM(JPNPIR,IRANG))
+ INBALO=MDES1D(IXM(JPNALO,IRANG))
+ INALDO=INBALO-INTROU
+ print *,' MFACTM(0), MFACTM(1) ',MFACTM(0),MFACTM(1)
+ IFACTM=MFACTM(IRANG)
+ print *,' jdlfilaf BALISE 1 IRANG, IFACTM ',IRANG,IFACTM
+ ILARPH=JPLARD*IFACTM
+ INALPP=JPNAPP*IFACTM
+C INALPP=512
+ print *,' jdlfilaf BALISE 1 INALPP',INALPP
+C INALPP=1
+ INTPPI=(INBALO-1+INALPP)/INALPP
+ INPPIM=NPPIMM(IRANG)
+C
+C Envoi d'une banniere.
+C
+ WRITE (UNIT=*,FMT='(///)')
+C
+ IF (LFRANC) THEN
+ WRITE (UNIT=CLMESS,FMT='(''Catalogue de l''''Unite Logique LFI''
+ S ,I3,'' dans l''''ordre *PHYSIQUE* (sequentiel) des articles'')')
+ S KNUMER
+ ELSE
+ WRITE (UNIT=CLMESS,FMT='(''Catalog of LFI Logical Unit'',I3,
+ S '' in *PHYSICAL* (sequential) record order'')') KNUMER
+ ENDIF
+C
+ INIMES=2
+ LLFATA=.FALSE.
+ CALL LFIEMS (KNUMER,INIMES,IREP,LLFATA,CLMESS,CLNSPR,CLACTI)
+C**
+C 2. - SUR OPTION, RENSEIGNEMENTS SUR LES ARTICLES "DE GESTION".
+C (ARTICLE DOCUMENTAIRE, PAIRES D'ARTICLES D'INDEX)
+C-----------------------------------------------------------------------
+C
+ print *,' jdlfilaf BALISE 2'
+ IF (LDTOUT) THEN
+ INAGES=1+2*INBPIR
+ IRESER=ILARPH*INAGES
+C
+ IF (LFRANC) THEN
+ WRITE (UNIT=*,FMT='(//,TR1,I6,
+ S '' article(s) "physique(s)" de gestion,'',I6,
+ S '' mots chacun, occupant donc'',I7,'' mots; detail:'',
+ S /,TR10,''Article documentaire de la position 1 a'',I6,/,TR10,I6,
+ S'' paire(s) d''''articles d''''index prereserves, de la position''
+ S ,I6,'' a'',I7)')
+ S INAGES,ILARPH,IRESER,ILARPH,INBPIR,ILARPH+1,IRESER
+ ELSE
+ WRITE (UNIT=*,FMT='(//,TR1,I6,
+ S '' "physical" records for file handling,'',I6,
+ S '' words each, occupying then'',I7,'' words; detail:'',
+ S /,TR10,''Documentary record from position 1 to'',I6,/,TR10,I6,
+ S'' pair(s) of pre-reserved index records, from position''
+ S ,I6,'' to'',I7)')
+ S INAGES,ILARPH,IRESER,ILARPH,INBPIR,ILARPH+1,IRESER
+ ENDIF
+C
+ IF (INTPPI.LT.INBPIR) THEN
+ INUTIL=INBPIR-INTPPI
+ IPERTE=ILARPH*INUTIL*2
+C
+ IF (LFRANC) THEN
+ WRITE (UNIT=*,FMT='(/,TR10,5(''=''),''> Il y a'',I3,
+ S '' paire(s) d''''articles d''''index inutilises, representant'',
+ S I8,'' mots'')') INUTIL,IPERTE
+ ELSE
+ WRITE (UNIT=*,FMT='(/,TR10,5(''=''),''> There is (are)'',I3,
+ S '' pair(s) of unused index records, leading to a loss of'',
+ S I8,'' words'')') INUTIL,IPERTE
+ ENDIF
+C
+ ELSEIF (INTPPI.EQ.INBPIR) THEN
+C
+ IF (LFRANC) THEN
+ WRITE (UNIT=*,FMT='(TR15,5(''-''),TR3,''pas de paire '',
+ S ''d''''articles d''''index inutilises ni excedentaires'',
+ S TR3,5(''-''))')
+ ELSE
+ WRITE (UNIT=*,FMT='(TR15,5(''-''),TR3,''no pair of '',
+ S ''unused or overflow pages'',
+ S TR3,5(''-''))')
+ ENDIF
+C
+ ELSEIF (INTPPI.EQ.(INBPIR+1)) THEN
+ IPOSFI=ILARPH*(MDES1D(IXM(ILARPH,IRANG))+1)
+ IPOSDE=IPOSFI-2*ILARPH+1
+C
+ IF (LFRANC) THEN
+ WRITE (UNIT=*,FMT='(TR10,''une paire d''''articles '',
+ S ''d''''index excedentaires, de la position'',
+ S I9,'' a'',I9)')
+ S IPOSDE,IPOSFI
+ ELSE
+ WRITE (UNIT=*,FMT='(TR10,''one pair of overflow index '',
+ S ''pages ,from position'',
+ S I9,'' to'',I9)')
+ S IPOSDE,IPOSFI
+ ENDIF
+C
+ print *,' jdlfilaf BALISE 3'
+ ELSE
+ INEXCE=INTPPI-INBPIR
+C
+ IF (LFRANC) THEN
+ WRITE (UNIT=*,FMT='(TR10,I6,'' paires d''''articles '',
+ S ''d''''index excedentaires, des positions:'')') INEXCE
+C
+ DO 201 J=1,INEXCE
+ IPOSFI=ILARPH*(MDES1D(IXM(ILARPH+1-J,IRANG))+1)
+ IPOSDE=IPOSFI-2*ILARPH+1
+ WRITE (UNIT=*,FMT='(TR20,I9,'' a'',I9)') IPOSDE,IPOSFI
+ 201 CONTINUE
+C
+ ELSE
+ WRITE (UNIT=*,FMT='(TR10,I6,'' pairs of overflow index '',
+ S ''pages, from positions:'')') INEXCE
+C
+ DO 202 J=1,INEXCE
+ IPOSFI=ILARPH*(MDES1D(IXM(ILARPH+1-J,IRANG))+1)
+ IPOSDE=IPOSFI-2*ILARPH+1
+ WRITE (UNIT=*,FMT='(TR20,I9,'' to'',I9)') IPOSDE,IPOSFI
+ 202 CONTINUE
+C
+ ENDIF
+C
+ ENDIF
+C
+ ENDIF
+C
+ WRITE (UNIT=*,FMT='(//)')
+C**
+C 3. - RENSEIGNEMENTS INDIVIDUALISES SUR LES ARTICLES LOGIQUES.
+C (DONNEES, ET SUR OPTION TROUS REPERTORIES DANS L'INDEX)
+C-----------------------------------------------------------------------
+ print *,' jdlfilaf BALISE 4'
+C
+ IF (LFRANC) THEN
+C
+ IF (INBALO.EQ.0) THEN
+ WRITE (UNIT=*,FMT='(/,TR10,5(''=''),''> L''''unite logique'',
+ S I3,'' ne contient AUCUN ARTICLE LOGIQUE (ni donnees, ni trous)'',
+ S //)') KNUMER
+ GOTO 1001
+ ELSEIF (INBALO.EQ.INTROU) THEN
+ WRITE (UNIT=*,FMT='(/,TR10,5(''=''),''> L''''unite logique'',
+ S I3,'' ne contient QUE DES TROUS, pas de donnees)'',//)') KNUMER
+ IF (.NOT.LDTOUT) GOTO 1001
+ ENDIF
+C
+ ELSE
+C
+ IF (INBALO.EQ.0) THEN
+ WRITE (UNIT=*,FMT='(/,TR10,5(''=''),''> The logical unit'',I3,
+ S '' contains NO LOGICAL RECORD AT ALL (neither data, nor holes)'',
+ S //)') KNUMER
+ GOTO 1001
+ ELSEIF (INBALO.EQ.INTROU) THEN
+ WRITE (UNIT=*,FMT='(/,TR10,5(''=''),''> The logical unit'',I3,
+ S '' contains ONLY HOLES, no dat)'',//)') KNUMER
+ IF (.NOT.LDTOUT) GOTO 1001
+ ENDIF
+C
+ ENDIF
+C*
+C 3.1 - BALAYAGE DES PAIRES D'ARTICLES D'INDEX, PAR ORDRE CROISSANT
+C-----------------------------------------------------------------------
+C
+ INABAL=0
+ INALDI=0
+ INTROI=0
+ INPIMD=2
+ INPIMF=INPPIM
+ IF (NPODPI(IRANG).EQ.2) INPIMD=3
+ IF (NPODPI(IRANG).EQ.INPPIM) INPIMF=INPPIM-1
+ INPILE=2
+C
+ DO 319 JRGPIF=1,INTPPI
+ IRGPFS=JRGPIF+1
+C
+C On fait en sorte que la P.A.I. concernee, ainsi que sa suivante
+C eventuelle, soient toutes les deux en memoire.
+C
+ IF (JRGPIF.EQ.INTPPI) THEN
+ IRGPIM=MRGPIM(NPODPI(IRANG),IRANG)
+ GOTO 314
+C
+ ELSEIF (JRGPIF.NE.1) THEN
+C
+C Recherche de la P.A.I. dans les Paires de Pages d'Index memoire.
+C
+ DO 311 J=INPIMD,INPIMF
+ IRGPIM=MRGPIM(J,IRANG)
+C
+ IF (MRGPIF(IRGPIM).EQ.JRGPIF) THEN
+C
+ IF (.NOT.LPHASP(IRGPIM)) THEN
+C
+ CALL LFIPHA (IREP,IRANG,IRGPIM,IRETIN)
+C
+ IF (IRETIN.EQ.1) THEN
+ GOTO 903
+ ELSEIF (IRETIN.EQ.2) THEN
+ GOTO 904
+ ELSEIF (IRETIN.NE.0) THEN
+ GOTO 1001
+ ENDIF
+C
+ ENDIF
+C
+ GOTO 312
+C
+ ENDIF
+C
+ print *,' jdlfilaf BALISE 5'
+ 311 CONTINUE
+C
+C Mise en memoire de la Paire d'Articles d'Index cherchee.
+C
+ CALL LFIPIM (IREP,IRANG,IRANGM,IRGPIM,JRGPIF,IRGPFS,INPILE,
+ S IRETIN)
+C
+ IF (IRETIN.EQ.1) THEN
+ GOTO 903
+ ELSEIF (IRETIN.EQ.2) THEN
+ GOTO 904
+ ELSEIF (IRETIN.NE.0) THEN
+ GOTO 1001
+ ELSEIF (IRANGM.GT.INPPIM) THEN
+ INPPIM=IRANGM
+ INPIMF=INPPIM
+ ENDIF
+C
+ ELSE
+ IRGPIM=MRGPIM(1,IRANG)
+C
+ ENDIF
+C
+ 312 CONTINUE
+C
+ IF (IRGPFS.EQ.INTPPI) THEN
+ IRPIMS=MRGPIM(NPODPI(IRANG),IRANG)
+C
+ ELSE
+C
+C Recherche de la P.A.I. dans les Paires de Pages d'Index memoire.
+C
+ DO 313 J=INPIMD,INPIMF
+ IRPIMS=MRGPIM(J,IRANG)
+C
+ IF (MRGPIF(IRPIMS).EQ.IRGPFS) THEN
+C
+ IF (.NOT.LPHASP(IRPIMS)) THEN
+C
+ CALL LFIPHA (IREP,IRANG,IRPIMS,IRETIN)
+C
+ IF (IRETIN.EQ.1) THEN
+ GOTO 903
+ ELSEIF (IRETIN.EQ.2) THEN
+ GOTO 904
+ ELSEIF (IRETIN.NE.0) THEN
+ GOTO 1001
+ ENDIF
+C
+ ENDIF
+C
+ GOTO 314
+C
+ ENDIF
+C
+ 313 CONTINUE
+C
+C Mise en memoire de la Paire d'Articles d'Index cherchee.
+C
+ print *,' jdlfilaf BALISE 6'
+ CALL LFIPIM (IREP,IRANG,IRANGM,IRPIMS,IRGPFS,JRGPIF,INPILE,
+ S IRETIN)
+C
+ IF (IRETIN.EQ.1) THEN
+ GOTO 903
+ ELSEIF (IRETIN.EQ.2) THEN
+ GOTO 904
+ ELSEIF (IRETIN.NE.0) THEN
+ GOTO 1001
+ ELSEIF (IRANGM.GT.INPPIM) THEN
+ INPPIM=IRANGM
+ INPIMF=INPPIM
+ ENDIF
+C
+ ENDIF
+C
+ 314 CONTINUE
+ INALPI=MIN0 (INALPP,INBALO-INABAL)
+C
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ IF(JRGPIF .EQ. 1)THEN
+ CFICJD='FICJD'
+ CFICJDOUT='FICJDOUT'
+ CALL FMATTR(CFICJD,CFICJDOUT,IFICJD,IREP)
+ OPEN(UNIT=IFICJD,FILE=CFICJD,FORM='FORMATTED')
+ ENDIF
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C
+C Balayage de la Paire d'Article d'Index concernee.
+C
+ DO 318 J=1,INALPI
+C
+ IF (CNOMAR(IXC(J,IRGPIM)).NE.' ') THEN
+C
+C Il s'agit d'un article logique de donnees; en plus de ses
+C caracteristiques tabulees, on verifie s'il n'y a pas de la
+C place "perdue" juste derriere les donnees, place recuperable
+C eventuellement en cas de reecriture plus longue de l'article
+C logique.
+C
+ INALDI=INALDI+1
+ ILONGA=MLGPOS(IXM(2*J-1,IRGPIM))
+ IPOSDE=MLGPOS(IXM(2*J ,IRGPIM))
+ IPOSFI=IPOSDE+ILONGA-1
+C
+ IF (J.EQ.1.AND.JRGPIF.GT.INBPIR) THEN
+C
+C Cas du premier article logique d'une P.A.I. excedentaire;
+C dans ce cas, la P.A.I. est situee derriere l'article logique,
+C en occupant deux articles physiques.
+C
+ IRECPI=MDES1D(IXM(ILARPH+1-(JRGPIF-INBPIR),IRANG))
+ IDERPU=ILARPH*(IRECPI-1)
+C
+ ELSEIF (J.EQ.INALPI.AND.JRGPIF.EQ.INTPPI) THEN
+C
+C Cas du dernier article logique du fichier, sans P.A.I. situee
+C derriere: la derniere position utilisable sans modifier le nombre
+C d'articles physiques du fichier correspond a la fin du dernier
+C article physique contenant des donnees, ou a la fin du dernier
+C article physique ecrit sur le fichier.
+C
+ IMDESC=MDES1D(IXM(JPNAPH,IRANG))
+ IREC=MAX0 (1+(IPOSFI-1)/ILARPH,IMDESC)
+ IDERPU=ILARPH*IREC
+C
+C Si on arrive au test ci-dessous, on est sur que l'article lo-
+C gique n'est pas le dernier du fichier.
+C
+ ELSEIF (J.NE.INALPP) THEN
+C
+C Cas general, ou l'article logique n'est pas le dernier de sa
+C (Paire de) Page(s) d'Index.
+C
+ IDERPU=MLGPOS(IXM(2*J+2,IRGPIM))-1
+C
+ ELSE
+C
+C Cas particulier ou l'article logique est le dernier de sa
+C (Paire de) Page(s) d'Index.
+C
+ IDERPU=MLGPOS(IXM(2,IRPIMS))-1
+ ENDIF
+C
+ IF (IDERPU.EQ.IPOSFI) THEN
+C
+ IF (LFRANC) THEN
+ WRITE (UNIT=*,FMT='(I7,''-eme article de donnees: "'',A,
+ S ''",'',I7,'' mots, position'',I9,'' a'',I9)')
+ S INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA,IPOSDE,IPOSFI
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ WRITE (UNIT=IFICJD,FMT='(I7,'' '',A,'' '',I8)')
+ S INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ ELSE
+ WRITE (UNIT=*,FMT='(I7,''-th data record: "'',A,''",'',I7,
+ S '' words, position'',I9,'' to'',I9)')
+ S INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA,IPOSDE,IPOSFI
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ WRITE (UNIT=IFICJD,FMT='(I7,'' '',A,'' '',I8)')
+ S INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ ENDIF
+C
+ ELSE
+C
+C On visualise en plus la place "perdue" derriere l'article.
+C
+ IF (LFRANC) THEN
+ WRITE (UNIT=*,FMT='(I7,''-eme article de donnees: "'',A,
+ S ''",'',I7,'' mots, position'',I9,'' a'',I9,'' <'',SP,
+ S I8,'' >'')')
+ S INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA,IPOSDE,IPOSFI,IDERPU-IPOSFI
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ WRITE (UNIT=IFICJD,FMT='(I7,'' '',A,'' '',I8)')
+ S INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ ELSE
+ WRITE (UNIT=*,FMT='(I7,''-th data record: "'',A,''",'',I7,
+ S '' words, position'',I9,'' to'',I9,'' <'',SP,
+ S I8,'' >'')')
+ S INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA,IPOSDE,IPOSFI,IDERPU-IPOSFI
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ WRITE (UNIT=IFICJD,FMT='(I7,'' '',A,'' '',I8)')
+ S INALDI,CNOMAR(IXC(J,IRGPIM)),ILONGA
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ ENDIF
+C
+ ENDIF
+C
+ ELSEIF (LDTOUT) THEN
+ INTROI=INTROI+1
+ ILONGA=MLGPOS(IXM(2*J-1,IRGPIM))
+ IPOSDE=MLGPOS(IXM(2*J ,IRGPIM))
+ IPOSFI=IPOSDE+ILONGA-1
+C
+ IF (LFRANC) THEN
+ WRITE (UNIT=*,FMT='(TR1,5(''=''),''>'',T10,I6,
+ S ''-eme TROU repertorie dans l''''index, longueur reutilisable:'',
+ S I7,'' mots, position'',I9,'' a'',I9)')
+ S INTROI,ILONGA,IPOSDE,IPOSFI
+ ELSE
+ WRITE (UNIT=*,FMT='(TR1,5(''=''),''>'',T10,I6,
+ S ''-th HOLE cataloged within index, re-usable length:'',
+ S I7,'' words, position'',I9,'' to'',I9)')
+ S INTROI,ILONGA,IPOSDE,IPOSFI
+ ENDIF
+C
+ ENDIF
+C
+ 318 CONTINUE
+C
+ INABAL=INABAL+INALPI
+ 319 CONTINUE
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+ CLOSE(IFICJD)
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC JDJDJD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+CCCCCCCCCCCCCCC didier
+ call FMFREE(CFICJD,CFICJDOUT,IREP)
+CCCCCCCCCCCCCCC didier
+C*
+C 3.2 - ENVOI DE MESSAGES RECAPITULATIFS.
+C-----------------------------------------------------------------------
+C
+ IF (LFRANC) THEN
+C
+ IF (LDTOUT) THEN
+ WRITE (UNIT=*,FMT='(//,T5,8(''-''),TR3,I7,
+ S '' articles logiques de donnees et'',I6,
+ S '' trous repertories listes'',TR3,8(''-''),//)')
+ S INALDI,INTROI
+ ELSE
+ WRITE (UNIT=*,FMT='(//,T5,8(''-''),TR3,I7,
+ S '' articles logiques de donnees listes'',TR3,8(''-''),//)')
+ S INALDI
+ ENDIF
+C
+ ELSE
+C
+ IF (LDTOUT) THEN
+ WRITE (UNIT=*,FMT='(//,T5,8(''-''),TR3,I7,
+ S '' logical records of data and'',I6,
+ S '' holes within index listed'',TR3,8(''-''),//)')
+ S INALDI,INTROI
+ ELSE
+ WRITE (UNIT=*,FMT='(//,T5,8(''-''),TR3,I7,
+ S '' logical records of data listed'',TR3,8(''-''),//)')
+ S INALDI
+ ENDIF
+C
+ ENDIF
+C
+ IF (INALDI.EQ.INALDO.AND.(.NOT.LDTOUT.OR.INTROI.EQ.INTROU)) THEN
+C
+ IF (LFRANC) THEN
+ WRITE (UNIT=CLMESS,FMT=
+ S '(''Fin du catalogue de l''''Unite Logique'',I3,'' ---'',I7,
+ S '' Articles logiques en tout'')') KNUMER,INBALO
+ ELSE
+ WRITE (UNIT=CLMESS,FMT=
+ S '(''End of catalog of Logical Unit'',I3,'' ---'',I7,
+ S '' logical Records for whole file'')') KNUMER,INBALO
+ ENDIF
+C
+ CALL LFIEMS (KNUMER,INIMES,IREP,LLFATA,CLMESS,CLNSPR,CLACTI)
+ WRITE (UNIT=*,FMT='(///)')
+ ELSE
+ IREP=-16
+ ENDIF
+C
+ GOTO 1001
+C**
+C 9. - CI-DESSOUS, ETIQUETTES DE BRANCHEMENT EN CAS D'ERREUR E/S.
+C-----------------------------------------------------------------------
+C
+ 903 CONTINUE
+ CLACTI='WRITE'
+ GOTO 909
+C
+ 904 CONTINUE
+ CLACTI='READ'
+C
+ 909 CONTINUE
+C
+C AU CAS OU, ON FORCE LE CODE-REPONSE ENTREE/SORTIE A ETRE POSITIF.
+C
+ IREP=IABS (IREP)
+C**
+C 10. - PHASE TERMINALE : MESSAGERIE, AVEC "ABORT" EVENTUEL,
+C VIA LE SOUS-PROGRAMME "LFIEMS" .
+C-----------------------------------------------------------------------
+C
+ 1001 CONTINUE
+ KREP=IREP
+ LLFATA=LLMOER (IREP,IRANG)
+C
+ IF (IRANG.NE.0) THEN
+ NDEROP(IRANG)=18
+ NDERCO(IRANG)=IREP
+ IF (LMULTI) CALL LFIVER (VERRUE(IRANG),'OFF')
+ ENDIF
+ print *,' jdlfilaf BALISE 7'
+C
+ IF (LLFATA.OR.IXNIMS (IRANG).EQ.2) THEN
+ INIMES=2
+ ELSE
+ RETURN
+ ENDIF
+C
+ WRITE (UNIT=CLMESS,FMT='(''KREP='',I4,'', KNUMER='',I3,
+ S '', LDTOUT= '',L1)') KREP,KNUMER,LDTOUT
+ CALL LFIEMS (KNUMER,INIMES,IREP,LLFATA,CLMESS,CLNSPR,CLACTI)
+ print *,' jdlfilaf BALISE 8'
+C
+ RETURN
+ END
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/lficom0.h b/LIBTOOLS/tools/diachro/src/FM2DIA/lficom0.h
new file mode 100644
index 0000000000000000000000000000000000000000..e9e355ee5abb35f4c5891e126570d82d1c61bcd7
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/lficom0.h
@@ -0,0 +1,165 @@
+C
+C----- DESCRIPTION DES "PARAMETER" DU LOGICIEL DE FICHIERS INDEXES -----
+C----- (et des variables logiques a charger absolument partout ) -----
+C
+C JPNBIM = NOMBRE DE BITS PAR MOT MACHINE
+C JPNBIC = NOMBRE DE BITS PAR CARACTERE
+C JPNCMO = NOMBRE DE CARACTERES PAR MOT MACHINE
+C
+C JPNCPN = NOMBRE MAXI. POSSIBLE DE CARACTERES PAR NOM D'ARTICLE
+C JPLARD = LONGUEUR D'ARTICLE "PHYSIQUE" elementaire des Fichiers
+C ( exprimee en mots, DOIT ETRE PAIRE, SUPERIEURE OU EGALE
+C a JPLDOC, JPLARD*JPNCMO DOIT ETRE MULTIPLE DE JPNCPN )
+C JPLARC = Longueur d'article "physique" exprimee en caracteres
+C JPRECL = PARAMETRE "RECL" de base POUR "OPEN" DES FICHIERS
+C JPNXFI = NOMBRE MAXIMUM DE FICHIERS INDEXES OUVERTS SIMULTANEMENT
+C (1 fichier de "multiplicite" N comptant comme N fichiers)
+C JPFACX = FACteur multiplicateur maXimum entre longueur d'article
+C physique effective et elementaire ( de 1 a JPNXFI )
+C JPXUFM = Nombre maXimum d'Unites logiques a Facteur Mul. predefini
+C JPNPIA = NOMBRE DE *PAIRES* DE "PAGES D'INDEX" EN MEMOIRE
+C *PREALLOUEES* PAR UNITE LOGIQUE ( AU MOINS *4* )
+C JPNXPI = NOMBRE TOTAL DE *PAIRES* DE "PAGES D'INDEX" EN MEMOIRE
+C ALLOUABLES ( DOIT ETRE AU MOINS EGAL A JPNPIA*JPNXFI )
+C JPNPIS = NOMBRE DE *PAIRES* DE "PAGES D'INDEX" NON PREALLOUEES
+C JPNXNA = NOMBRE MAXI. DE NOMS D'ARTICLES PAR PAGE/ARTICLE D'INDEX
+C JPNBLP = NOMBRE MAXI. DE COUPLES (LONGUEUR/POSITION)" " "
+C JPNAPP = NOMBRE MAXI. UTILE DE NOMS D'ARTICLES PAR PAGE/AR D'INDEX
+C JPLDOC = LONGUEUR (MOTS) DE LA PARTIE DOCUMENTAIRE DU 1ER ARTICLE
+C JPNPDF = NOMBRE DE PAGES DE DONNEES PAR FICHIER OUVERT ( >= 2 )
+C JPNXPR = NOMBRE MAXIMUM DE PAIRES D'ARTICLES D'INDEX RESERVABLES
+C JPNIL = CODE DE "VALEUR ABSENTE" POUR CERTAINES TABLES D'ENTIERS.
+C JPNMPN = NOMBRE DE MOTS NECESSAIRE AU STOCKAGE D'UN NOM D'ARTICLE
+C JPNAPX = JPNAPP*JPFACX
+C JPLARX = JPLARD*JPFACX = longueur d'article physique maximale
+C JPLFTX = Longueur maximale traitable des noms de fichiers.
+C JPLFIX = " " imprimable " " " " .
+C JPLSPX = " " des noms des sous-programmes du logiciel.
+C JPLSTX = " " des valeurs du "STATUS" FORTRAN (open/close).
+C JPCFMX = Nombre maximum de ConFigurations pour iMport/eXport.
+C JPIMEX = " " de fichiers imp/exportables "simultanement".
+C JPDEXP = Dimension tableau Descripteurs EXPlicites d'imp/export.
+C JPDIMP = " " " IMPlicites " " " .
+C JPXDAM = Nombre maXimum noms D'Articles d'imp/export en Memoire.
+C JPXCIE = " " de Caracteres par nom pour Import/Export.
+C JPXMET = " " " " " " avec METacaracteres.
+C JPXCCF = " " " " des noms de ConFig. imp/exp.
+C JPTYMX = " de TYpes de variables valides pour Import/Export.
+C
+C LPCRAY = VRAI SI L'ON TRAVAILLE SUR CRAY ( "WHENEQ" UTILISABLE )
+C LPRECH = VRAI SI L'ON PEUT UTILISER LA RECHERCHE "RAPIDE" DES NOMS
+C
+ INTEGER JPNBIM, JPNBIC, JPNCPN, JPLARD, JPNPDF, JPXUFM, JPNXFI
+ INTEGER JPNPIA, JPNXPI, JPNXPR, JPLDOC, JPNIL, JPNCMO, JPLARC
+ INTEGER JPXMET, JPRECL, JPFACX, JPLFTX, JPLFIX, JPLSPX, JPLSTX
+ INTEGER JPIMEX, JPDEXP, JPDIMP, JPXDAM, JPXCIE, JPCFMX, JPXCCF
+ INTEGER JPNXNA, JPNBLP, JPNAPP, JPNPIS, JPNAPX, JPNMPN, JPLARX
+ INTEGER JPTYMX
+C
+ LOGICAL LPCRAY, LPRECH
+C
+ PARAMETER ( JPNCPN=16, JPLARD=512, JPNPDF=20, JPXUFM=100 )
+ PARAMETER ( JPNXFI=300, JPFACX=120, JPNPIA=4, JPNXPR=100 )
+C
+C Implementation-dependent symbolic constants (except for JPNCMO and
+C JPLARC definitions, which are there to have only one set of
+C "ifdef" in current header).
+C
+#if defined(RS6K) || defined(VPP) || defined(T3D) || defined(HPPA) || defined(SUN) || defined(O2000) || defined(LINUX)
+ PARAMETER ( JPNBIM=64, JPNBIC=8, LPCRAY=.FALSE. )
+ PARAMETER ( JPNCMO=JPNBIM/JPNBIC )
+ PARAMETER ( JPLARC=JPNCMO*JPLARD )
+ PARAMETER ( JPRECL=JPLARC )
+#else
+#if defined(DEC)
+ PARAMETER ( JPNBIM=64, JPNBIC=8, LPCRAY=.FALSE. )
+ PARAMETER ( JPNCMO=JPNBIM/JPNBIC )
+ PARAMETER ( JPLARC=JPNCMO*JPLARD )
+ PARAMETER ( JPRECL=2*JPLARD )
+#else
+#if defined(HP)
+ PARAMETER ( JPNBIM=32, JPNBIC=8, LPCRAY=.FALSE. )
+ PARAMETER ( JPNCMO=JPNBIM/JPNBIC )
+ PARAMETER ( JPLARC=JPNCMO*JPLARD )
+ PARAMETER ( JPRECL=JPLARC )
+#else
+#if defined(SX4)
+ PARAMETER ( JPNBIM=64, JPNBIC=8, LPCRAY=.FALSE. )
+ PARAMETER ( JPNCMO=JPNBIM/JPNBIC )
+ PARAMETER ( JPLARC=JPNCMO*JPLARD )
+ PARAMETER ( JPRECL=JPLARD )
+#else
+
+C CRAY IS DEFAULT
+ PARAMETER ( JPNBIM=64, JPNBIC=8, LPCRAY=.TRUE. )
+ PARAMETER ( JPNCMO=JPNBIM/JPNBIC )
+ PARAMETER ( JPLARC=JPNCMO*JPLARD )
+ PARAMETER ( JPRECL=JPLARC )
+#endif
+#endif
+#endif
+#endif
+ PARAMETER ( JPLDOC=22, JPNIL=-999, JPXMET=2*JPNCPN, JPCFMX=4 )
+ PARAMETER ( JPNXPI=JPNPIA*JPNXFI+2*JPFACX, JPXCIE=2*JPNCPN )
+ PARAMETER ( JPLFTX=512, JPLFIX=128, JPLSPX=6, JPLSTX=7, JPTYMX=5 )
+ PARAMETER ( JPIMEX=2, JPDEXP=10000, JPDIMP=1000, JPXDAM=1000 )
+ PARAMETER ( JPNXNA=(JPLARD*JPNCMO)/JPNCPN, JPNBLP=JPLARD/2 )
+ PARAMETER ( JPNAPP=(JPNBLP*(JPNXNA/JPNBLP)+JPNXNA*(JPNBLP/JPNXNA))
+ S /(JPNXNA/JPNBLP+JPNBLP/JPNXNA), JPXCCF=16 )
+ PARAMETER ( JPNPIS=JPNXPI-JPNPIA*JPNXFI, JPNAPX=JPNAPP*JPFACX )
+ PARAMETER ( JPNMPN=1+(JPNCPN-1)/JPNCMO, JPLARX=JPLARD*JPFACX )
+ PARAMETER ( LPRECH=(JPNCPN.EQ.(JPNMPN*JPNCMO)).AND.LPCRAY )
+C
+C---------- VARIABLES LOGIQUES A CHARGER ABSOLUMENT PARTOUT ------------
+C
+C LMISOP = VRAI SI ON DOIT TRAVAILLER EN MODE MISE AU POINT LOGICIEL
+C LFRANC = Vrai/Faux si la messagerie doit etre en francais/anglais
+C
+ LOGICAL LMISOP, LFRANC
+C
+ COMMON /LFIMAP/ LMISOP, LFRANC
+C
+C-------- DESCRIPTION DE LA PARTIE DOCUMENTAIRE DU 1ER ARTICLE ---------
+C
+C MOT 1 ==> LONGUEUR "PHYSIQUE" Effective DES ARTICLES (EN MOTS)
+C MOT 2 ==> LONGUEUR MAXIMUM DES NOMS D'ARTICLES (CARACTERES)
+C MOT 3 ==> "DRAPEAU" SIGNALANT SI LE FICHIER A BIEN ETE FERME
+C APRES LA DERNIERE MODIFICATION
+C MOT 4 ==> LONGUEUR DE LA PARTIE DOCUMENTAIRE DU FICHIER
+C MOT 5 ==> NOMBRE D'ARTICLES "PHYSIQUES" DANS LE FICHIER
+C MOT 6 ==> " " LOGIQUES " " "
+C (Y COMPRIS LES "TROUS" CREES PAR LES REECRITURES
+C D'ARTICLES PLUS LONGUES QUE PRECEDEMMENT, ET N'AYANT
+C PAS ENCORE PU ETRE REUTILISES, COMPTES DANS LE MOT 21)
+C MOT 7 ==> LONGUEUR MINI. DES ARTICLES LOGIQUES DE DONNEES (MOTS)
+C MOT 8 ==> " MAXI. " " " " " "
+C MOT 9 ==> " TOTALE " " " " " "
+C MOT 10 ==> NOMBRE DE REECRITURES SUR PLACE (VRAIES)
+C MOT 11 ==> " " " PLUS COURTES
+C MOT 12 ==> " " " " LONGUES
+C MOT 13 ==> NOMBRE MAXIMUM D'ARTICLES PAR PAGE OU ARTICLE D'INDEX
+C MOT 14 ==> DATE DE LA CREATION DU FICHIER (1ERE OUVERTURE)
+C MOT 15 ==> HEURE " " " " " ( " " )
+C MOT 16 ==> DATE DE LA DERNIERE MODIFICATION GARANTIE (FERMETURE)
+C MOT 17 ==> HEURE " " " " " ( " )
+C MOT 18 ==> DATE DE LA 1ERE MODIFICATION PAS FORCEMENT GARANTIE
+C MOT 19 ==> HEURE " " " " " " "
+C (LES MODIFICATIONS NE SONT GARANTIES QUE SI LE MOT 4 VAUT ZERO)
+C MOT 20 ==> NOMBRE DE PAIRES D'ARTICLES D'INDEX PRERESERVES .
+C MOT 21 ==> NOMBRE DE "TROUS" CORRESP. A DES REECRITURES + LONGUES
+C ( AVANT OUVERTURE )
+C MOT 22 ==> NUMERO D'ARTICLE MAXI. DES ARTICLES PHYSIQ. DE DONNEES
+C
+C------ "PARAMETER" DECRIVANT LES POSITIONS DES ENTITES CI-DESSUS ------
+C
+ INTEGER JPLPAR, JPLMNA, JPFEAM, JPLLDO, JPNAPH, JPNALO, JPLNAL
+ INTEGER JPLXAL, JPLTAL, JPNRES, JPNREC, JPNREL, JPXAPI, JPDCRE
+ INTEGER JPHCRE, JPDDMG, JPHDMG, JPDMNG, JPHMNG, JPNPIR, JPNTRU
+ INTEGER JPAXPD
+C
+ PARAMETER ( JPLPAR=1, JPLMNA=2, JPFEAM=3, JPLLDO=4, JPNAPH=5 )
+ PARAMETER ( JPNALO=6, JPLNAL=7, JPLXAL=8, JPLTAL=9, JPNRES=10 )
+ PARAMETER ( JPNREC=11, JPNREL=12, JPXAPI=13, JPDCRE=14 )
+ PARAMETER ( JPHCRE=15, JPDDMG=16, JPHDMG=17, JPDMNG=18 )
+ PARAMETER ( JPHMNG=19, JPNPIR=20, JPNTRU=21, JPAXPD=22 )
+C
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/read_and_write_dimgridref.f90 b/LIBTOOLS/tools/diachro/src/FM2DIA/read_and_write_dimgridref.f90
new file mode 100644
index 0000000000000000000000000000000000000000..89cfc95cc70081d5ca4cebc05850ee5e477ff5c2
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/read_and_write_dimgridref.f90
@@ -0,0 +1,341 @@
+! ######spl
+ MODULE MODI_READ_AND_WRITE_DIMGRIDREF
+! #####################################
+!
+INTERFACE
+!
+SUBROUTINE READ_AND_WRITE_DIMGRIDREF(K,HNAMFILE,HLUOUT)
+INTEGER :: K
+CHARACTER(LEN=*) :: HNAMFILE, HLUOUT
+END SUBROUTINE READ_AND_WRITE_DIMGRIDREF
+!
+END INTERFACE
+!
+END MODULE MODI_READ_AND_WRITE_DIMGRIDREF
+! #######################################################
+ SUBROUTINE READ_AND_WRITE_DIMGRIDREF(K,HNAMFILE,HLUOUT)
+! #######################################################
+!
+!!**** *READ_AND_WRITE_DIMGRIDREF* - Lecture et ecriture des parametres
+!! "intouchables" et des profils 1D de l'etat de reference
+!!
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+! Lecture des dimensions par appel a SET_GRID
+! " parametres de grilles par appel a SET_GRID
+! " des 3 var. de l'etat de ref.
+! Ecriture de toutes ces informations dans le fichier diachronique
+! par appel a WRITE_DIMGRIDREF
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHORS
+!! -------
+!! J. Duron *Lab. Aerologie*
+!!
+!! Copyright 1994, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/01/96
+!! Modification 291196 CSTORAGE_TYPE forced to 'PG' (temp.)
+!! Modification 01/2003 suppression de l appel a SET_REF_FORDIACHRO
+! (=SET_REF modifie en supprimant toute la partie calculs inutile)
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_DIACHRO, ONLY: CMY_NAME_DIA, CDAD_NAME_DIA
+USE MODD_DIM1 ! NIMAX,NJMAX,NKMAX, NIINF,NISUP, NJINF,NJSUP
+USE MODD_DIMGRID_FORDIACHRO, ONLY: NNBF
+USE MODD_GRID ! XLON0,XLAT0, XBETA,XRPK
+USE MODD_GRID1
+USE MODD_OUT_DIA, ONLY : NLUOUTD
+USE MODD_OUT1
+USE MODD_PARAMETERS
+USE MODD_DYN , ONLY: XSEGLEN
+USE MODD_DYN1, ONLY: XTSTEP
+USE MODD_CONF, ONLY: CCONF,CSTORAGE_TYPE,LCARTESIAN
+USE MODD_TIME
+USE MODD_TIME1
+USE MODD_REF ! XRHODREFZ,XTHVREFZ,XEXNTOP
+USE MODD_REA_LFI
+!
+USE MODI_SET_DIM
+USE MODI_SET_GRID
+USE MODI_WRITE_DIMGRIDREF
+USE MODI_FMREAD
+!
+!* 0.1 Dummy arguments
+!
+
+INTEGER :: K
+
+CHARACTER(LEN=*) :: HNAMFILE
+CHARACTER(LEN=*) :: HLUOUT
+!
+!* 0.2 Local variables declarations
+!
+!
+INTEGER :: JJ, J
+INTEGER :: IIU, IJU, IKU ! Upper bounds in x, y, z directions
+INTEGER :: IIB, IJB, IKB ! Begining useful area in x, y, z directions
+INTEGER :: IIE, IJE, IKE ! End useful area in x, y, z directions
+!
+REAL :: ZLAT,ZLON ! Emagram soundings gridpoint location
+ ! latitude and longitude (decimal degrees)
+REAL :: ZX,ZY ! Emagram soundings gridpoint location
+ ! cartesian east and north coordinates (meters)
+!
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: ZJ ! Jacobian
+!
+REAL,DIMENSION(:), ALLOCATABLE,SAVE :: IIMAX, IJMAX, IKMAX, ITIMECUR
+REAL,DIMENSION(:), ALLOCATABLE,SAVE :: ZLON0, ZRPK, ZLONOR, ZLATOR, ZLAT0, &
+ ZBETA
+LOGICAL,DIMENSION(:), ALLOCATABLE,SAVE :: OCARTESIAN
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Preseting the general FM2DIACHRO environment
+! ---------------------------------------
+!
+!* 1.1 Sets default values
+!
+CCONF='POSTP'
+!
+!* 1.6 Reads the LFIFM file initial section (i.e. Array dimensions)
+!
+NIINF=0 ; NISUP=0 ; NJINF=0 ; NJSUP=0
+!
+CALL SET_DIM(HNAMFILE,HLUOUT,NIINF,NISUP,NJINF,NJSUP,NIMAX,NJMAX,NKMAX)
+!
+CMY_NAME_DIA(1:LEN(CMY_NAME_DIA))=' '
+CRECFM='MY_NAME'
+NLENG=28
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,CMY_NAME_DIA,NGRID,NLENCH,CCOMMENT,NRESP)
+!
+CDAD_NAME_DIA(1:LEN(CDAD_NAME_DIA))=' '
+CRECFM='DAD_NAME'
+NLENG=28
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,CDAD_NAME_DIA,NGRID,NLENCH,CCOMMENT,NRESP)
+print *,'CMY_name CDAD_name ',CMY_NAME_DIA,CDAD_NAME_DIA
+!
+! Reads the geometry configuration selector
+CRECFM='THINSHELL'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,LTHINSHELL,NGRID,NLENCH,CCOMMENT,NRESP)
+!
+CRECFM='CARTESIAN'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,LCARTESIAN,NGRID,NLENCH,CCOMMENT,NRESP)
+!
+CRECFM='STORAGE_TYPE'
+NLENG=2
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,CSTORAGE_TYPE,NGRID,NLENCH,CCOMMENT,NRESP)
+IF(NRESP /= 0) CSTORAGE_TYPE='MT'
+!
+!
+!* 1.7 Allocates the first bunch of input arrays
+!
+!* 1.7.1 Local variables :
+!
+IIU=NIMAX+2*JPHEXT ; IJU=NJMAX+2*JPHEXT ; IKU=NKMAX+2*JPVEXT
+!
+print *,' READ_AND_WRITE_DIMGRIDREF ENTREE CSTORAGE_TYPE ',CSTORAGE_TYPE
+IF(CSTORAGE_TYPE == 'PG')THEN
+ IKU=1
+ LCARTESIAN=.FALSE.
+ NKMAX=1
+ENDIF
+!
+IIB=1+JPHEXT ; IIE=IIU-JPHEXT
+IJB=1+JPHEXT ; IJE=IJU-JPHEXT
+IKB=1+JPVEXT ; IKE=IKU-JPVEXT
+WRITE(NLUOUTD,*) 'MAIN: IIB, IJB, IKB=',IIB,IJB,IKB
+WRITE(NLUOUTD,*) 'MAIN: IIE, IJE, IKE=',IIE,IJE,IKE
+WRITE(NLUOUTD,*) 'MAIN: IIU, IJU, IKU=',IIU,IJU,IKU
+!
+!
+IF(K == 1)THEN ! premier fichier
+ ALLOCATE(ZJ(IIU,IJU,IKU))
+ !
+ !* 1.7.2 Grid variables (MODD_GRID1 module):
+ !
+ ALLOCATE(XXHAT(IIU),XYHAT(IJU),XZHAT(IKU))
+ ALLOCATE(XMAP(IIU,IJU))
+ ALLOCATE(XLAT(IIU,IJU))
+ ALLOCATE(XLON(IIU,IJU))
+ ALLOCATE(XDXHAT(IIU),XDYHAT(IJU))
+ ALLOCATE(XZS(IIU,IJU))
+ ALLOCATE(XZZ(IIU,IJU,IKU))
+ !
+ !* 1.7.3 Reference state variables (MODD_REF1 module):
+ !
+ ALLOCATE(XRHODREFZ(IKU),XTHVREFZ(IKU))
+ !
+ XXHAT=0. ; XYHAT=0. ; XZHAT=0. ; XMAP=0. ; XLAT=0. ; XLON=0.
+ XDXHAT=0. ; XDYHAT=0. ; XZS=0. ; XZZ=0.
+ XRHODREFZ=0. ; XTHVREFZ=0.; XEXNTOP=0.
+ ALLOCATE(IIMAX(NNBF),IJMAX(NNBF),IKMAX(NNBF),ITIMECUR(NNBF))
+ ALLOCATE(ZLON0(NNBF),ZRPK(NNBF),ZLONOR(NNBF),ZLATOR(NNBF),ZLAT0(NNBF),ZBETA(NNBF))
+ ALLOCATE(OCARTESIAN(NNBF))
+ !
+ENDIF
+!
+!* 1.8 Reads the last section of the LFIFM file
+!
+! Notice: The whole XXHAT, XYHAT arrays have to be set here
+! to make provision for any grid selector choice
+!
+NIINF=1 ; NISUP=IIU
+NJINF=1 ; NJSUP=IJU
+! Artifice pour eviter 1 plantage dans SET_GRID
+XTSTEP=50.
+XSEGLEN=500.
+!
+CALL SET_GRID(1,HNAMFILE,HLUOUT,IIU,IJU,IKU,NIINF,NISUP,NJINF,NJSUP,XTSTEP,&
+ XSEGLEN, XOUT1,XOUT2,XOUT3,XOUT4,XOUT5,XOUT6,XOUT7,XOUT8, &
+ XOUT9,XOUT10,XOUT11,XOUT12,XOUT13,XOUT14,XOUT15, &
+ XOUT16,XOUT17,XOUT18,XOUT19,XOUT20, &
+ XLONOR,XLATOR,XLON,XLAT,XXHAT,XYHAT, &
+ XDXHAT,XDYHAT,XMAP,XZS,XZZ,XZHAT, &
+ ZJ, &
+ TDTMOD,TDTCUR,NSTOP,NOUT_TIMES,NOUT_NUMB )
+!
+IF(CSTORAGE_TYPE == 'PG')THEN
+ IKU=1
+ LCARTESIAN=.FALSE.
+ NKMAX=1
+ TDTMOD%TIME=0.
+ TDTCUR%TIME=0.
+ TDTEXP%TIME=0.
+ TDTSEG%TIME=0.
+ TDTMOD%TDATE%YEAR=0.
+ TDTMOD%TDATE%MONTH=0.
+ TDTMOD%TDATE%DAY=0.
+ TDTCUR%TDATE%YEAR=0.
+ TDTCUR%TDATE%MONTH=0.
+ TDTCUR%TDATE%DAY=0.
+ TDTEXP%TDATE%YEAR=0.
+ TDTEXP%TDATE%MONTH=0.
+ TDTEXP%TDATE%DAY=0.
+ TDTSEG%TDATE%YEAR=0.
+ TDTSEG%TDATE%MONTH=0.
+ TDTSEG%TDATE%DAY=0.
+ENDIF
+!
+!* 1.9 read 3 variables of ref. state without orography (SET_REF)
+!
+CRECFM='STORAGE_TYPE'
+NLENG=2
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,CSTORAGE_TYPE,NGRID,NLENCH,CCOMMENT,NRESP)
+!
+CRECFM='RHOREFZ'
+NLENG=SIZE(XRHODREFZ)
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,XRHODREFZ,NGRID,NLENCH,CCOMMENT,NRESP)
+IF(NRESP == -47)THEN
+ print *,' XRHODREFZ ABSENT dans le fichier ',TRIM(HNAMFILE),': MIS a 0. '
+ XRHODREFZ(:)=0.
+ENDIF
+!
+CRECFM='THVREFZ'
+NLENG=SIZE(XTHVREFZ)
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,XTHVREFZ,NGRID,NLENCH,CCOMMENT,NRESP)
+IF(NRESP == -47)THEN
+ print *,' XTHVREFZ ABSENT dans le fichier ',TRIM(HNAMFILE),': MIS a 0. '
+ XTHVREFZ(:)=0.
+ENDIF
+!
+CRECFM='EXNTOP'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,XEXNTOP,NGRID,NLENCH,CCOMMENT,NRESP)
+IF(NRESP == -47)THEN
+ print *,' XEXNTOP ABSENT dans le fichier ',TRIM(HNAMFILE),': MIS a 0. '
+ XEXNTOP=0.
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. WRITING OR CHECKING DIM., GRID., REF. VARIABLES
+! -----------------------------------------------
+!
+IIMAX(K)=NIMAX ; IJMAX(K)=NJMAX ; IKMAX(K)=NKMAX
+ITIMECUR(K)=TDTCUR%TIME
+!
+ZLON0(K)=XLON0 ; ZLAT0(K)=XLAT0
+ZLONOR(K)=XLONOR ; ZLATOR(K)=XLATOR
+ZRPK(K)=XRPK ; ZBETA(K)=XBETA
+!
+OCARTESIAN(K)=LCARTESIAN
+!
+!
+IF(K == 1)THEN ! premier fichier
+ !
+ CALL WRITE_DIMGRIDREF
+ !
+ENDIF
+!
+IF(K > 1)THEN ! fichiers suivants
+ !
+ IF(IIMAX(K) /= IIMAX(1))THEN
+ PRINT *,' K IIMAX(K) IIMAX(1) ',K,IIMAX(K),IIMAX(1)
+ ENDIF
+ IF(IJMAX(K) /= IJMAX(1))THEN
+ PRINT *,' K IJMAX(K) IJMAX(1) ',K,IJMAX(K),IJMAX(1)
+ ENDIF
+ IF(IKMAX(K) /= IKMAX(1))THEN
+ PRINT *,' K IKMAX(K) IKMAX(1) ',K,IKMAX(K),IKMAX(1)
+ ENDIF
+ IF(ITIMECUR(K) /= ITIMECUR(1))THEN
+ PRINT *,' K ITIMECUR(K) ITIMECUR(1) ',K,ITIMECUR(K),ITIMECUR(1)
+ ENDIF
+ !
+ IF(ZLON0(K) /= ZLON0(1))THEN
+ PRINT *,' K ZLON0(K) ZLON0(1) ',K,ZLON0(K),ZLON0(1)
+ ENDIF
+ IF(ZRPK(K) /= ZRPK(1))THEN
+ PRINT *,' K ZRPK(K) ZRPK(1) ',K,ZRPK(K),ZRPK(1)
+ ENDIF
+ IF(ZLONOR(K) /= ZLONOR(1))THEN
+ PRINT *,' K ZLONOR(K) ZLONOR(1) ',K,ZLONOR(K),ZLONOR(1)
+ ENDIF
+ IF(ZLATOR(K) /= ZLATOR(1))THEN
+ PRINT *,' K ZLATOR(K) ZLATOR(1) ',K,ZLATOR(K),ZLATOR(1)
+ ENDIF
+ IF(ZLAT0(K) /= ZLAT0(1))THEN
+ PRINT *,' K ZLAT0(K) ZLAT0(1) ',K,ZLAT0(K),ZLAT0(1)
+ ENDIF
+ IF(ZBETA(K) /= ZBETA(1))THEN
+ PRINT *,' K ZBETA(K) ZBETA(1) ',K,ZBETA(K),ZBETA(1)
+ ENDIF
+ !
+ IF((OCARTESIAN(K) .AND..NOT. OCARTESIAN(1)) .OR. &
+ (.NOT. OCARTESIAN(K) .AND. OCARTESIAN(1)))THEN
+ PRINT *,' K OCARTESIAN(K) OCARTESIAN(1) ',K,OCARTESIAN(K),OCARTESIAN(1)
+ ENDIF
+ !
+ENDIF
+!------------------------------------------------------------------------------
+!
+!* 4. EPILOG
+! ------
+!
+IF(K == NNBF)THEN ! dernier fichier
+ DEALLOCATE(IIMAX,IJMAX,IKMAX,ITIMECUR)
+ DEALLOCATE(ZLON0,ZRPK,ZLONOR,ZLATOR,ZLAT0,ZBETA)
+ DEALLOCATE(OCARTESIAN)
+END IF
+!
+RETURN
+
+END SUBROUTINE READ_AND_WRITE_DIMGRIDREF
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/read_diachro.f90 b/LIBTOOLS/tools/diachro/src/FM2DIA/read_diachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a4a9b31385d72387479307d431ca3692e6b3e691
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/read_diachro.f90
@@ -0,0 +1,487 @@
+! ######spl
+ MODULE MODI_READ_DIACHRO
+! ########################
+!
+INTERFACE
+!
+SUBROUTINE READ_DIACHRO(HFILEDIA,HLUOUTDIA,HGROUP)
+CHARACTER(LEN=*) :: HFILEDIA,HLUOUTDIA
+CHARACTER(LEN=*) :: HGROUP
+END SUBROUTINE READ_DIACHRO
+!
+END INTERFACE
+END MODULE MODI_READ_DIACHRO
+! ##################################################
+ SUBROUTINE READ_DIACHRO(HFILEDIA,HLUOUTDIA,HGROUP)
+! ##################################################
+!
+!!**** *READ_DIACHRO* - Lecture d'un enregistrement dans un fichier
+!! diachronique
+
+!! PURPOSE
+!! -------
+!! Permet la lecture d'un enregistrement de nom HGROUP
+!! (En realite, il s'agit de plusieurs enregistrements
+!! identifies par un nom=HGROUP+1suffixe)
+!
+!
+!!** METHOD
+!! ------
+!! En fonction du nom passe dans HGROUP , on lit un 1er enregistrement
+!! qui fournit le type d'informations a traiter. Puis ce type donne
+!! acces a un 2eme enregistrement contenant les dimensions de
+!! toutes les matrices qui seront lues dans les articles suivants
+!! et qui sont donc allouees dynamiquement a ce moment.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/02/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_TYPE_AND_LH
+USE MODD_RESOLVCAR
+USE MODD_DIM1
+USE MODD_ALLOC_FORDIACHRO
+USE MODI_ALLOC_FORDIACHRO
+USE MODI_FMREAD
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HFILEDIA,HLUOUTDIA
+CHARACTER(LEN=*) :: HGROUP
+
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+CHARACTER(LEN=16) :: YRECFM, YTEM
+CHARACTER(LEN=LEN(HFILEDIA)+4) :: YFILEDIA
+! Aout 99 longueur YCOMMENT passee de 20 a 100
+CHARACTER(LEN=100) :: YCOMMENT
+CHARACTER(LEN=3) :: YJ
+INTEGER :: ILENG, ILENCH, ILENTITRE, ILENUNITE, ILENCOMMENT, IRESP
+INTEGER :: ILUOUTDIA,INPRARDIA,IFTYPEDIA,IVERBDIA,ININARDIA
+INTEGER :: II, IJ, IK, IT, IN, IP, INUM, J, JJ
+INTEGER :: INTRAJT, IKTRAJX, IKTRAJY, IKTRAJZ
+INTEGER :: ITTRAJX, ITTRAJY, ITTRAJZ
+INTEGER :: INTRAJX, INTRAJY, INTRAJZ
+INTEGER :: IIMASK, IJMASK, IKMASK, ITMASK, INMASK, IPMASK
+INTEGER :: ICOMPX, ICOMPY, ICOMPZ
+INTEGER :: ILENGP, IUSCORE, III
+INTEGER,DIMENSION(:),ALLOCATABLE :: ITABCHAR
+CHARACTER(LEN=20) :: CFORMAT
+!------------------------------------------------------------------------------
+!
+ILENCH = LEN(YCOMMENT)
+if (nverbia > 0)then
+print *,' BEGIN READ_DIACHRO ******************'
+endif
+
+CALL FMLOOK(HLUOUTDIA,HLUOUTDIA,ILUOUTDIA,IRESP)
+!WRITE(ILUOUTDIA,*)' READ_DIACHRO IRESP ',IRESP
+IF(IRESP== -54)THEN
+ CALL FMATTR(HLUOUTDIA,HLUOUTDIA,ILUOUTDIA,IRESP)
+ OPEN(UNIT=ILUOUTDIA,FILE=HLUOUTDIA)
+ IFTYPEDIA = 0; IVERBDIA = 5
+ENDIF
+YFILEDIA=ADJUSTL(ADJUSTR(HFILEDIA)//'.lfi')
+CALL FMLOOK(YFILEDIA,HLUOUTDIA,INUM,IRESP)
+!WRITE(ILUOUTDIA,*)' READ_DIACHRO IRESP ',IRESP
+IF(IRESP == -54)THEN
+! Modif demandee par Nicole Asencio. 28/9/98
+ IFTYPEDIA=2
+ CALL FMOPEN(HFILEDIA,'OLD',HLUOUTDIA,INPRARDIA,IFTYPEDIA,IVERBDIA, &
+ ININARDIA,IRESP)
+END IF
+
+!
+! 1er enregistrement TYPE
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TYPE')
+ILENG = LEN(CTYPE)
+ALLOCATE(ITABCHAR(ILENG))
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ITABCHAR,NGRID,ILENCH,YCOMMENT,IRESP)
+IF(IRESP == -47)THEN
+ DEALLOCATE(ITABCHAR)
+ print *,' ERREUR D''ORTHOGRAPHE OU DE SYNTAXE DANS VOTRE DIRECTIVE '
+ print *,' VERIFIEZ ET RENTREZ LA A NOUVEAU '
+ LPBREAD=.TRUE.
+ RETURN
+ENDIF
+DO J = 1,ILENG
+ CTYPE(J:J) = CHAR(ITABCHAR(J))
+ENDDO
+!WRITE(ILUOUTDIA,*)' 1er ENREGISTREMENT LU OK',CTYPE
+DEALLOCATE(ITABCHAR)
+!
+if (nverbia > 0)then
+print *,' TYPE ',CTYPE
+endif
+
+! 2eme enregistrement DIMENSIONS des MATRICES et LONGUEUR des TABLEAUX de CARACTERES et FLAGS de COMPRESSION sur les DIFFERENTS AXES
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.DIM')
+SELECT CASE(CTYPE)
+
+ CASE('CART','MASK','SPXY')
+
+ ILENG = 34
+ ALLOCATE(ITABCHAR(ILENG))
+
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ NGRID,ILENCH,YCOMMENT,IRESP)
+ ILENTITRE=ITABCHAR(1); ILENUNITE=ITABCHAR(2)
+ ILENCOMMENT=ITABCHAR(3); II=ITABCHAR(4)
+ IJ=ITABCHAR(5); IK=ITABCHAR(6)
+ IT=ITABCHAR(7); IN=ITABCHAR(8)
+ IP=ITABCHAR(9); NIL=ITABCHAR(10)
+ NJL=ITABCHAR(11); NKL=ITABCHAR(12)
+ NIH=ITABCHAR(13); NJH=ITABCHAR(14)
+ NKH=ITABCHAR(15); ICOMPX=ITABCHAR(16)
+ ICOMPY=ITABCHAR(17); ICOMPZ=ITABCHAR(18)
+ INTRAJT=ITABCHAR(19); IKTRAJX=ITABCHAR(20)
+ IKTRAJY=ITABCHAR(21); IKTRAJZ=ITABCHAR(22)
+ ITTRAJX=ITABCHAR(23); ITTRAJY=ITABCHAR(24)
+ ITTRAJZ=ITABCHAR(25); INTRAJX=ITABCHAR(26)
+ INTRAJY=ITABCHAR(27); INTRAJZ=ITABCHAR(28)
+ IIMASK=ITABCHAR(29); IJMASK=ITABCHAR(30)
+ IKMASK=ITABCHAR(31); ITMASK=ITABCHAR(32)
+ INMASK=ITABCHAR(33); IPMASK=ITABCHAR(34)
+ LICP=.FALSE.; LJCP=.FALSE.; LKCP=.FALSE.
+ IF(ICOMPX==1)THEN
+ LICP=.TRUE.
+ ENDIF
+ IF(ICOMPY==1)THEN
+ LJCP=.TRUE.
+ ENDIF
+ IF(ICOMPZ==1)THEN
+ LKCP=.TRUE.
+ ENDIF
+if (nverbia > 0)then
+print *,' DIM ',ILENG
+!print *, ITABCHAR
+endif
+! WRITE(ILUOUTDIA,*)' ILENTITRE,ILENUNITE,ILENCOMMENT LUES',ILENTITRE,ILENUNITE,ILENCOMMENT
+ DEALLOCATE(ITABCHAR)
+
+ CASE DEFAULT
+
+ ILENG = 25
+ ALLOCATE(ITABCHAR(ILENG))
+
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ NGRID,ILENCH,YCOMMENT,IRESP)
+
+ ILENTITRE=ITABCHAR(1); ILENUNITE=ITABCHAR(2)
+ ILENCOMMENT=ITABCHAR(3); II=ITABCHAR(4)
+ IJ=ITABCHAR(5); IK=ITABCHAR(6)
+ IT=ITABCHAR(7); IN=ITABCHAR(8)
+ IP=ITABCHAR(9)
+ INTRAJT=ITABCHAR(10); IKTRAJX=ITABCHAR(11)
+ IKTRAJY=ITABCHAR(12); IKTRAJZ=ITABCHAR(13)
+ ITTRAJX=ITABCHAR(14); ITTRAJY=ITABCHAR(15)
+ ITTRAJZ=ITABCHAR(16); INTRAJX=ITABCHAR(17)
+ INTRAJY=ITABCHAR(18); INTRAJZ=ITABCHAR(19)
+ IIMASK=ITABCHAR(20); IJMASK=ITABCHAR(21)
+ IKMASK=ITABCHAR(22); ITMASK=ITABCHAR(23)
+ INMASK=ITABCHAR(24); IPMASK=ITABCHAR(25)
+
+! CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ILENTITRE,ILENUNITE, &
+! ILENCOMMENT,II,IJ,IK,IT,IN,IP,NGRID,ILENCH,YCOMMENT,IRESP)
+if (nverbia > 0)then
+print'(A5,I3)',' DIM ',ILENG
+write(CFORMAT,FMT='(A1,I2,A7)') "(",ILENG,"(I4,X))"
+print CFORMAT, ITABCHAR
+endif
+ DEALLOCATE(ITABCHAR)
+END SELECT
+!WRITE(ILUOUTDIA,*)' 2eme ENREGISTREMENT LU OK'
+!
+! Allocation des tableaux pour la lecture
+!
+if (nverbia > 0)then
+ print *,' READ_DIACHRO AVANT ALLOC'
+ print'(A19,6I4)',' II,IJ,IK,IT,IN,IP ',II,IJ,IK,IT,IN,IP
+ print'(A41,5I4)',' INTRAJT,IKTRAJX,IKTRAJY,IKTRAJZ,ITTRAJX ',INTRAJT,IKTRAJX,IKTRAJY,IKTRAJZ,ITTRAJX
+ print'(A49,6I4)',' ITTRAJX,ITTRAJY,ITTRAJZ,INTRAJX,INTRAJY,INTRAJZ ',ITTRAJX,ITTRAJY,ITTRAJZ,INTRAJX,INTRAJY,INTRAJZ
+ print'(A42,6I4)',' IIMASK,IJMASK,IKMASK,ITMASK,INMASK,IPMASK ',IIMASK,IJMASK,IKMASK,ITMASK,INMASK,IPMASK
+endif
+CALL ALLOC_FORDIACHRO(II,IJ,IK,IT,IN,IP,2,INTRAJT,IKTRAJX,IKTRAJY, &
+ IKTRAJZ,ITTRAJX,ITTRAJY,ITTRAJZ,INTRAJX,INTRAJY,INTRAJZ,IIMASK, &
+ IJMASK,IKMASK,ITMASK,INMASK,IPMASK)
+if (nverbia > 0)then
+ print *,' READ_DIACHRO APRES ALLOC'
+ print'(A19,6I4)',' II,IJ,IK,IT,IN,IP ',II,IJ,IK,IT,IN,IP
+ print'(A41,5I4)',' INTRAJT,IKTRAJX,IKTRAJY,IKTRAJZ,ITTRAJX ',INTRAJT,IKTRAJX,IKTRAJY,IKTRAJZ,ITTRAJX
+ print'(A49,6I4)',' ITTRAJX,ITTRAJY,ITTRAJZ,INTRAJX,INTRAJY,INTRAJZ ',ITTRAJX,ITTRAJY,ITTRAJZ,INTRAJX,INTRAJY,INTRAJZ
+ print'(A42,6I4)',' IIMASK,IJMASK,IKMASK,ITMASK,INMASK,IPMASK ',IIMASK,IJMASK,IKMASK,ITMASK,INMASK,IPMASK
+endif
+!
+! 3eme enregistrement TITRE
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TITRE')
+if (nverbia > 0)then
+ print'(A14,I3,X,I3)',' ILENTITRE IP ',ILENTITRE,IP
+endif
+ILENG = ILENTITRE*IP
+ALLOCATE(ITABCHAR(ILENG))
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ITABCHAR,NGRID,ILENCH,YCOMMENT,IRESP)
+if (nverbia > 0)then
+ print'(A14,I3,X,I3)' ,' ILENTITRE IP ',ILENTITRE,IP
+endif
+DO JJ = 1,IP
+DO J = 1,ILENTITRE
+ CTITRE(JJ)(J:J)=CHAR(ITABCHAR(ILENTITRE*(JJ-1)+J))
+ENDDO
+!WRITE(ILUOUTDIA,*)CTITRE(JJ)
+if (nverbia > 0)then
+print *,' TITRE '
+print *,CTITRE(JJ)
+endif
+ENDDO
+!WRITE(ILUOUTDIA,*)' 3eme ENREGISTREMENT LU OK'
+DEALLOCATE(ITABCHAR)
+!
+! 4eme enregistrement UNITE
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.UNITE')
+ILENG = ILENUNITE*IP
+ALLOCATE(ITABCHAR(ILENG))
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ITABCHAR,NGRID,ILENCH,YCOMMENT,IRESP)
+DO JJ = 1,IP
+!! Fev 2002
+ CUNITE(JJ)=' '
+ if (nverbia > 0)then
+ print *,' **read_diachro CUNITE AP MISE A BLANC ILENUNITE JJ ',ILENUNITE,JJ, CUNITE(JJ)
+ endif
+!! Fev 2002
+DO J = 1,ILENUNITE
+ CUNITE(JJ)(J:J)=CHAR(ITABCHAR(ILENUNITE*(JJ-1)+J))
+ENDDO
+!WRITE(ILUOUTDIA,*)CUNITE(JJ)
+if (nverbia > 0)then
+print *,' UNITE'
+print *,CUNITE(JJ)
+endif
+ENDDO
+!WRITE(ILUOUTDIA,*)' 4eme ENREGISTREMENT LU OK'
+DEALLOCATE(ITABCHAR)
+!
+! 5eme enregistrement COMMENT
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.COMMENT')
+ILENG = ILENCOMMENT*IP
+ALLOCATE(ITABCHAR(ILENG))
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ITABCHAR,NGRID,ILENCH,YCOMMENT,IRESP)
+DO JJ = 1,IP
+DO J = 1,ILENCOMMENT
+ CCOMMENT(JJ)(J:J)=CHAR(ITABCHAR(ILENCOMMENT*(JJ-1)+J))
+ENDDO
+!WRITE(ILUOUTDIA,*)CCOMMENT(JJ)
+if (nverbia > 0)then
+print *,' COMMENT'
+print *,CCOMMENT(JJ)
+endif
+ENDDO
+!WRITE(ILUOUTDIA,*)' 5eme ENREGISTREMENT LU OK'
+DEALLOCATE(ITABCHAR)
+!
+! 6eme enregistrement VAR
+!
+! Dans la mesure ou cette matrice risque d'etre tres volumineuse, on a ecrit
+! et donc on lit un enregistrement par processus
+DO J = 1,IP
+YJ = ' '
+IF(J < 10)WRITE(YJ,'(I1)')J
+IF(J >= 10 .AND. J < 100)WRITE(YJ,'(I2)')J
+YJ = ADJUSTL(YJ)
+IF(J >= 100 .AND. J < 1000)WRITE(YJ,'(I3)')J
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.PROC'//YJ)
+ILENG = II*IJ*IK*IT*IN
+!print *,' PVAR '
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+XVAR(:,:,:,:,:,J),NGRIDIA(J),ILENCH,YCOMMENT,IRESP)
+!print *,' YJ ILENG YRECFM NGRIDIA',YJ,ILENG,YRECFM,NGRIDIA(J)
+!WRITE(ILUOUTDIA,*)' 6eme ENREGISTREMENT LU OK'
+if (nverbia > 0)then
+ print *,' J de VAR(J) ',J
+endif
+ENDDO
+! PROVI MOdif dim d'un spectre pour voir si pb
+!NIMAX=0 ; NJMAX=0 ; NIL=0; NJL=0; NIH=0; NJH=0
+!
+! 7eme enregistrement TRAJT
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TRAJT')
+ILENG = IT*INTRAJT
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+XTRAJT,NGRID,ILENCH,YCOMMENT,IRESP)
+if (nverbia == -5)then
+print *,' XTRAJT ',XTRAJT
+endif
+if (nverbia > 0)then
+print *,' XTRAJT '
+!print *,XTRAJT
+endif
+!
+! Dans certains cas
+!
+!
+! 8eme enregistrement TRAJX
+!
+IF(IKTRAJX /= 0 .AND. ITTRAJX /= 0 .AND. INTRAJX /= 0 )THEN
+ YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TRAJX')
+ ILENG = IKTRAJX*ITTRAJX*INTRAJX
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ XTRAJX,NGRID,ILENCH,YCOMMENT,IRESP)
+if (nverbia > 0)then
+print *,' XTRAJX'
+!print *,XTRAJX
+endif
+ENDIF
+!
+! ou
+!
+if (nverbia > 0)then
+ print'(A42,6I4)',' IIMASK,IJMASK,IKMASK,ITMASK,INMASK,IPMASK ',&
+ IIMASK,IJMASK,IKMASK,ITMASK,INMASK,IPMASK
+endif
+IF(IIMASK /= 0 .AND. IJMASK /= 0 .AND. IKMASK /= 0 .AND. &
+ ITMASK /= 0 .AND. INMASK /= 0 .AND. IPMASK /= 0)THEN
+ YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.MASK')
+ ILENG = IIMASK*IJMASK*IKMASK*ITMASK*INMASK*IPMASK
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ XMASK,NGRID,ILENCH,YCOMMENT,IRESP)
+if (nverbia > 0)then
+ IF(IRESP /= 0)THEN
+ print'(A19,A20,I1)',' YRECFM IRESP MASK ',YRECFM,IRESP
+ ENDIF
+endif
+! Modif demandee par Nicole pour les budgets en Juin 99 mais compatible avec
+! les anciennes ecritures
+! (Ecriture du masque 1 seule fois pour tous les groupes et par sequence temp.
+! avec le nom : 'MASK_nnnn.MASK' (nnnn=suffixe numerique id. a celui du
+! nom des bilans pour avoir la bonne correspondance temporelle))
+! Donc si en lecture on ne trouve pas l'enr. de nom YRECFM ci-dessus,
+! on recherche celui de nom 'MASK_nnnn.MASK'
+!
+ IF(IRESP == -47)THEN
+ YTEM=YRECFM
+ ILENGP=LEN_TRIM(HGROUP)
+ IUSCORE=INDEX(HGROUP,'___')
+ IF(IUSCORE == 0)THEN
+ IUSCORE=INDEX(HGROUP,'__')
+ IF(IUSCORE == 0)THEN
+ IUSCORE=INDEX(HGROUP,'_')
+ IUSCORE=IUSCORE+1
+ ELSE
+ IUSCORE=IUSCORE+2
+ ENDIF
+ ELSE
+ IUSCORE=IUSCORE+3
+ ENDIF
+ YRECFM(1:LEN(YRECFM))=' '
+ YRECFM='MASK_'
+ YRECFM=ADJUSTL(ADJUSTR(YRECFM)//HGROUP(IUSCORE:ILENGP))
+ YRECFM=ADJUSTL(ADJUSTR(YRECFM)//'.MASK')
+ print *,' Absence ',YTEM(1:LEN_TRIM(YTEM)),' Recherche ',YRECFM(1:LEN_TRIM(YRECFM))
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ XMASK,NGRID,ILENCH,YCOMMENT,IRESP)
+ IF(IRESP /= 0)THEN
+ print *,'PB ou ABSENCE ENR. de nom',YRECFM,' ou ',YTEM
+ print *,'Impossibilite de tracer des MASQUES'
+ ENDIF
+ ENDIF
+
+if (nverbia > 0)then
+do iii=1,INMASK
+print *,' XMASK',size(XMASK,1),size(XMASK,2),' N',III
+!print 10,XMASK(:,:,:,:,iii,:)
+10 FORMAT(40I2)
+enddo
+endif
+
+ENDIF
+!
+! 9eme enregistrement TRAJY
+!
+IF(IKTRAJY /= 0 .AND. ITTRAJY /= 0 .AND. INTRAJY /= 0 )THEN
+ YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TRAJY')
+ ILENG = IKTRAJY*ITTRAJY*INTRAJY
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ XTRAJY,NGRID,ILENCH,YCOMMENT,IRESP)
+if (nverbia > 0)then
+print *,' XTRAJY'
+!print *,XTRAJY
+endif
+ENDIF
+!
+! 10eme enregistrement TRAJZ
+!
+IF(IKTRAJZ /= 0 .AND. ITTRAJZ /= 0 .AND. INTRAJZ /= 0 )THEN
+ YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TRAJZ')
+ ILENG = IKTRAJZ*ITTRAJZ*INTRAJZ
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ XTRAJZ,NGRID,ILENCH,YCOMMENT,IRESP)
+if (nverbia > 0)then
+print *,' XTRAJZ'
+!print *,XTRAJZ
+endif
+ENDIF
+!
+! 11eme enregistrement XDATIME
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.DATIM')
+ILENG=16*IT
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+XDATIME,NGRID,ILENCH,YCOMMENT,IRESP)
+if (nverbia > 0)then
+print *,' XDATIME '
+!print *,XDATIME
+endif
+if (nverbia == -5)then
+print *,' XDATIME ',XDATIME
+!print *,XDATIME
+endif
+
+if (nverbia > 0)then
+print *,' END READ_DIACHRO **************'
+endif
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE READ_DIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/read_dimgridref_fm2dia.f90 b/LIBTOOLS/tools/diachro/src/FM2DIA/read_dimgridref_fm2dia.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c8115f77bad86d46b662de353e43fe96e04a3d2b
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/read_dimgridref_fm2dia.f90
@@ -0,0 +1,272 @@
+! ######spl
+ MODULE MODI_READ_DIMGRIDREF_FM2DIA
+! #####################################
+!
+INTERFACE
+!
+SUBROUTINE READ_DIMGRIDREF_FM2DIA(K,HNAMFILE,HLUOUT)
+INTEGER :: K
+CHARACTER(LEN=*) :: HNAMFILE, HLUOUT
+END SUBROUTINE READ_DIMGRIDREF_FM2DIA
+!
+END INTERFACE
+!
+END MODULE MODI_READ_DIMGRIDREF_FM2DIA
+! #######################################################
+ SUBROUTINE READ_DIMGRIDREF_FM2DIA(K,HNAMFILE,HLUOUT)
+! #######################################################
+!
+!!**** *READ_DIMGRIDREF_FM2DIA* - Lecture et ecriture des parametres
+!! "intouchables" et des profils 1D de l'etat de reference
+!!
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+! Lecture des dimensions par appel a SET_GRID
+! " parametres de grilles par appel a SET_GRID
+! " des 3 var. de l'etat de ref.
+! Ecriture de toutes ces informations dans le fichier diachronique
+! par appel a WRITE_DIMGRIDREF
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHORS
+!! -------
+!! J. Duron *Lab. Aerologie*
+!!
+!! Copyright 1994, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/01/96
+!! Modification 291196 CSTORAGE_TYPE forced to 'PG' (temp.)
+!! Modification 01/2003 suppression de l appel a SET_REF_FORDIACHRO
+! (=SET_REF modifie en supprimant toute la partie calculs inutile)
+!! Modification 12/2003 appel a SET_GRID remplace par SET_LIGHT_GRID
+!! Modification 09/2004 lecture de MASDEV pour masdev4_6
+!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_DIM1 ! NIMAX,NJMAX,NKMAX, NIINF,NISUP, NJINF,NJSUP
+USE MODD_GRID ! XLON0,XLAT0,XBETA, XRPK,XLONORI,XLATORI
+USE MODD_GRID1 ! LSLEVE,XLEN1,XLEN2
+USE MODD_PARAMETERS, ONLY: JPHEXT,JPVEXT
+USE MODD_CONF, ONLY: CCONF,CSTORAGE_TYPE,LCARTESIAN,NMASDEV,NBUGFIX,L1D,L2D,LPACK
+USE MODD_PARAM1, ONLY: CSURF
+USE MODD_TIME
+USE MODD_TIME1
+!
+USE MODD_DIACHRO, ONLY: CMY_NAME_DIA, CDAD_NAME_DIA
+USE MODD_OUT_DIA, ONLY : NLUOUTD
+USE MODD_REA_LFI
+!
+USE MODI_SET_DIM
+USE MODI_SET_LIGHT_GRID
+USE MODI_FMREAD
+!
+!* 0.1 Dummy arguments
+!
+
+INTEGER :: K
+
+CHARACTER(LEN=*) :: HNAMFILE
+CHARACTER(LEN=*) :: HLUOUT
+!
+!* 0.2 Local variables declarations
+!
+!
+INTEGER :: JJ, J
+INTEGER :: IIU, IJU, IKU ! Upper bounds in x, y, z directions
+INTEGER :: IIB, IJB, IKB ! Begining useful area in x, y, z directions
+INTEGER :: IIE, IJE, IKE ! End useful area in x, y, z directions
+!
+REAL :: ZLAT,ZLON ! Emagram soundings gridpoint location
+ ! latitude and longitude (decimal degrees)
+REAL :: ZX,ZY ! Emagram soundings gridpoint location
+ ! cartesian east and north coordinates (meters)
+!
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: ZJ ! Jacobian
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Preseting the general FM2DIACHRO environment
+! ---------------------------------------
+!
+!* 1.1 Sets default values
+!
+CCONF='POSTP'
+!
+!* 1.6 Reads the LFIFM file initial section (i.e. Array dimensions)
+!
+NIINF=0 ; NISUP=0 ; NJINF=0 ; NJSUP=0
+!
+CALL SET_DIM(HNAMFILE,HLUOUT,NIINF,NISUP,NJINF,NJSUP,NIMAX,NJMAX,NKMAX)
+!
+CMY_NAME_DIA(1:LEN(CMY_NAME_DIA))=' '
+CRECFM='MY_NAME'
+NLENG=28
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,CMY_NAME_DIA,NGRID,NLENCH,CCOMMENT,NRESP)
+!
+CDAD_NAME_DIA(1:LEN(CDAD_NAME_DIA))=' '
+CRECFM='DAD_NAME'
+NLENG=28
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,CDAD_NAME_DIA,NGRID,NLENCH,CCOMMENT,NRESP)
+print *,'CMY_name CDAD_name ',CMY_NAME_DIA,CDAD_NAME_DIA
+!
+CRECFM='SURF'
+NLENG=4
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,CSURF,NGRID,NLENCH,CCOMMENT,NRESP)
+!
+! Reads the geometry configuration selector
+!
+CRECFM='CARTESIAN'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,LCARTESIAN,NGRID,NLENCH,CCOMMENT,NRESP)
+!
+CRECFM='THINSHELL'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,LTHINSHELL,NGRID,NLENCH,CCOMMENT,NRESP)
+!
+CRECFM='STORAGE_TYPE'
+NLENG=2
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,CSTORAGE_TYPE,NGRID,NLENCH,CCOMMENT,NRESP)
+IF(NRESP /= 0) CSTORAGE_TYPE='MT'
+!
+CRECFM='L1D'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,L1D,NGRID,NLENCH,CCOMMENT,NRESP)
+!
+CRECFM='L2D'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,L2D,NGRID,NLENCH,CCOMMENT,NRESP)
+!
+CRECFM='PACK'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,LPACK,NGRID,NLENCH,CCOMMENT,NRESP)
+!
+! Reads the MesoNH version
+!
+CRECFM='MASDEV'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,NMASDEV,NGRID,NLENCH,CCOMMENT,NRESP)
+IF (NRESP /=0 ) NMASDEV=43
+!
+CRECFM='BUGFIX'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,NBUGFIX,NGRID,NLENCH,CCOMMENT,NRESP)
+IF (NRESP /=0 ) NBUGFIX=0
+!
+CRECFM='JPHEXT'
+NLENG=1
+CALL FMREAD(HNAMFILE,CRECFM,HLUOUT,NLENG,JPHEXT,NGRID,NLENCH,CCOMMENT,NRESP)
+IF (NRESP /=0 ) JPHEXT=1
+!* 1.7 Allocates the first bunch of input arrays
+!
+!* 1.7.1 Local variables :
+!
+IIU=NIMAX+2*JPHEXT ; IJU=NJMAX+2*JPHEXT ; IKU=NKMAX+2*JPVEXT
+!
+print *,' READ_DIMGRIDREF_FM2DIA CSTORAGE_TYPE=',CSTORAGE_TYPE
+IF(CSTORAGE_TYPE == 'PG' .OR. CSTORAGE_TYPE=='SU')THEN
+ IKU=1
+ LCARTESIAN=.FALSE.
+ NKMAX=1
+ENDIF
+!
+IIB=1+JPHEXT ; IIE=IIU-JPHEXT
+IJB=1+JPHEXT ; IJE=IJU-JPHEXT
+IKB=1+JPVEXT ; IKE=IKU-JPVEXT
+WRITE(NLUOUTD,*) 'MAIN: IIB, IJB, IKB=',IIB,IJB,IKB
+WRITE(NLUOUTD,*) 'MAIN: IIE, IJE, IKE=',IIE,IJE,IKE
+WRITE(NLUOUTD,*) 'MAIN: IIU, IJU, IKU=',IIU,IJU,IKU
+!
+!
+IF(K == 1)THEN ! premier fichier
+ ALLOCATE(ZJ(IIU,IJU,IKU))
+ !
+ !* 1.7.2 Grid variables (MODD_GRID1 module):
+ !
+ ALLOCATE(XXHAT(IIU),XYHAT(IJU),XZHAT(IKU))
+ ALLOCATE(XMAP(IIU,IJU))
+ ALLOCATE(XLAT(IIU,IJU))
+ ALLOCATE(XLON(IIU,IJU))
+ ALLOCATE(XDXHAT(IIU),XDYHAT(IJU))
+ ALLOCATE(XZS(IIU,IJU),XZSMT(IIU,IJU))
+ ALLOCATE(XZZ(IIU,IJU,IKU))
+ !
+ XXHAT=0. ; XYHAT=0. ; XZHAT=0. ; XMAP=0. ; XLAT=0. ; XLON=0.
+ XDXHAT=0. ; XDYHAT=0. ; XZS=0. ; XZZ=0.
+ !
+ENDIF
+!
+!* 1.8 Reads the last section of the LFIFM file
+!
+! Notice: The whole XXHAT, XYHAT arrays have to be set here
+! to make provision for any grid selector choice
+!
+NIINF=1 ; NISUP=IIU
+NJINF=1 ; NJSUP=IJU
+!
+CALL SET_LIGHT_GRID(1,HNAMFILE,HLUOUT, &
+ IIU,IJU,IKU,NIMAX,NJMAX, &
+ XLONORI,XLATORI, &
+ XLON,XLAT,XXHAT,XYHAT, &
+ XDXHAT,XDYHAT,XMAP, &
+ XZS,XZZ,XZHAT,LSLEVE,XLEN1,XLEN2,XZSMT,&
+ ZJ, &
+ TDTMOD,TDTCUR )
+!
+IF(CSTORAGE_TYPE == 'PG')THEN
+ IKU=1
+ LCARTESIAN=.FALSE.
+ NKMAX=1
+ TDTMOD%TIME=0.
+ TDTCUR%TIME=0.
+ TDTEXP%TIME=0.
+ TDTSEG%TIME=0.
+ TDTMOD%TDATE%YEAR=0.
+ TDTMOD%TDATE%MONTH=0.
+ TDTMOD%TDATE%DAY=0.
+ TDTCUR%TDATE%YEAR=0.
+ TDTCUR%TDATE%MONTH=0.
+ TDTCUR%TDATE%DAY=0.
+ TDTEXP%TDATE%YEAR=0.
+ TDTEXP%TDATE%MONTH=0.
+ TDTEXP%TDATE%DAY=0.
+ TDTSEG%TDATE%YEAR=0.
+ TDTSEG%TDATE%MONTH=0.
+ TDTSEG%TDATE%DAY=0.
+ELSE IF(CSTORAGE_TYPE == 'SU')THEN
+ IKU=1
+ LCARTESIAN=.FALSE.
+ NKMAX=1
+ TDTMOD%TIME= TDTCUR%TIME
+ TDTEXP%TIME= TDTCUR%TIME
+ TDTSEG%TIME= TDTCUR%TIME
+ TDTMOD%TDATE%YEAR= TDTCUR%TDATE%YEAR
+ TDTMOD%TDATE%MONTH= TDTCUR%TDATE%MONTH
+ TDTMOD%TDATE%DAY= TDTCUR%TDATE%DAY
+ TDTEXP%TDATE%YEAR= TDTCUR%TDATE%YEAR
+ TDTEXP%TDATE%MONTH= TDTCUR%TDATE%MONTH
+ TDTEXP%TDATE%DAY= TDTCUR%TDATE%DAY
+ TDTSEG%TDATE%YEAR= TDTCUR%TDATE%YEAR
+ TDTSEG%TDATE%MONTH= TDTCUR%TDATE%MONTH
+ TDTSEG%TDATE%DAY= TDTCUR%TDATE%DAY
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+RETURN
+
+END SUBROUTINE READ_DIMGRIDREF_FM2DIA
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/resolv_units.f90 b/LIBTOOLS/tools/diachro/src/FM2DIA/resolv_units.f90
new file mode 100644
index 0000000000000000000000000000000000000000..387769dbfe23a473219923c8ca18b04d3ae66504
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/resolv_units.f90
@@ -0,0 +1,112 @@
+! ######spl
+ MODULE MODI_RESOLV_UNITS
+! #############################
+!
+INTERFACE
+!
+SUBROUTINE RESOLV_UNITS(HCARIN,HCAROUT)
+CHARACTER(LEN=*) :: HCARIN
+CHARACTER(LEN=*) :: HCAROUT
+END SUBROUTINE RESOLV_UNITS
+!
+END INTERFACE
+END MODULE MODI_RESOLV_UNITS
+! #######################################
+ SUBROUTINE RESOLV_UNITS(HCARIN,HCAROUT)
+! #######################################
+!
+!!**** *RESOLV_UNITS* - Extraction du champ unites
+
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+USE MODD_CONF
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HCARIN
+CHARACTER(LEN=*) :: HCAROUT
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+CHARACTER(LEN=1) :: YC
+CHARACTER(LEN=LEN(HCARIN)) :: YCARIN
+INTEGER :: ILENC
+
+INTEGER :: J, J1, J2, JJ
+!------------------------------------------------------------------------------
+!
+YCARIN=HCARIN
+ILENC = LEN(YCARIN)
+!print *,' YCARIN ',LEN(YCARIN),YCARIN
+J1=0; J2=0
+J1=INDEX(YCARIN,'(')
+DO J=ILENC,1,-1
+ IF(YCARIN(J:J) == ')')THEN
+ J2=J
+ EXIT
+ ENDIF
+ENDDO
+CGROUP=ADJUSTL(CGROUP)
+!print *,'CGROUP ',CGROUP
+IF(J2 < J1)THEN
+ J2=LEN_TRIM(YCARIN)+1
+ENDIF
+IF(J1 == 0 .AND. J2 == 0)THEN
+ IF(INDEX(YCARIN,CGROUP(1:LEN_TRIM(CGROUP))) /= 0 )THEN
+ HCAROUT(1:LEN(HCAROUT))=' '
+ ELSE
+ HCAROUT=ADJUSTL(YCARIN)
+ ENDIF
+ELSE
+ HCAROUT=ADJUSTL(YCARIN(J1+1:J2-1))
+ENDIF
+!print *,' HCAROUT ',HCAROUT
+YCARIN(1:LEN(YCARIN))=' '
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE RESOLV_UNITS
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/write_dimgridref.f90 b/LIBTOOLS/tools/diachro/src/FM2DIA/write_dimgridref.f90
new file mode 100644
index 0000000000000000000000000000000000000000..24a38a8c7c59a575ceddef3cf8f34480e06a60dc
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/write_dimgridref.f90
@@ -0,0 +1,97 @@
+! ######spl
+ MODULE MODI_WRITE_DIMGRIDREF
+! ############################
+!
+INTERFACE
+!
+SUBROUTINE WRITE_DIMGRIDREF
+END SUBROUTINE WRITE_DIMGRIDREF
+!
+END INTERFACE
+!
+END MODULE MODI_WRITE_DIMGRIDREF
+! ###########################
+ SUBROUTINE WRITE_DIMGRIDREF
+! ###########################
+!
+!!**** *WRITE_DIMGRIDREF* - Ouverture du fichier diachronique et ecriture
+!! de l'entete
+!!
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHORS
+!! -------
+!! J. Duron *Lab. Aerologie*
+!!
+!! Copyright 1994, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/01/96
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_DIACHRO
+USE MODI_WRITE_LFIFM1_FORDIACHRO_CV
+
+!
+!* 0.1 Local variables
+!
+INTEGER :: IRESP
+!
+!* 1. Ouverture du fichier diachronique
+! ---------------------------------
+!
+CALL FMLOOK(CLUOUTDIA,CLUOUTDIA,NLUOUTDIA,IRESP)
+IF (IRESP/=0) THEN
+ ! ouverture du listing
+ CALL FMATTR(CLUOUTDIA,CLUOUTDIA,NLUOUTDIA,NRESPDIA)
+ OPEN(UNIT=NLUOUTDIA,FILE=CLUOUTDIA,FORM='FORMATTED')
+END IF
+!
+WRITE(UNIT=NLUOUTDIA,FMT=1)CFILEDIA
+1 FORMAT(' OPEN NEW DIACHRONIC FILE ',A28)
+
+! Modif demandee par Nicole Asencio. 28/9/98
+NFTYPEDIA=2
+!NFTYPEDIA=0
+NVERBDIA=5
+CALL FMOPEN(CFILEDIA,'NEW',CLUOUTDIA,NNPRARDIA,NFTYPEDIA,NVERBDIA,NNINARDIA, &
+ NRESPDIA)
+
+!
+!* 2. Fermeture du fichier descriptif correspondant
+! et unite logique correspondante liberee
+! ----------------------------------------------
+!
+! non, on ferme DES et LFI par FMCLOS a la fin du programme
+!(On peut envisager d'y ecrire le DESFM des fichiers d'entree)
+!
+!* 3. Ecriture des dimensions, parametres de grille, etat de ref...
+! ----------------------------------------------------------
+!
+CALL WRITE_LFIFM1_FORDIACHRO_CV(CFILEDIA)
+
+!
+!------------------------------------------------------------------------------
+!
+!* 4. EPILOGUE
+! --------
+
+RETURN
+
+END SUBROUTINE WRITE_DIMGRIDREF
diff --git a/LIBTOOLS/tools/diachro/src/FM2DIA/write_othersfields.f90 b/LIBTOOLS/tools/diachro/src/FM2DIA/write_othersfields.f90
new file mode 100644
index 0000000000000000000000000000000000000000..aadb760372d15f07888f301d17d4568a59f48c7a
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/FM2DIA/write_othersfields.f90
@@ -0,0 +1,937 @@
+! ######spl
+ MODULE MODI_WRITE_OTHERSFIELDS
+! ##############################
+!
+INTERFACE
+!
+SUBROUTINE WRITE_OTHERSFIELDS(K,HFILEDIA,HLUOUTDIA,KX,KY,KZ)
+INTEGER :: K
+CHARACTER(LEN=*) :: HFILEDIA,HLUOUTDIA
+INTEGER, INTENT(IN), OPTIONAL :: KX,KY,KZ
+END SUBROUTINE WRITE_OTHERSFIELDS
+!
+END INTERFACE
+!
+END MODULE MODI_WRITE_OTHERSFIELDS
+! #############################################################
+ SUBROUTINE WRITE_OTHERSFIELDS(K,HFILEDIA,HLUOUTDIA,KX,KY,KZ)
+! #############################################################
+!
+!!**** *WRITE_OTHERSFIELDS* -
+!!
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHORS
+!! -------
+!! J. Duron *Lab. Aerologie*
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/01/96
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_DIMGRID_FORDIACHRO
+USE MODD_OUT_DIA
+USE MODD_DIACHRO
+USE MODD_ALLOC_FORDIACHRO
+USE MODI_ALLOC_FORDIACHRO
+USE MODD_PARAMETERS
+USE MODD_DIM1
+USE MODD_TYPE_AND_LH
+USE MODD_RESOLVCAR, ONLY : CGROUP
+USE MODD_GRID
+USE MODD_CONF
+USE MODD_GRID1
+USE MODD_TIME1
+USE MODD_TYPE_DATE
+USE MODI_WRITE_DIACHRO
+USE MODI_READ_DIACHRO
+USE MODI_RESOLV_UNITS
+USE MODI_TEMPORAL_DIST
+USE MODD_TIME
+USE MODI_FMREAD
+USE MODI_FMWRIT
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+!
+INTEGER :: K ! Input file number
+CHARACTER(LEN=*) :: HFILEDIA, HLUOUTDIA
+INTEGER, INTENT(IN), OPTIONAL :: KX,KY,KZ
+!
+!* 0.2 Local variables declarations
+!
+INTEGER :: JJ, J, JA, I
+INTEGER :: ixyz, J1, J2, J3, I1, I2, I3
+INTEGER :: IIU, IJU, IKU
+INTEGER :: IGRID, ILENCH, IRESP
+INTEGER :: IPCENT
+INTEGER :: IMULT, ILYCOMM
+INTEGER :: ILUOUTDIA
+!
+CHARACTER(LEN=100):: YCOMMENT, YCAROUT
+CHARACTER(LEN=20):: YCOMM
+CHARACTER(LEN=16) :: YRECFM
+!
+REAL,DIMENSION(:),ALLOCATABLE :: ZTAB
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: ZTAB3, ZTABM3, Z3D
+INTEGER,DIMENSION(3):: ITAB3 ! sizes of array ZTAB3
+!
+TYPE (DATE_TIME), SAVE :: TZDTEXP ! to store exp. time when TT files
+LOGICAL :: GPACK ! to store LPACK
+!----------------------------------------------------------------------------
+!
+!* 1. INITIALISATION
+! --------------
+!
+GPACK=LPACK
+! Duplication du profil au niveau des points de garde en 1D ou 2D
+IF(NIMAX==1 .OR. NJMAX==1) LPACK=.FALSE.
+!
+ILENCH=LEN(YCOMMENT)
+ILYCOMM=LEN(YCOMM)
+YCOMM(1:ILYCOMM)='NOTHING'
+!
+IIU=NIMAX+2*JPHEXT
+IJU=NJMAX+2*JPHEXT
+IKU=NKMAX+2*JPVEXT
+print*,'IIU,IJU,IKU= ',IIU,IJU,IKU
+!JDJDJDJD 291196
+WRITE(NLUOUTD,*)' ******** WRITE_OTHERSFIELDS ENTREE CSTORAGE_TYPE ',CSTORAGE_TYPE
+IF(CSTORAGE_TYPE == 'PG' .OR. CSTORAGE_TYPE == 'SU')THEN
+ IKU=1
+ENDIF
+!JDJDJDJD 291196
+
+CALL FMLOOK(HLUOUTDIA,HLUOUTDIA,ILUOUTDIA,IRESP)
+!
+! resolution degradee
+ixyz=0
+IF (PRESENT(KX)) THEN
+IF (KX>1.AND.NIMAX/=1) ixyz=1
+ENDIF
+IF (PRESENT(KY)) THEN
+IF (KY>1.AND.NJMAX/=1) ixyz=ixyz+10
+ENDIF
+IF (PRESENT(KZ)) THEN
+IF (KZ>1) ixyz=ixyz+100
+ENDIF
+!
+! NNB= NB d'articles a lire dans le fichier en cours de traitement en entree
+! Mais en fait on prend comme ref. les articles du premier fichier
+! (CF instruction IF(NNUMT(JJ,1....) en supposant que tous les fichiers
+! traites ont la meme organisation (ce qui doit etre le cas sachant que
+! ces fichiers sont differentes echeances d'un meme run)
+!
+DO JJ=1,NNB
+!
+ IF(NNUMT(JJ,1) /= 0)THEN
+!
+!----------------------------------------------------------------------------
+!
+!* 2. TREATMENT ACCORDING THE VARIABLE SHAPE
+! --------------------------------------
+!
+! 130198 Introduction de IMULT pour prise en compte du 2D Vertical dont
+! seul le plan central est enregistre
+ IMULT=1
+!
+!* 2.0
+!
+ IF(NSIZT(JJ,K) == IIU*IJU)THEN
+! 051296 Modif pour tenir compte du 2D surfacique horizontal
+ IKU=1
+ ELSE IF(NSIZT(JJ,K)*(2*JPHEXT+NJMAX) == IIU*IJU)THEN
+! 130198 Modif pour tenir compte du 2D Vertical filaire et surfacique; cas
+! enregistrement du seul plan central
+ IKU=1
+ IMULT=2*JPHEXT+NJMAX
+ WRITE(NLUOUTD,*)'***************************************************************'
+ WRITE(NLUOUTD,*)' Variable 1D rencontree // X et enregistree dans le fichier',&
+ &' diachronique ',CRECFM2T(JJ,K),' size origine et size enr. ',NSIZT(JJ,K),NSIZT(JJ,K)*IMULT
+ WRITE(NLUOUTD,*)' (Duplication du profil (<--> 2D filaire) au niveau des points de garde)'
+ WRITE(NLUOUTD,*)'***************************************************************'
+ ELSE IF(NSIZT(JJ,K)*(2*JPHEXT+NIMAX) == IIU*IJU)THEN
+ WRITE(NLUOUTD,*)'***************************************************************'
+ WRITE(NLUOUTD,*)' Variable 1D // Y non enregistree dans le fichier',&
+ &' diachronique ',CRECFM2T(JJ,K),' size et IIU,IJU,IKU ',NSIZT(JJ,K),IIU,IJU,IKU
+ WRITE(NLUOUTD,*)'***************************************************************'
+ CYCLE
+ ELSE IF(NSIZT(JJ,K)*(2*JPHEXT+NIMAX) == IIU*IJU/(2*JPHEXT+NJMAX))THEN
+ IF(NIMAX==1 .AND. NJMAX==1) THEN
+! 110906 Cas 0D Vertical ou seul le profil central est enregistre
+! Duplication du profil sur les points de garde
+! (rigoureusement, il faut dupliquer car type CART)
+ IKU=1
+ IMULT = (2*JPHEXT+NIMAX)*(2*JPHEXT+NJMAX)
+ WRITE(NLUOUTD,*)'***************************************************************'
+ WRITE(NLUOUTD,*)' Variable 0D enregistree dans le fichier',&
+ &' diachronique ',CRECFM2T(JJ,K),' size origine et size enr. ',NSIZT(JJ,K),NSIZT(JJ,K)*IMULT
+ WRITE(NLUOUTD,*)' (Duplication du profil au niveau des points de garde...)'
+ WRITE(NLUOUTD,*)'***************************************************************'
+ ENDIF
+ ELSE
+ IKU=NKMAX+2*JPVEXT
+ IF(NSIZT(JJ,K)*(2*JPHEXT+NJMAX) == IIU*IJU*IKU)THEN
+ IMULT=2*JPHEXT+NJMAX
+ WRITE(NLUOUTD,*)'***************************************************************'
+ WRITE(NLUOUTD,*)' Variable 2D Vertical // X et enregistree dans le fichier',&
+ &' diachronique ',CRECFM2T(JJ,K),' size origine et size enr. ',NSIZT(JJ,K),NSIZT(JJ,K)*IMULT
+ WRITE(NLUOUTD,*)' (Duplication du plan au niveau des points de garde)'
+ WRITE(NLUOUTD,*)'***************************************************************'
+ ELSE IF(NSIZT(JJ,K)*(2*JPHEXT+NIMAX) == IIU*IJU*IKU)THEN
+ WRITE(NLUOUTD,*)'***************************************************************'
+ WRITE(NLUOUTD,*)' Variable 2D Vertical // Y non enregistree dans le fichier',&
+ &' diachronique ',CRECFM2T(JJ,K),' size et IIU,IJU,IKU ',NSIZT(JJ,K),IIU,IJU,IKU
+ WRITE(NLUOUTD,*)'***************************************************************'
+ CYCLE
+ !ELSE IF(NSIZT(JJ,K)*(2*JPHEXT+NIMAX)*(2*JPHEXT+NJMAX) == IIU*IJU*IKU)THEN
+ !remplace par la ligne suivante car le membre de gauche peut etre tres grand
+ ELSE IF(NSIZT(JJ,K)*(2*JPHEXT+NIMAX)==IIU*IJU*IKU/(2*JPHEXT+NJMAX) )THEN
+ WRITE(NLUOUTD,*)'***************************************************************'
+ IF(NIMAX==1 .AND. NJMAX==1) THEN
+! 180703 Cas 1D Vertical ou seul le profil central est enregistre
+! Duplication du profil sur les points de garde
+! (rigoureusement, il faut dupliquer car type CART)
+ IMULT = (2*JPHEXT+NIMAX)*(2*JPHEXT+NJMAX)
+ WRITE(NLUOUTD,*)' Variable 1D Vertical enregistree dans le fichier',&
+ &' diachronique ',CRECFM2T(JJ,K),' size origine et size enr. ',NSIZT(JJ,K),NSIZT(JJ,K)*IMULT
+ WRITE(NLUOUTD,*)' (Duplication du profil au niveau des points de garde...)'
+ ELSE
+ WRITE(NLUOUTD,*)' Variable 1D Vertical enregistree dans le fichier',&
+ &' diachronique ',CRECFM2T(JJ,K),' size origine et size enr. ',NSIZT(JJ,K),NSIZT(JJ,K)*IMULT
+ ENDIF
+ WRITE(NLUOUTD,*)'***************************************************************'
+ ELSE
+ IF(NSIZT(JJ,K) == IIU*IJU*IKU)THEN
+! Variable 3D normale IKU= NKMAX+2*JPVEXT IMULT=1 On ne fait rien
+ ELSE
+ IF(NJMAX==1 .AND. GPACK) THEN
+ IF(MOD(NSIZT(JJ,K) , IIU) == 0)THEN
+! Variable 3D avec la 3eme dim <= a IKU habituel et sans signification spatiale
+ IKU=NSIZT(JJ,K)/IIU
+ WRITE(NLUOUTD,*)'*********** 3D mais 3e dimension =/= de IKU *******************'
+ WRITE(NLUOUTD,*)' Variable 3D enregistree dans le fichier diachronique ',&
+ &CRECFM2T(JJ,K),' size et IIU,3e DIMENSION,IKU ',NSIZT(JJ,K),IIU,IKU,NKMAX+2*JPVEXT
+ IF(CSTORAGE_TYPE == 'PG' .OR. CSTORAGE_TYPE == 'SU')THEN
+ WRITE(NLUOUTD,*)' cas d un fichier physiographique: niveaux supplementaires de 1 a ',IKU
+ ELSE
+ WRITE(NLUOUTD,*)' consideree comme une matrice partielle en K dont seuls les niveaux 1 a ',IKU,' sont enregistres'
+ END IF
+! Duplication du profil sur les points de garde
+! (rigoureusement, il faut dupliquer car type CART)
+ IMULT = 2*JPHEXT+NJMAX
+ WRITE(NLUOUTD,*)' (Duplication au niveau des points de garde)'
+ ENDIF
+ ELSE IF(MOD(NSIZT(JJ,K) , IIU*IJU) == 0)THEN
+! Variable 3D avec la 3eme dim <= a IKU habituel et sans signification spatiale
+ IKU=NSIZT(JJ,K)/(IIU*IJU)
+ WRITE(NLUOUTD,*)'*********** 3D mais 3e dimension =/= de IKU *******************'
+ WRITE(NLUOUTD,*)' Variable 3D enregistree dans le fichier diachronique ',&
+ &CRECFM2T(JJ,K),' size et IIU,IJU,3e DIMENSION,IKU ',NSIZT(JJ,K),IIU,IJU,IKU,NKMAX+2*JPVEXT
+ IF(CSTORAGE_TYPE == 'PG' .OR. CSTORAGE_TYPE == 'SU')THEN
+ WRITE(NLUOUTD,*)' cas d un fichier physiographique: niveaux supplementaires de 1 a ',IKU
+ ELSE
+ WRITE(NLUOUTD,*)' consideree comme une matrice partielle en K dont seuls les niveaux 1 a ',IKU,' sont enregistres'
+ END IF
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+ !
+!
+! Allocation de la zone tampon de lecture
+ ALLOCATE(ZTAB(NSIZT(JJ,K)))
+ ! LPACK n intervient pas dans cette maniere de lire (ZTAB est 1D)
+!
+! Lecture de l'article concerne (CRECFM2T(JJ,K))
+ CALL FMREAD(CNAMFILED(K),CRECFM2T(JJ,K),CLUOUTD,NSIZT(JJ,K), &
+ ZTAB,IGRID,ILENCH,YCOMMENT,IRESP)
+ YCOMMENT=ADJUSTL(ADJUSTR(YCOMMENT))
+ CGROUP(1:LEN(CGROUP))=' '
+ CGROUP=CRECFM2T(JJ,K)
+ CGROUP=ADJUSTL(CGROUP)
+!
+! 051296 Modifs pour enregistrer le relief ZS egalement sous le nom ZSBIS
+ IF(CGROUP(1:LEN_TRIM(CGROUP)) == 'ZS')THEN
+ CRECFM2T(JJ,K)='ZSBIS'
+ CGROUP='ZSBIS'
+ ENDIF
+! 120106 idem pour le smooth relief
+ IF(CGROUP(1:LEN_TRIM(CGROUP)) == 'ZSMT')THEN
+ CRECFM2T(JJ,K)='ZSMTBIS'
+ CGROUP='ZSMTBIS'
+ ENDIF
+!
+! Extraction des unites du champ commentaire
+ YCAROUT(1:LEN(YCAROUT))=' '
+ IF (LEN_TRIM(YCOMMENT)/=0) &
+ CALL RESOLV_UNITS(YCOMMENT(1:LEN_TRIM(YCOMMENT)),YCAROUT)
+!
+!
+!* 2.1 ++++3D + 2D H + 2D V et 1D // X+++++
+!
+! Traitement informations 3D et 2D Horiz. Sont considerees de type CART
+! dans le fichier diachronique
+! (En realite si on W en 2D, on recupere le 2D plan et filaire
+! (3D + 2D avec les points de garde) et si on W
+! en 1D on recupere 1 profil vertical (3D avec les points de garde) et
+! peut-etre 1 scalaire avec des points de garde horiz. (2D)) A VERIFIER
+
+! 130198 Ajout 2D Vertical surfacique + filaire // X
+! IF(NSIZT(JJ,K) == IIU*IJU*IKU)THEN
+ IF(NSIZT(JJ,K)*IMULT == IIU*IJU*IKU)THEN
+ IF(IMULT /= 1)THEN
+ IF(IMULT == (2*JPHEXT+NIMAX)*(2*JPHEXT+NJMAX))THEN
+! 180703 Cas 1D Vertical ou seul le profil central est enregistre
+! si pas de duplication du profil sur les points de garde:
+! ITAB3(1)=1; ITAB3(2)=1; ITAB3(3)=IKU
+! ALLOCATE(ZTAB3(ITAB3(1),ITAB3(2),ITAB3(3)))
+! ZTAB3=RESHAPE(ZTAB,ITAB3)
+! il faut dupliquer car type CART:
+ ITAB3(1)=1 ; ITAB3(2)=1 ; ITAB3(3)=IKU
+ ALLOCATE(ZTABM3(ITAB3(1),ITAB3(2),ITAB3(3)))
+ ZTABM3=RESHAPE(ZTAB,ITAB3)
+ ITAB3(1)=2*JPHEXT+NIMAX ; ITAB3(2)=2*JPHEXT+NJMAX ; ITAB3(3)=IKU
+ IF (ALLOCATED(ZTAB3)) DEALLOCATE(ZTAB3)
+ ALLOCATE(ZTAB3(ITAB3(1),ITAB3(2),ITAB3(3)))
+ DO J=1,ITAB3(2)
+ DO I=1,ITAB3(1)
+ ZTAB3(I,J,:)=ZTABM3(1,1,:)
+ ENDDO
+ ENDDO
+ DEALLOCATE(ZTABM3)
+ ELSE
+! 130198 Cas 2D Vertical // X ou seul le plan central est enregistre
+! Duplication du plan sur les points de garde
+ ITAB3(1)=IIU; ITAB3(2)=1; ITAB3(3)=IKU
+ ALLOCATE(ZTABM3(ITAB3(1),ITAB3(2),ITAB3(3)))
+ ZTABM3=RESHAPE(ZTAB,ITAB3)
+ IF (ALLOCATED(ZTAB3)) DEALLOCATE(ZTAB3)
+ ITAB3(1)=IIU; ITAB3(2)=IJU; ITAB3(3)=IKU
+ ALLOCATE(ZTAB3(ITAB3(1),ITAB3(2),ITAB3(3)))
+ DO J=1,ITAB3(2)
+ ZTAB3(:,J,:)=ZTABM3(:,1,:)
+ ENDDO
+ DEALLOCATE(ZTABM3)
+ END IF
+ ELSE ! Variable 3D normale IKU= NKMAX+2*JPVEXT IMULT=1
+ ITAB3(1)=IIU; ITAB3(2)=IJU; ITAB3(3)=IKU
+ IF (ALLOCATED(ZTAB3)) DEALLOCATE(ZTAB3)
+ ALLOCATE(ZTAB3(ITAB3(1),ITAB3(2),ITAB3(3)))
+ ZTAB3=RESHAPE(ZTAB,ITAB3)
+ ENDIF
+!
+! Dans ce pg de conversion, on considere que chaque variable (prognostique,
+! diagnostique, generique represente a elle seule un groupe a 1 processus
+! (--> indice de processus = 1)
+! On affecte (arbitrairement) le meme nom au groupe et au processus
+ IF(K == 1)THEN
+ CTYPE='CART'
+! resolution degradee
+ IF (PRESENT(KX)) THEN
+ IF (KX>1.AND.NIMAX/=1) ITAB3(1)=(IIU-1)/KX +1
+ ENDIF
+ IF (PRESENT(KY)) THEN
+ IF (KY>1.AND.NJMAX/=1) ITAB3(2)=(IJU-1)/KY +1
+ ENDIF
+ IF (PRESENT(KZ)) THEN
+ IF (KZ>1) ITAB3(3)=(IKU-1)/KZ +1
+ ENDIF
+! Allocation des matrices utilisees dans le fichier diachronique (dernier
+! argument = 1 pour ecriture; = 2 pour lecture; si =3, desallocation)
+ CALL ALLOC_FORDIACHRO(ITAB3(1),ITAB3(2),ITAB3(3),NNBF,1,1,1)
+! Initialisation de variables et matrices
+ LICP=.FALSE. ; LJCP=.FALSE. ; LKCP=.FALSE.
+ NIL=1 ; NJL=1 ; NKL=1
+ NIH=ITAB3(1) ; NJH=ITAB3(2) ; NKH=ITAB3(3)
+ XVAR(:,:,:,:,:,:)=0.
+ XTRAJT(:,:)=0.
+ CTITRE(:)(1:LEN(CTITRE))=' '
+ CUNITE(:)(1:LEN(CUNITE))=' '
+ CCOMMENT(:)(1:LEN(CCOMMENT))=' '
+ XDATIME(:,:)=0.
+ ENDIF
+!
+! Distinction 1er fichier et les suivants. Dans le premier cas on ecrit di-
+! -rectement dans le fic. diachronique et apres les avoir reorganisees les
+! informations lues. Dans les cas suivants, on relit d'abord les infos du
+! fic. diachron. pour les augmenter des nouvelles fraichement lues avant
+! de les reecrire.
+! NOTA on a pris la precaution de prevoir des le depart une taille d'article
+! = a la dimension de la matrice traitee * par le nb de fichiers lus (NNBF)
+!
+ IF (K == 1)THEN !************************************
+! resolution degradee
+ ! in: ZTAB3, taille:IIU(ou 1),IJU(ou 1),IKU
+ ! out: XVAR, taille:ITAB3
+ SELECT CASE(ixyz)
+ CASE (0)
+ XVAR(:,:,:,K,1,1)=ZTAB3
+ CASE (1) !X
+ DO J3=1,SIZE(ZTAB3,3)
+ DO J2=1,SIZE(ZTAB3,2)
+ XVAR(:,J2,J3,K,1,1)=ZTAB3(1:IIU:KX,J2,J3)
+ END DO
+ END DO
+ CASE (10) !Y
+ DO J3=1,SIZE(ZTAB3,3)
+ DO J1=1,SIZE(ZTAB3,1)
+ XVAR(J1,:,J3,K,1,1)=ZTAB3(J1,1:IJU:KY,J3)
+ END DO
+ END DO
+ CASE (11) !X et Y
+ DO J3=1,SIZE(ZTAB3,3)
+ I2=0
+ DO J2=1,SIZE(ZTAB3,2),KY
+ I2=I2+1
+ XVAR(:,I2,J3,K,1,1)=ZTAB3(1:IIU:KX,J2,J3)
+ END DO
+ IF (I2>SIZE(XVAR,2)) THEN
+ print*,'cas xy: niveau ',J3,' debordement de tableau: ', &
+ I2,SIZE(XVAR,2)
+ STOP
+ ENDIF
+ END DO
+ CASE (100) !Z
+ DO J2=1,SIZE(ZTAB3,2)
+ DO J1=1,SIZE(ZTAB3,1)
+ XVAR(J1,J2,:,K,1,1)=ZTAB3(J1,J2,1:IKU:KZ)
+ END DO
+ END DO
+ CASE (101) !X et Z
+ DO J2=1,SIZE(ZTAB3,2)
+ I1=0
+ DO J1=1,SIZE(ZTAB3,1),KX
+ I1=I1+1
+ XVAR(I1,J2,:,K,1,1)=ZTAB3(J1,J2,1:IKU:KZ)
+ END DO
+ IF (I1>SIZE(XVAR,1)) THEN
+ print*,'cas xz: colonne ',J2,' debordement de tableau: ', &
+ I1,SIZE(XVAR,1)
+ STOP
+ ENDIF
+ END DO
+ CASE (110) !Y et Z
+ DO J1=1,SIZE(ZTAB3,1)
+ I2=0
+ DO J2=1,SIZE(ZTAB3,2),KY
+ I2=I2+1
+ XVAR(J1,I2,:,K,1,1)=ZTAB3(J1,I2,1:IKU:KZ)
+ IF (I2>SIZE(XVAR,2)) THEN
+ print*,'cas xy: ligne ',J1,' debordement de tableau: ', &
+ I2,SIZE(XVAR,2)
+ STOP
+ ENDIF
+ END DO
+ END DO
+ CASE (111) !X, Y et Z
+ ALLOCATE(Z3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(ZTAB3,3)))
+ !first X et Y
+ DO J3=1,SIZE(ZTAB3,3)
+ I2=0
+ DO J2=1,SIZE(ZTAB3,2),KY
+ I2=I2+1
+ Z3D(:,I2,J3)=ZTAB3(1:IIU:KX,J2,J3)
+ END DO
+ IF (I2>SIZE(XVAR,2)) THEN
+ print*,'cas xyz: niveau ',J3,' debordement de tableau: ', &
+ I2,SIZE(XVAR,2)
+ STOP
+ ENDIF
+ END DO
+ !then Z
+ DO J2=1,SIZE(XVAR,2)
+ DO J1=1,SIZE(XVAR,1)
+ XVAR(J1,J2,:,K,1,1)=Z3D(J1,J2,1:IKU:KZ)
+ END DO
+ END DO
+ DEALLOCATE(Z3D)
+ END SELECT
+!
+! Le tps courant est transforme en temps relatif par / au debut de l'experience
+ CALL TEMPORAL_DIST(TDTCUR%TDATE%YEAR,TDTCUR%TDATE%MONTH, &
+ TDTCUR%TDATE%DAY,TDTCUR%TIME,TDTEXP%TDATE%YEAR, &
+ TDTEXP%TDATE%MONTH,TDTEXP%TDATE%DAY,TDTEXP%TIME, &
+ XTRAJT(K,1))
+ TZDTEXP=TDTEXP
+ CTITRE(1)=CGROUP
+ CUNITE(1)=ADJUSTL(YCAROUT)
+ CCOMMENT(1)=YCOMMENT
+ XDATIME(1,K)=TDTEXP%TDATE%YEAR; XDATIME(2,K)=TDTEXP%TDATE%MONTH
+ XDATIME(3,K)=TDTEXP%TDATE%DAY; XDATIME(4,K)=TDTEXP%TIME
+ XDATIME(5,K)=TDTSEG%TDATE%YEAR; XDATIME(6,K)=TDTSEG%TDATE%MONTH
+ XDATIME(7,K)=TDTSEG%TDATE%DAY; XDATIME(8,K)=TDTSEG%TIME
+ XDATIME(9,K)=TDTMOD%TDATE%YEAR; XDATIME(10,K)=TDTMOD%TDATE%MONTH
+ XDATIME(11,K)=TDTMOD%TDATE%DAY; XDATIME(12,K)=TDTMOD%TIME
+ XDATIME(13,K)=TDTCUR%TDATE%YEAR;XDATIME(14,K)=TDTCUR%TDATE%MONTH
+ XDATIME(15,K)=TDTCUR%TDATE%DAY; XDATIME(16,K)=TDTCUR%TIME
+!
+! Ecriture dans le fichier diachronique
+ NGRIDIA(1)=IGRID
+ CALL WRITE_DIACHRO(HFILEDIA,HLUOUTDIA,CGROUP,CTYPE,NGRIDIA,XDATIME,XVAR, &
+ XTRAJT,CTITRE,CUNITE,CCOMMENT, &
+ LICP,LJCP,LKCP,NIL,NIH,NJL,NJH,NKL,NKH)
+!
+! Desallocation des matrices
+ DEALLOCATE(ZTAB3)
+ CALL ALLOC_FORDIACHRO(IIU,IJU,IKU,NNBF,1,1,3)
+!
+ ELSE !************************************
+!
+! On relit les infos deja enregistrees du fichier diachronique en connaissant
+! le nom du groupe CGROUP=CRECFM2T(JJ,K)
+ CALL READ_DIACHRO(CFILEDIA,CLUOUTDIA,CGROUP)
+ SELECT CASE(ixyz)
+ CASE (0)
+ XVAR(:,:,:,K,1,1)=ZTAB3
+ CASE (1) !X
+ DO J3=1,SIZE(ZTAB3,3)
+ DO J2=1,SIZE(ZTAB3,2)
+ XVAR(:,J2,J3,K,1,1)=ZTAB3(1:IIU:KX,J2,J3)
+ END DO
+ END DO
+ CASE (10) !Y
+ DO J3=1,SIZE(ZTAB3,3)
+ DO J1=1,SIZE(ZTAB3,1)
+ XVAR(J1,:,J3,K,1,1)=ZTAB3(J1,1:IJU:KY,J3)
+ END DO
+ END DO
+ CASE (11) !X et Y
+ DO J3=1,SIZE(ZTAB3,3)
+ I2=0
+ DO J2=1,SIZE(ZTAB3,2),KY
+ I2=I2+1
+ XVAR(:,I2,J3,K,1,1)=ZTAB3(1:IIU:KX,J2,J3)
+ END DO
+ END DO
+ CASE (100) !Z
+ DO J2=1,SIZE(ZTAB3,2)
+ DO J1=1,SIZE(ZTAB3,1)
+ XVAR(J1,J2,:,K,1,1)=ZTAB3(J1,J2,1:IKU:KZ)
+ END DO
+ END DO
+ CASE (101) !X et Z
+ DO J2=1,SIZE(ZTAB3,2)
+ I1=0
+ DO J1=1,SIZE(ZTAB3,1),KX
+ I1=I1+1
+ XVAR(I1,J2,:,K,1,1)=ZTAB3(J1,J2,1:IKU:KZ)
+ END DO
+ END DO
+ CASE (110) !Y et Z
+ DO J1=1,SIZE(ZTAB3,1)
+ I2=0
+ DO J2=1,SIZE(ZTAB3,2),KY
+ I2=I2+1
+ XVAR(J1,I2,:,K,1,1)=ZTAB3(J1,I2,1:IKU:KZ)
+ END DO
+ END DO
+ CASE (111) !X, Y et Z
+ ALLOCATE(Z3D(SIZE(XVAR,1),SIZE(XVAR,2),SIZE(ZTAB3,3)))
+ !first X et Y
+ DO J3=1,SIZE(ZTAB3,3)
+ I2=0
+ DO J2=1,SIZE(ZTAB3,2),KY
+ I2=I2+1
+ Z3D(:,I2,J3)=ZTAB3(1:IIU:KX,J2,J3)
+ END DO
+ END DO
+ !then Z
+ DO J2=1,SIZE(XVAR,2)
+ DO J1=1,SIZE(XVAR,1)
+ XVAR(J1,J2,:,K,1,1)=Z3D(J1,J2,1:IKU:KZ)
+ END DO
+ END DO
+ DEALLOCATE(Z3D)
+ END SELECT
+ CALL TEMPORAL_DIST(TDTCUR%TDATE%YEAR,TDTCUR%TDATE%MONTH, &
+ TDTCUR%TDATE%DAY,TDTCUR%TIME,TDTEXP%TDATE%YEAR, &
+ TDTEXP%TDATE%MONTH,TDTEXP%TDATE%DAY,TDTEXP%TIME, &
+ XTRAJT(K,1))
+ IF (CSTORAGE_TYPE=='TT') THEN
+ CALL TEMPORAL_DIST(TDTCUR%TDATE%YEAR,TDTCUR%TDATE%MONTH, &
+ TDTCUR%TDATE%DAY,TDTCUR%TIME,TZDTEXP%TDATE%YEAR, &
+ TZDTEXP%TDATE%MONTH,TZDTEXP%TDATE%DAY,TZDTEXP%TIME, &
+ XTRAJT(K,1))
+ WRITE(NLUOUTD,*) &
+ ' WRITE_OTHERSFIELDS calcul de XTRAJT par rapport au 1er fichier ',XTRAJT(K,1)
+ END IF
+ XDATIME(1,K)=TDTEXP%TDATE%YEAR; XDATIME(2,K)=TDTEXP%TDATE%MONTH
+ XDATIME(3,K)=TDTEXP%TDATE%DAY; XDATIME(4,K)=TDTEXP%TIME
+ XDATIME(5,K)=TDTSEG%TDATE%YEAR; XDATIME(6,K)=TDTSEG%TDATE%MONTH
+ XDATIME(7,K)=TDTSEG%TDATE%DAY; XDATIME(8,K)=TDTSEG%TIME
+ XDATIME(9,K)=TDTMOD%TDATE%YEAR; XDATIME(10,K)=TDTMOD%TDATE%MONTH
+ XDATIME(11,K)=TDTMOD%TDATE%DAY; XDATIME(12,K)=TDTMOD%TIME
+ XDATIME(13,K)=TDTCUR%TDATE%YEAR;XDATIME(14,K)=TDTCUR%TDATE%MONTH
+ XDATIME(15,K)=TDTCUR%TDATE%DAY; XDATIME(16,K)=TDTCUR%TIME
+!
+ WRITE(ILUOUTDIA,*)' OTHERSFIELDS IGRID XVAR,XTRAJT,CTITRE,CUNITE,CCOMMENT'
+ WRITE(ILUOUTDIA,*)IGRID,SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6),' ',SIZE(XTRAJT,1),SIZE(XTRAJT,2),XTRAJT
+ WRITE(ILUOUTDIA,*)(CTITRE(J)(1:LEN(CTITRE)),J=1,SIZE(CTITRE))
+ WRITE(ILUOUTDIA,*)(CUNITE(J)(1:LEN(CUNITE)),J=1,SIZE(CUNITE))
+ WRITE(ILUOUTDIA,*)(CCOMMENT(J)(1:LEN(CCOMMENT)),J=1,SIZE(CCOMMENT))
+
+! Ecriture dans le fichier diachronique
+ NGRIDIA(1)=IGRID
+ CALL WRITE_DIACHRO(HFILEDIA,HLUOUTDIA,CGROUP,CTYPE,NGRIDIA,XDATIME,XVAR, &
+ XTRAJT,CTITRE,CUNITE,CCOMMENT, &
+ LICP,LJCP,LKCP,NIL,NIH,NJL,NJH,NKL,NKH)
+
+! Desallocation des matrices
+ DEALLOCATE(ZTAB3)
+ CALL ALLOC_FORDIACHRO(IIU,IJU,IKU,NNBF,1,1,3)
+
+ ENDIF !************************************
+!
+!
+!* 2.2 ++++2D+++++
+!
+! Traitement des infos 2D (Traite avec le 3D)
+! ELSE IF(NSIZT(JJ,K) == IIU*IJU)THEN
+!
+!
+!* 2.3 ++++1D // Z+++++
+!
+! Traitement des infos 1D
+ ELSE IF(NSIZT(JJ,K) == IKU)THEN
+ WRITE(NLUOUTD,*)'***************************************************************'
+ WRITE(NLUOUTD,*)' Variable 1D rencontree et enregistree dans le fichier',&
+ &' diachronique ',CGROUP,' size et IKU ',NSIZT(JJ,K),IKU
+ WRITE(NLUOUTD,*)'***************************************************************'
+ ITAB3(1)=1; ITAB3(2)=1; ITAB3(3)=IKU
+ IF(ALLOCATED(ZTAB3))THEN
+ DEALLOCATE(ZTAB3)
+ ENDIF
+ ALLOCATE(ZTAB3(ITAB3(1),ITAB3(2),ITAB3(3)))
+ ZTAB3=RESHAPE(ZTAB,ITAB3)
+!
+ IF(K == 1)THEN
+ CTYPE='CART'
+! resolution degradee
+ IF (PRESENT(KZ)) THEN
+ IF (KZ>1) ITAB3(3)=(IKU-1)/KZ +1
+ ENDIF
+! Allocation des matrices utilisees dans le fichier diachronique (dernier
+! argument = 1 pour ecriture; = 2 pour lecture; si =3, desallocation)
+ CALL ALLOC_FORDIACHRO(ITAB3(1),ITAB3(2),ITAB3(3),NNBF,1,1,1)
+! Initialisation de variables et matrices
+ LICP=.FALSE. ; LJCP=.FALSE. ; LKCP=.FALSE.
+ NIL=JPHEXT ; NJL=JPHEXT ; NKL=1
+ NIH=JPHEXT ; NJH=JPHEXT ; NKH=ITAB3(3)
+ XVAR(:,:,:,:,:,:)=0.
+ XTRAJT(:,:)=0.
+ CTITRE(:)(1:LEN(CTITRE))=' '
+ CUNITE(:)(1:LEN(CUNITE))=' '
+ CCOMMENT(:)(1:LEN(CCOMMENT))=' '
+ XDATIME(:,:)=0
+ ENDIF
+!
+! Distinction 1er fichier et les suivants. Dans le premier cas on ecrit di-
+! -rectement dans le fic. diachronique et apres les avoir reorganisees les
+! informations lues. Dans les cas suivants, on relit d'abord les infos du
+! fic. diachron. pour les augmenter des nouvelles fraichement lues avant
+! de les reecrire.
+! NOTA on a pris la precaution de prevoir des le depart une taille d'article
+! = a la dimension de la matrice traitee * par le nb de fichiers lus (NNBF)
+!
+ IF (K == 1)THEN !************************************
+ IF (PRESENT(KZ)) THEN
+ DO J2=1,SIZE(ZTAB3,2)
+ DO J1=1,SIZE(ZTAB3,1)
+ XVAR(J1,J2,:,K,1,1)=ZTAB3(J1,J2,1:IKU:KZ)
+ END DO
+ END DO
+ ELSE
+ XVAR(:,:,:,K,1,1)=ZTAB3
+ ENDIF
+!
+! Le tps courant est transforme en temps relatif par / au debut de l'experience
+ CALL TEMPORAL_DIST(TDTCUR%TDATE%YEAR,TDTCUR%TDATE%MONTH, &
+ TDTCUR%TDATE%DAY,TDTCUR%TIME,TDTEXP%TDATE%YEAR, &
+ TDTEXP%TDATE%MONTH,TDTEXP%TDATE%DAY,TDTEXP%TIME, &
+ XTRAJT(K,1))
+ CTITRE(1)=CGROUP
+ CUNITE(1)=ADJUSTL(YCAROUT)
+ CCOMMENT(1)=YCOMMENT
+ XDATIME(1,K)=TDTEXP%TDATE%YEAR; XDATIME(2,K)=TDTEXP%TDATE%MONTH
+ XDATIME(3,K)=TDTEXP%TDATE%DAY; XDATIME(4,K)=TDTEXP%TIME
+ XDATIME(5,K)=TDTSEG%TDATE%YEAR; XDATIME(6,K)=TDTSEG%TDATE%MONTH
+ XDATIME(7,K)=TDTSEG%TDATE%DAY; XDATIME(8,K)=TDTSEG%TIME
+ XDATIME(9,K)=TDTMOD%TDATE%YEAR; XDATIME(10,K)=TDTMOD%TDATE%MONTH
+ XDATIME(11,K)=TDTMOD%TDATE%DAY; XDATIME(12,K)=TDTMOD%TIME
+ XDATIME(13,K)=TDTCUR%TDATE%YEAR;XDATIME(14,K)=TDTCUR%TDATE%MONTH
+ XDATIME(15,K)=TDTCUR%TDATE%DAY; XDATIME(16,K)=TDTCUR%TIME
+
+! Ecriture dans le fichier diachronique
+ NGRIDIA(1)=IGRID
+ CALL WRITE_DIACHRO(HFILEDIA,HLUOUTDIA,CGROUP,CTYPE,NGRIDIA,XDATIME,XVAR, &
+ XTRAJT,CTITRE,CUNITE,CCOMMENT, &
+ LICP,LJCP,LKCP,NIL,NIH,NJL,NJH,NKL,NKH)
+
+! Desallocation des matrices
+ DEALLOCATE(ZTAB3)
+ CALL ALLOC_FORDIACHRO(1,1,IKU,NNBF,1,1,3)
+!
+ ELSE !************************************
+!
+! On relit les infos deja enregistrees du fichier diachronique en connaissant
+! le nom du groupe CGROUP=CRECFM2T(JJ,K)
+ CALL READ_DIACHRO(CFILEDIA,CLUOUTDIA,CGROUP)
+ IF (PRESENT(KZ)) THEN
+ DO J2=1,SIZE(ZTAB3,2)
+ DO J1=1,SIZE(ZTAB3,1)
+ XVAR(J1,J2,:,K,1,1)=ZTAB3(J1,J2,1:IKU:KZ)
+ END DO
+ END DO
+ ELSE
+ XVAR(:,:,:,K,1,1)=ZTAB3
+ ENDIF
+ CALL TEMPORAL_DIST(TDTCUR%TDATE%YEAR,TDTCUR%TDATE%MONTH, &
+ TDTCUR%TDATE%DAY,TDTCUR%TIME,TDTEXP%TDATE%YEAR, &
+ TDTEXP%TDATE%MONTH,TDTEXP%TDATE%DAY,TDTEXP%TIME, &
+ XTRAJT(K,1))
+ XDATIME(1,K)=TDTEXP%TDATE%YEAR; XDATIME(2,K)=TDTEXP%TDATE%MONTH
+ XDATIME(3,K)=TDTEXP%TDATE%DAY; XDATIME(4,K)=TDTEXP%TIME
+ XDATIME(5,K)=TDTSEG%TDATE%YEAR; XDATIME(6,K)=TDTSEG%TDATE%MONTH
+ XDATIME(7,K)=TDTSEG%TDATE%DAY; XDATIME(8,K)=TDTSEG%TIME
+ XDATIME(9,K)=TDTMOD%TDATE%YEAR; XDATIME(10,K)=TDTMOD%TDATE%MONTH
+ XDATIME(11,K)=TDTMOD%TDATE%DAY; XDATIME(12,K)=TDTMOD%TIME
+ XDATIME(13,K)=TDTCUR%TDATE%YEAR;XDATIME(14,K)=TDTCUR%TDATE%MONTH
+ XDATIME(15,K)=TDTCUR%TDATE%DAY; XDATIME(16,K)=TDTCUR%TIME
+
+ WRITE(ILUOUTDIA,*)' OTHERSFIELDS IGRID XVAR,XTRAJT,CTITRE,CUNITE,CCOMMENT'
+ WRITE(ILUOUTDIA,*)IGRID,SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6),' ',SIZE(XTRAJT,1),SIZE(XTRAJT,2)
+ WRITE(ILUOUTDIA,*)(CTITRE(J)(1:LEN(CTITRE)),J=1,SIZE(CTITRE))
+ WRITE(ILUOUTDIA,*)(CUNITE(J)(1:LEN(CUNITE)),J=1,SIZE(CUNITE))
+ WRITE(ILUOUTDIA,*)(CCOMMENT(J)(1:LEN(CCOMMENT)),J=1,SIZE(CCOMMENT))
+!
+! Ecriture dans le fichier diachronique
+ NGRIDIA(1)=IGRID
+ CALL WRITE_DIACHRO(HFILEDIA,HLUOUTDIA,CGROUP,CTYPE,NGRIDIA,XDATIME,XVAR, &
+ XTRAJT,CTITRE,CUNITE,CCOMMENT, &
+ LICP,LJCP,LKCP,NIL,NIH,NJL,NJH,NKL,NKH)
+!
+! Desallocation des matrices
+ DEALLOCATE(ZTAB3)
+ CALL ALLOC_FORDIACHRO(1,1,IKU,NNBF,1,1,3)
+!
+ ENDIF !************************************
+!
+!
+!* 2.4 ++++0D+++++
+!
+! Traitement des scalaires 'individuels'
+ ELSE IF(NSIZT(JJ,K) == 1)THEN
+! WRITE(NLUOUTD,*)'***************************************************************'
+! WRITE(NLUOUTD,*)' Scalaire rencontre et non enregistre dans le fichier',&
+! WRITE(NLUOUTD,*)' Scalaire rencontre et enregistre dans le fichier',&
+! &' diachronique ',CGROUP,' size ',NSIZT(JJ,K)
+! WRITE(NLUOUTD,*)' Prevenir J.DURON . Mail: durj@aero.obs-mip.fr '
+! Prise en compte de certains temps
+! WRITE(NLUOUTD,*)'***************************************************************'
+ IPCENT=0
+ IPCENT=INDEX(CRECFM2T(JJ,K),'%TIM')
+ IF(IPCENT /= 0)THEN !===================
+ CALL FMWRIT(HFILEDIA,CGROUP,HLUOUTDIA,NSIZT(JJ,K),ZTAB,IGRID,&
+ ILYCOMM,YCOMM,IRESP)
+! ILENCH,YCOMMENT,IRESP)
+ CALL ELIM(CRECFM2T(JJ,K))
+ print *,' Impression pour controle ',CGROUP,ZTAB,' size ', &
+ NSIZT(JJ,K)
+ ELSE !===================
+!
+ ITAB3(1)=1; ITAB3(2)=1; ITAB3(3)=1
+ IF(ALLOCATED(ZTAB3))THEN
+ DEALLOCATE(ZTAB3)
+ ENDIF
+ ALLOCATE(ZTAB3(ITAB3(1),ITAB3(2),ITAB3(3)))
+ ZTAB3=RESHAPE(ZTAB,ITAB3)
+!
+ IF(K == 1)THEN
+ CTYPE='CART'
+!
+! Allocation des matrices utilisees dans le fichier diachronique (dernier
+! argument = 1 pour ecriture; = 2 pour lecture; si =3, desallocation)
+!
+ CALL ALLOC_FORDIACHRO(ITAB3(1),ITAB3(2),ITAB3(3),NNBF,1,1,1)
+
+! Initialisation de variables et matrices
+ LICP=.FALSE. ; LJCP=.FALSE. ; LKCP=.FALSE.
+ NIL=1 ; NJL=1 ; NKL=1
+ NIH=1 ; NJH=1 ; NKH=1
+ XVAR(:,:,:,:,:,:)=0.
+ XTRAJT(:,:)=0.
+ CTITRE(:)(1:LEN(CTITRE))=' '
+ CUNITE(:)(1:LEN(CUNITE))=' '
+ CCOMMENT(:)(1:LEN(CCOMMENT))=' '
+ XDATIME(:,:)=0
+ ENDIF
+!
+! Distinction 1er fichier et les suivants. Dans le premier cas on ecrit di-
+! -rectement dans le fic. diachronique et apres les avoir reorganisees les
+! informations lues. Dans les cas suivants, on relit d'abord les infos du
+! fic. diachron. pour les augmenter des nouvelles fraichement lues avant
+! de les reecrire.
+! NOTA on a pris la precaution de prevoir des le depart une taille d'article
+! = a la dimension de la matrice traitee * par le nb de fichiers lus (NNBF)
+!
+ IF (K == 1)THEN !************************************
+ XVAR(:,:,:,K,1,1)=ZTAB3
+!
+! Le tps courant est transforme en temps relatif par / au debut de l'experience
+ CALL TEMPORAL_DIST(TDTCUR%TDATE%YEAR,TDTCUR%TDATE%MONTH, &
+ TDTCUR%TDATE%DAY,TDTCUR%TIME,TDTEXP%TDATE%YEAR, &
+ TDTEXP%TDATE%MONTH,TDTEXP%TDATE%DAY,TDTEXP%TIME, &
+ XTRAJT(K,1))
+ CTITRE(1)=CGROUP
+ CUNITE(1)=ADJUSTL(YCAROUT)
+ CCOMMENT(1)=YCOMMENT
+ XDATIME(1,K)=TDTEXP%TDATE%YEAR; XDATIME(2,K)=TDTEXP%TDATE%MONTH
+ XDATIME(3,K)=TDTEXP%TDATE%DAY; XDATIME(4,K)=TDTEXP%TIME
+ XDATIME(5,K)=TDTSEG%TDATE%YEAR; XDATIME(6,K)=TDTSEG%TDATE%MONTH
+ XDATIME(7,K)=TDTSEG%TDATE%DAY; XDATIME(8,K)=TDTSEG%TIME
+ XDATIME(9,K)=TDTMOD%TDATE%YEAR; XDATIME(10,K)=TDTMOD%TDATE%MONTH
+ XDATIME(11,K)=TDTMOD%TDATE%DAY; XDATIME(12,K)=TDTMOD%TIME
+ XDATIME(13,K)=TDTCUR%TDATE%YEAR;XDATIME(14,K)=TDTCUR%TDATE%MONTH
+ XDATIME(15,K)=TDTCUR%TDATE%DAY; XDATIME(16,K)=TDTCUR%TIME
+!
+! Ecriture dans le fichier diachronique
+ NGRIDIA(1)=IGRID
+ CALL WRITE_DIACHRO(HFILEDIA,HLUOUTDIA,CGROUP,CTYPE,NGRIDIA,XDATIME,XVAR, &
+ XTRAJT,CTITRE,CUNITE,CCOMMENT, &
+ LICP,LJCP,LKCP,NIL,NIH,NJL,NJH,NKL,NKH)
+!
+! Desallocation des matrices
+ DEALLOCATE(ZTAB3)
+ CALL ALLOC_FORDIACHRO(1,1,1,NNBF,1,1,3)
+!
+ ELSE !************************************
+!
+! On relit les infos deja enregistrees du fichier diachronique en connaissant
+! le nom du groupe CGROUP=CRECFM2T(JJ,K)
+ CALL READ_DIACHRO(CFILEDIA,CLUOUTDIA,CGROUP)
+ XVAR(:,:,:,K,1,1)=ZTAB3
+ CALL TEMPORAL_DIST(TDTCUR%TDATE%YEAR,TDTCUR%TDATE%MONTH, &
+ TDTCUR%TDATE%DAY,TDTCUR%TIME,TDTEXP%TDATE%YEAR, &
+ TDTEXP%TDATE%MONTH,TDTEXP%TDATE%DAY,TDTEXP%TIME, &
+ XTRAJT(K,1))
+ XDATIME(1,K)=TDTEXP%TDATE%YEAR; XDATIME(2,K)=TDTEXP%TDATE%MONTH
+ XDATIME(3,K)=TDTEXP%TDATE%DAY; XDATIME(4,K)=TDTEXP%TIME
+ XDATIME(5,K)=TDTSEG%TDATE%YEAR; XDATIME(6,K)=TDTSEG%TDATE%MONTH
+ XDATIME(7,K)=TDTSEG%TDATE%DAY; XDATIME(8,K)=TDTSEG%TIME
+ XDATIME(9,K)=TDTMOD%TDATE%YEAR; XDATIME(10,K)=TDTMOD%TDATE%MONTH
+ XDATIME(11,K)=TDTMOD%TDATE%DAY; XDATIME(12,K)=TDTMOD%TIME
+ XDATIME(13,K)=TDTCUR%TDATE%YEAR;XDATIME(14,K)=TDTCUR%TDATE%MONTH
+ XDATIME(15,K)=TDTCUR%TDATE%DAY; XDATIME(16,K)=TDTCUR%TIME
+
+ WRITE(ILUOUTDIA,*)' OTHERSFIELDS IGRID XVAR,XTRAJT,CTITRE,CUNITE,CCOMMENT'
+ WRITE(ILUOUTDIA,*)IGRID,SIZE(XVAR,1),SIZE(XVAR,2),SIZE(XVAR,3),SIZE(XVAR,4), &
+ SIZE(XVAR,5),SIZE(XVAR,6),' ',SIZE(XTRAJT,1),SIZE(XTRAJT,2)
+ WRITE(ILUOUTDIA,*)(CTITRE(J)(1:LEN(CTITRE)),J=1,SIZE(CTITRE))
+ WRITE(ILUOUTDIA,*)(CUNITE(J)(1:LEN(CUNITE)),J=1,SIZE(CUNITE))
+ WRITE(ILUOUTDIA,*)(CCOMMENT(J)(1:LEN(CCOMMENT)),J=1,SIZE(CCOMMENT))
+!
+! Ecriture dans le fichier diachronique
+ NGRIDIA(1)=IGRID
+ CALL WRITE_DIACHRO(HFILEDIA,HLUOUTDIA,CGROUP,CTYPE,NGRIDIA,XDATIME,XVAR, &
+ XTRAJT,CTITRE,CUNITE,CCOMMENT, &
+ LICP,LJCP,LKCP,NIL,NIH,NJL,NJH,NKL,NKH)
+!
+! Desallocation des matrices
+ DEALLOCATE(ZTAB3)
+ CALL ALLOC_FORDIACHRO(1,1,1,NNBF,1,1,3)
+
+ ENDIF !************************************
+ ENDIF !===============
+!
+!
+!* 2.5 ++++ +++++
+!
+! Impression des infos non recensees
+!
+ ELSE
+! Some dates are taken into account
+ IPCENT=0
+ IPCENT=INDEX(CRECFM2T(JJ,K),'%TDA')
+ IF(IPCENT /= 0)THEN !===================
+ CALL FMWRIT(HFILEDIA,CGROUP,HLUOUTDIA,NSIZT(JJ,K),ZTAB,IGRID,&
+ ILYCOMM,YCOMM,IRESP)
+! ILENCH,YCOMMENT,IRESP)
+ CALL ELIM(CRECFM2T(JJ,K))
+ print *,' Impression pour controle ',CGROUP,ZTAB,' size ',NSIZT(JJ,K)
+ ELSE
+ WRITE(NLUOUTD,*)'***************************************************************'
+ WRITE(NLUOUTD,*)' Variable non prise en compte dans le fichier diachronique ',&
+ CGROUP,' size ',NSIZT(JJ,K),' IIU IJU IKU ',IIU,IJU,IKU
+ IF (LEN_TRIM(YCOMMENT) /=0) THEN
+ WRITE(NLUOUTD,*)' YCOMMENT=',YCOMMENT(1:LEN_TRIM(YCOMMENT))
+ ELSE
+ WRITE(NLUOUTD,*)' YCOMMENT '
+ ENDIF
+ WRITE(NLUOUTD,*)'***************************************************************'
+ ENDIF
+ ENDIF
+!
+!
+!* 2.6 ++++END+++++
+!
+!
+ DEALLOCATE(ZTAB)
+ IF(K == NNBF)THEN
+ WRITE(ILUOUTDIA,*)CRECFM2T(JJ,K),' TREATED with size ', NSIZT(JJ,K)*K*IMULT
+ ENDIF
+!
+!
+!----------------------------------------------------------------------------
+!
+!* 3. TREATMENT OF ELIMINATED VARIABLE
+! --------------------------------
+!
+ ELSE
+ IPCENT=0
+ IPCENT=INDEX(CRECFM2T(JJ,K),'%TIM')
+ IF(IPCENT /= 0 .AND. K >1)THEN
+ IF(INDEX(CRECFM2T(JJ,K),'TDTEXP%TDA') /= 0 .OR. &
+ INDEX(CRECFM2T(JJ,K),'TDTEXP%TIM') /= 0 .OR. &
+ INDEX(CRECFM2T(JJ,K),'TDTSEG%TDA') /= 0 .OR. &
+ INDEX(CRECFM2T(JJ,K),'TDTSEG%TIM') /= 0 .OR. &
+ INDEX(CRECFM2T(JJ,K),'TDTMOD%TDA') /= 0 .OR. &
+ INDEX(CRECFM2T(JJ,K),'TDTMOD%TIM') /= 0 .OR. &
+ INDEX(CRECFM2T(JJ,K),'TDTCUR%TDA') /= 0 .OR. &
+ INDEX(CRECFM2T(JJ,K),'TDTCUR%TIM') /= 0)THEN
+ ELSE
+ ALLOCATE(ZTAB(NSIZT(JJ,K)))
+ CALL FMREAD(CNAMFILED(K),CRECFM2T(JJ,K),CLUOUTD,NSIZT(JJ,K), &
+ ZTAB,IGRID,ILENCH,YCOMMENT,IRESP)
+ print *,' CRECFM2T(JJ,K) K= ',CRECFM2T(JJ,K),K,' non enr. volontairement .'
+ DEALLOCATE(ZTAB)
+ ENDIF
+ ENDIF
+ ENDIF
+!
+ENDDO
+!
+LPACK=GPACK
+!----------------------------------------------------------------------------
+RETURN
+!
+END SUBROUTINE WRITE_OTHERSFIELDS
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_alloc2_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_alloc2_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9284000e6646951a124a9885ef1dfd044fe0c79c
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_alloc2_fordiachro.f90
@@ -0,0 +1,52 @@
+! ######spl
+ MODULE MODD_ALLOC2_FORDIACHRO
+! ##############################
+!
+!!**** *MODD_ALLOC2_FORDIACHRO* -
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 01/02/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+
+REAL,DIMENSION(:,:,:,:,:,:), ALLOCATABLE,SAVE :: XMASK2
+INTEGER,DIMENSION(:), ALLOCATABLE,SAVE :: NGRIDIA2
+
+REAL,DIMENSION(:,:,:,:,:,:), ALLOCATABLE,SAVE :: XVAR2
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XTRAJT2
+REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE :: XTRAJX2, XTRAJY2, XTRAJZ2
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XDATIME2
+
+CHARACTER*100,DIMENSION(:), ALLOCATABLE,SAVE :: CTITRE2, CUNITE2, CCOMMENT2
+
+!
+!
+END MODULE MODD_ALLOC2_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_alloc_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_alloc_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..76ce7a295013de158de936b31196f50e5d5522bc
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_alloc_fordiachro.f90
@@ -0,0 +1,54 @@
+! ######spl
+ MODULE MODD_ALLOC_FORDIACHRO
+! #############################
+!
+!!**** *MODD_ALLOC_FORDIACHRO* -
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 01/02/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+INTEGER,SAVE :: NGRID, NGRIDIAM
+
+REAL,DIMENSION(:,:,:,:,:,:), ALLOCATABLE,SAVE :: XMASK
+INTEGER,DIMENSION(:), ALLOCATABLE,SAVE :: NGRIDIA
+
+REAL,DIMENSION(:,:,:,:,:,:), ALLOCATABLE,SAVE :: XVAR
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XTRAJT
+REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE :: XTRAJX, XTRAJY, XTRAJZ
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XDATIME
+
+CHARACTER*100,DIMENSION(:), ALLOCATABLE,SAVE :: CTITRE, CUNITE, CCOMMENT
+
+LOGICAL :: LPBREAD=.FALSE.
+!
+!
+END MODULE MODD_ALLOC_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_allvar.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_allvar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2acb3c04c54116a8b42205b8f1cfd6e8b1e6e56f
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_allvar.f90
@@ -0,0 +1,70 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_allvar.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODD_ALLVAR
+! ###################
+!
+!!**** *MODD_ALLVAR* - Declaration des tableaux de travail pour les
+! variables autres que prognostiques
+! et des types de variables permettant la memorisation
+! du nom de ces variables, du parametre NGRID, des unites
+!!
+!! PURPOSE
+!! -------
+! Declare des tableaux de travail pour des variables 3D, 2D, 1D,
+! scalaires ou vectorielles ne figurant pas parmi les champs de base
+! du modele
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/06/94
+!! Updated PM /11/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+USE MODD_TYPE_ALLVAR
+!
+IMPLICIT NONE
+!
+INTEGER,SAVE :: NVAR3D, NVAR2D
+
+LOGICAL :: LSCAL1D, LSCAL2D
+
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: XWORK3D
+
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: XWORKX3D
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: XWORKY3D
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: XWORKZ3D
+
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XWORK2D
+
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XWORKX2D
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XWORKY2D
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XWORKZ2D
+
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XWORK1D
+
+TYPE (X_Y_Z_) :: XT1
+TYPE (X_Y_) :: XT2
+TYPE (VX_VY_VZ_) :: XT3
+TYPE (VX_VY_) :: XT4
+TYPE (Z_) :: XT5
+END MODULE MODD_ALLVAR
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_convij2xy.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_convij2xy.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c514167023eefc5536a2b971724db19a9d840609
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_convij2xy.f90
@@ -0,0 +1,49 @@
+! ######spl
+ MODULE MODD_CONVIJ2XY
+! ######################
+!
+!!**** *MODD_CONVIJ2XY* -
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 01/04/99
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XCONVIJ
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XCONVI
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XCONVJ
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XCONVX
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XCONVY
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XCONVLAT
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XCONVLON
+
+!
+!
+END MODULE MODD_CONVIJ2XY
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_coord.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_coord.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1f29f3373eea4c303c8e5be62886811784c4d212
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_coord.f90
@@ -0,0 +1,97 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_coord.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! #################
+ MODULE MODD_COORD
+! #################
+!
+!!**** *MODD_COORD* - Declaration of the TRACE arrays giving the gridpoint
+!! coordinates for the 7 MESO-NH grid types.
+!!
+!! PURPOSE
+!! -------
+! This declarative module defines a set of arrays containing:
+!
+! - XHAT, YHAT, ZHAT coordinate values for all the MESO-NH grids
+! --> XXX(:,:) XXY(:,:) XXZ(:,:)
+! - Meshsize values for all the available MESO-NH grids:
+! --> XXDXHAT(:,:) XXDYHAT(:,:) XXDZHAT(:,:)
+! - Oblique meshsize values along the abscissa (horizontal) axis
+! of the oblique vertical cross-sections (for all the MESO-NH grids):
+! --> XXDS(:,:)
+! - Oblique abscissa values for the gridpoints along the horizontal
+! axis of the oblique vertical cross-sections(for all the MESO-NH grids):
+! --> XDS(:,:)
+! - X- and Y- projections on the MESO-NH axes directions for the gridpoints
+! along the oblique vertical cross-sections (for all the MESO-NH grids):
+! --> XDSX(:,:) XDSY(:,:)
+! - Interpolated topography for all the available MESO_NH grids:
+! --> XXZS(:,:,:)
+!
+! In all the forecoming arrays, the last index is the grid indicator,
+! NGRID, i. e. the number of the grid where the displayed variable is
+! located. Seven grids are available so far, see the MESO-NH Book-1
+! for definitions. The local name for this grid indicator may be IGRID,
+! or NMGRID, or KGRID according to the context.
+!
+! Lengthes are given in meters.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! The 7 MESO-NH grid types are defined in:
+!!
+!! - Asencio N. et al., 1994, "Le projet de modele non-hydrostatique
+!! commun CNRM-LA, specifications techniques",
+!! Note CNRM/GMME, 26, 139p, (pages 39 to 43).
+!!
+!! - Fischer C., 1994, "File structure and content in the Meso-NH
+!! model", Meso-nh internal note, CNRM/GMME, July 5.
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/06/94
+!! Updated PM 17/11/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+! XXDXHAT, XXDYHAT, Mesh size arrays (meters), last index is the grid indicator
+! XXDZHAT
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XXDXHAT, XXDYHAT, XXDZHAT
+
+! XXX, XXY, Values of XHAT, YHAT, ZHAT (meters) for the different grids,
+! XXZ as given by NGRID (second index, grid indicator)
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XXX, XXY, XXZ
+
+! XXDS Mesh size (meters) along the horizontal axis of an oblique
+! vertical cross-section, for all the grids (given by NGRID,
+! second index)
+! XDS Abscissa array along the horizontal axis of an oblique vertical
+! cross-section (meters), for all the grids (given by NGRID,
+! second index)
+! XDSX, XDSY Projections on the MESO-NH cartesian axes of the XDS oblique
+! abscissa (meters), for all the grids (given by NGRID, second
+! index)
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XXDS, XDS, XDSX, XDSY
+
+! XXZS Terrain topography (meters) interpolated at the NGRID gridpoint
+! location (for all the possible grids, given by the third index)
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: XXZS
+
+
+END MODULE MODD_COORD
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_ctl_axes_and_styl.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_ctl_axes_and_styl.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5d6d15322250b7e82c54d937f7f9c01e2eb573fd
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_ctl_axes_and_styl.f90
@@ -0,0 +1,74 @@
+! ######spl
+ MODULE MODD_CTL_AXES_AND_STYL
+! ##############################
+!
+!!**** *MODD_CTL_AXES_AND_STYL* -
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 01/02/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+! Controle des graduations majeures (labellees) et mineures sur les axes X et Y
+! On donne le nb d'intervalles
+!******************************************************************************
+! CH Projection cartographique _K_ _Z_ _PR_ _TK_ _EV_
+INTEGER:: NCHPCITVXMJ=0,NCHPCITVYMJ=0,NCHPCITVXMN=0,NCHPCITVYMN=0
+! CH Cartesien _K_ _Z_ _PR_ _TK_
+INTEGER:: NCHITVXMJ=5,NCHITVYMJ=4,NCHITVXMN=1,NCHITVYMN=1
+! CV _CV_ et _PVT_
+INTEGER:: NCVITVXMJ=5,NCVITVYMJ=10,NCVITVXMN=1,NCVITVYMN=1
+! PV _PV_
+INTEGER:: NPVITVXMJ=4,NPVITVYMJ=0,NPVITVXMN=1,NPVITVYMN=1
+! FT _FT_ _PVKT_
+INTEGER:: NFTITVXMJ=5,NFTITVYMJ=5,NFTITVXMN=2,NFTITVYMN=2
+! FT1 _FT1_
+INTEGER:: NFT1ITVXMJ=5,NFT1ITVYMJ=5,NFT1ITVXMN=1,NFT1ITVYMN=1
+! XY _XY_
+INTEGER:: NXYITVXMJ=5,NXYITVYMJ=5,NXYITVXMN=1,NXYITVYMN=1
+! MASK _MASK_
+INTEGER:: NMASKITVXMJ=5,NMASKITVYMJ=5,NMASKITVXMN=1,NMASKITVYMN=1
+
+! Axes labelles en latitude, longitude pour CH Proj. cart.
+LOGICAL :: LGEOG=.FALSE.
+
+! Axes labelles en indices de grilles
+LOGICAL,SAVE :: LINDAX=.FALSE.
+
+! Gestion de la taille titres en X
+REAL :: XSZTITXL=0., XSZTITXM=0., XSZTITXR=0.
+
+! Controle du type de trait avec _FT1_
+LOGICAL :: LFT1STYLUSER=.FALSE.
+LOGICAL :: LFTSTYLUSER=.FALSE.
+LOGICAL :: LTITFTUSER=.FALSE.
+!
+!
+END MODULE MODD_CTL_AXES_AND_STYL
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_cvert.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_cvert.f90
new file mode 100644
index 0000000000000000000000000000000000000000..13a9e8e20b709e652d5bba0c89514c3cf39f0c92
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_cvert.f90
@@ -0,0 +1,48 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_cvert.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODD_CVERT
+! ###################
+!
+!!**** *MODD_CVERT* - Declares work arrays for vertical cross-sections
+!!
+!! PURPOSE
+!! -------
+! For vertical cross-sections only, this declarative module declares
+! the arrays containing the sea-level altitudes and the model topography
+! of the oblique cross-section points.
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book2 of the TRACE volume of the Meso-NH user manual
+!! (MODD_CVERT)
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/06/94
+!! Updated PM 17/11/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+IMPLICIT NONE
+!
+REAL,DIMENSION(:,:,:),ALLOCATABLE,SAVE :: XWORKZ ! Sea-level altitude array
+ ! (meters)
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XWZ ! Topography array (meters)
+
+END MODULE MODD_CVERT
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_defcv.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_defcv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..214c65b5ff9fd8ed391c887d2fd975e824128914
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_defcv.f90
@@ -0,0 +1,59 @@
+! ######spl
+ MODULE MODD_DEFCV
+! ####################
+!
+!!**** *MODD_DEFCV* -
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 10/11/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+! Definition des limites CV en coord. conformes
+LOGICAL,SAVE :: LDEFCV2
+REAL,SAVE :: XIDEBCV, XIFINCV, XJDEBCV, XJFINCV
+! Definition des limites CV en Lat/lon
+LOGICAL,SAVE :: LDEFCV2LL
+REAL,SAVE :: XIDEBCVLL, XIFINCVLL, XJDEBCVLL, XJFINCVLL
+! Definition des limites CV en indices de points de grille
+LOGICAL,SAVE :: LDEFCV2IND
+INTEGER,SAVE :: NIDEBCV, NIFINCV, NJDEBCV, NJFINCV
+!
+! Logique general pour moi
+LOGICAL,SAVE :: LDEFCV2CC
+!
+! Angle de la coupe en valeur reelle (/axe des X)
+REAL,SAVE :: XANGLECV
+!
+! PV : localisation en indices de grille, LL et CC (Transmission entre trapro
+! et pro1d)
+INTEGER, SAVE :: NIPROFV, NJPROFV
+REAL,SAVE :: XIPROFV, XJPROFV
+END MODULE MODD_DEFCV
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_diachro.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_diachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..79d517c5b20f4b0230b9c5e5a5671550b8ebafeb
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_diachro.f90
@@ -0,0 +1,58 @@
+! ######spl
+ MODULE MODD_DIACHRO
+! ####################
+!
+!!**** *MODD_DIACHRO* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original JD 08/01/96
+!! updated PM
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+! Nom fichier diachronique
+!
+CHARACTER(LEN=28),SAVE :: CFILEDIA
+!
+! Listing associe au traitement diachronique
+!
+CHARACTER(LEN=16),SAVE :: CLUOUTDIA='OUT_DIA'
+!
+! Numero logique du listing et parametres d'ouverture du fichier
+!
+INTEGER,SAVE :: NLUOUTDIA, NNPRARDIA, NFTYPEDIA=2, NVERBDIA, &
+ NNINARDIA, NRESPDIA
+
+CHARACTER(LEN=28),SAVE :: CMY_NAME_DIA
+CHARACTER(LEN=28),SAVE :: CDAD_NAME_DIA
+
+!
+END MODULE MODD_DIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_dimgrid_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_dimgrid_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..86054c4ea18d7bd1d468babf1652bcf4f484a633
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_dimgrid_fordiachro.f90
@@ -0,0 +1,45 @@
+! ######spl
+ MODULE MODD_DIMGRID_FORDIACHRO
+! ###############################
+!
+!!**** *MODD_DIMGRID_FORDIACHRO* -
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 01/02/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+INTEGER,SAVE :: NNB, NNBF
+
+INTEGER,DIMENSION(:,:), ALLOCATABLE,SAVE :: NNUMT, NSIZT, NLENC
+
+CHARACTER*16,DIMENSION(:,:), ALLOCATABLE,SAVE :: CRECFM2T
+!
+!
+END MODULE MODD_DIMGRID_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_emul.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_emul.f90
new file mode 100644
index 0000000000000000000000000000000000000000..802dec0d1f3375f18faee4a32c49f11dcc0cbf14
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_emul.f90
@@ -0,0 +1,12 @@
+! ######spl
+ MODULE MODD_EMUL
+! ################
+!
+!
+LOGICAL :: LEMULPART3D=.FALSE.
+LOGICAL :: LEMUL1D=.FALSE.
+LOGICAL :: LEMUL1=.FALSE.
+LOGICAL :: LPROCP1=.FALSE.
+LOGICAL :: LMASK=.FALSE.
+
+END MODULE MODD_EMUL
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_experim.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_experim.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5e60dbad7ec7f77ce6af411cdb87c254cf7961b1
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_experim.f90
@@ -0,0 +1,44 @@
+! ######spl
+ MODULE MODD_EXPERIM
+! ####################
+!
+!!**** *MODD_EXPERIM* -
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 10/11/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+! Cas SSOL . Altitudes des niveaux traites
+REAL,DIMENSION(:), ALLOCATABLE,SAVE :: XZSOL
+
+!
+!
+END MODULE MODD_EXPERIM
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_expr.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_expr.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1759cd976abda7adb66e0195a3406d6a21528e54
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_expr.f90
@@ -0,0 +1,52 @@
+! ######spl
+ MODULE MODD_EXPR
+! #############################
+!
+!!**** *MODD_EXPR* -
+!!
+!! PURPOSE
+!! -------
+! Declaration des variables et tableaux intervenant dans la
+! multiplication (ou division) d'un processus par un autre
+! processus
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 02/07/01
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+INTEGER,SAVE :: NMD
+
+REAL,DIMENSION(:,:,:,:,:,:), ALLOCATABLE,SAVE :: XEXPR1,XEXPR2,XEXPR3,&
+XEXPR4,XEXPR5,XEXPR6,XEXPR7,XEXPR8,XEXPR9
+REAL,DIMENSION(:,:,:,:,:,:), ALLOCATABLE,SAVE :: XDEXPR1,XDEXPR2,XDEXPR3,&
+XDEXPR4,XDEXPR5,XDEXPR6,XDEXPR7,XDEXPR8,XDEXPR9
+INTEGER,DIMENSION(100), SAVE :: NMULTDIV
+CHARACTER(LEN=6),DIMENSION(50),SAVE :: CMULTDIV
+
+!
+END MODULE MODD_EXPR
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_field1_cv2d.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_field1_cv2d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2997a75f2f024a797f17b5cea84ef85b8e6c3c2d
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_field1_cv2d.f90
@@ -0,0 +1,91 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_field1_cv2d.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! #######################
+ MODULE MODD_FIELD1_CV2D
+! #######################
+!
+!!**** *MODD_FIELD1_CV2D* - declaration of arrays for prognostic variables
+! in case of vertical sections
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to specify the
+! arrays holding prognostic variables in vertical planes
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book2 of the TRACE volume of the Meso-NH user manual
+!! (MODD_FIELD1_CV2D), to appear in 1994
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/05/94
+!! Updated PM 17/11/94
+!! (Stein) 08/03/95 Change the historical variables
+!! (Stein) 25/07/97 AChange the pressure variables
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XUMCV,XVMCV,XWMCV ! U,V,W at time t-dt
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XUTCV,XVTCV,XWTCV ! U,V,W at time t
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XRUSCV,XRVSCV,XRWSCV ! Source of
+ ! (rho U), (rho V), (rho W)
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XTHMCV ! theta at time t-dt
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XTHTCV ! theta at time t
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XRTHSCV ! Source of (rho theta)
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XTKEMCV ! Kinetic energy at time t-dt
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XTKETCV ! Kinetic energy at time t
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XRTKESCV ! Source of kinetic energy
+ ! (rho e)
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XPABSMCV ! Pressure variable
+ ! at time t-dt
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XPABSTCV ! Pressure variable
+ ! at time t
+REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE :: XRMCV ! Moist variables
+ ! at time t-dt
+REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE :: XRTCV ! Moist variables
+ ! at time t
+REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE :: XRRSCV ! Source of Moist variables
+ ! (rho Rn)
+REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE :: XSVMCV ! Additionnal scalar
+ ! variables at time t-deltat
+REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE :: XSVTCV ! Additionnal scalar
+ ! variables at time t
+REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE :: XRSVSCV ! Source of Additionnal scal.
+ ! variables (rho Sn.)
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XULMCV
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XULTCV
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XVTMCV
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XVTTCV
+
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XWORKCV
+
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XLSUMCV ! Larger scale fields at
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XLSVMCV ! time t-deltat for
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XLSWMCV ! U,V,W,TH and Rv
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XLSTHMCV
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XLSRVMCV
+
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XULMWMUCV ! U component for UW
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XULTWTUCV ! vectors plot
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XULMWMWCV ! W component for UW
+REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: XULTWTWCV ! vectors plot
+!
+END MODULE MODD_FIELD1_CV2D
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_files_diachro.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_files_diachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..eb721106298a7a212492b7c3c0b5359d9639be65
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_files_diachro.f90
@@ -0,0 +1,82 @@
+! ######spl
+ MODULE MODD_FILES_DIACHRO
+! ##########################
+!
+!!**** *MODD_FILES_DIACHRO* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original JD 08/01/96
+!! updated PM
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+!
+INTEGER,SAVE :: NBGUIL
+INTEGER,DIMENSION(180),SAVE :: NMGUIL
+
+!
+! Nb fichiers ouverts
+!
+INTEGER,SAVE :: NBFILES=0
+! Numero x de _filex_ du fichier courant
+INTEGER,SAVE :: NUMFILECUR
+! Memorisation du fichier courant dans le cas de diffrerence de 2 champs
+INTEGER,SAVE :: NUMFILECUR2
+! cf JPNXFM (modd_fmdeclar)= limite Fortran (99=JPNXLU) -10
+INTEGER,DIMENSION(90),SAVE :: NUMFILES
+
+!
+! Indication traitement un seul fichier ou plusieurs fichiers simultanement
+!
+LOGICAL :: LFIC1=.TRUE.
+!
+! Plusieurs fichiers simultanes
+!
+INTEGER,SAVE :: NBSIMULT
+INTEGER,DIMENSION(90),SAVE :: NUMFILESIMULT
+INTEGER,DIMENSION(90),SAVE :: NINDFILESIMULT
+
+
+! Nom fichiers diachroniques
+!
+CHARACTER(LEN=28),DIMENSION(90),SAVE :: CFILEDIAS
+!
+! Listings associes au traitement diachronique
+!
+CHARACTER(LEN=16),DIMENSION(90),SAVE :: CLUOUTDIAS='OUT_DIA'
+!
+! Numeros logiques des listings et parametres d'ouverture des fichiers
+!
+INTEGER,DIMENSION(90),SAVE :: NLUOUTDIAS, NNPRARDIAS, NFTYPEDIAS=2, NVERBDIAS, &
+ NNINARDIAS, NRESPDIAS
+
+!
+END MODULE MODD_FILES_DIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_hach.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_hach.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4eb5be369024c73c26661b47f4d03e726df29c7f
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_hach.f90
@@ -0,0 +1,50 @@
+! ######spl
+ MODULE MODD_HACH
+! #################
+!
+!!**** *MODD_HACH* -
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 10/11/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+! Surfaces en hachures
+LOGICAL :: LHACH1=.FALSE., LHACH2=.FALSE., LHACH3=.FALSE., LHACH4=.FALSE., LHACHSEL=.FALSE.
+! Surfaces en grises
+LOGICAL :: LGREY=.FALSE.
+! Label sur la 1ere isoligne
+LOGICAL :: LABEL1=.TRUE.
+LOGICAL :: LBLUSER1=.FALSE., LBLUSER2=.FALSE., LBLUSER3=.FALSE., LBLUSER4=.FALSE.
+INTEGER,SAVE :: NLBL1, NLBL2, NLBL3, NLBL4
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: XLBLUSER1,XLBLUSER2,XLBLUSER3,XLBLUSER4
+!
+!
+END MODULE MODD_HACH
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_mask3d.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_mask3d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..58c66e9259aabf638e98bae8c5277b273412c833
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_mask3d.f90
@@ -0,0 +1,53 @@
+! ######spl
+ MODULE MODD_MASK3D
+! ####################
+!
+!!**** *MODD_MASK3D* -
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 10/11/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+CHARACTER(LEN=16),SAVE :: CGROUPSV3
+LOGICAL,SAVE :: LXYZ=.FALSE., LMASK3D=.FALSE., LMSKTOP=.FALSE.
+LOGICAL,SAVE :: LSV3=.FALSE., LMARKER=.FALSE.
+LOGICAL,SAVE :: LXYZ00=.FALSE.
+LOGICAL,SAVE :: LMASK3D_XY=.FALSE.,LMASK3D_XZ=.FALSE.,LMASK3D_YZ=.FALSE.
+LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: LXYZT
+!
+! Masque 3D
+LOGICAL,DIMENSION(:,:,:,:),ALLOCATABLE,SAVE :: LMASK3
+!
+! limites fournies par l'utilisateur (x,y conformes z altitudes) pour
+! definir un masque
+REAL,SAVE :: XXL=0.,XXH=0.,XYL=0.,XYH=0.,XZL=0.,XZH=0.
+!
+END MODULE MODD_MASK3D
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_memcv.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_memcv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..01d135b8316f790d7618eea4f481dd45620c1610
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_memcv.f90
@@ -0,0 +1,67 @@
+! ######spl
+ MODULE MODD_MEMCV
+! ####################
+!
+!!**** *MODD_MEMCV* -
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 10/11/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+!
+! Info. pour superposer en INTERACTIF (LSTI=T)
+! 1 symbole (LSYMB=T)
+! 1 texte (LTEXTG=T) sur le graphique (LTEXTIT=T) hors du graphique
+! LSYMBTEXTG=T 1 symbole + 1 texte sur le graphique
+LOGICAL,SAVE :: LSYMB=.FALSE., LTEXTG=.FALSE., LTEXTIT=.FALSE., &
+ LSYMBTEXTG=.FALSE., LSTI=.FALSE.
+!
+! Info. pour tracer la trace d'une CV (et PH) dans un plan horizontal
+LOGICAL,SAVE :: LTRACECV=.FALSE.
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XTRACECV, XYTRACECV
+REAL,SAVE :: XLWTRACECV=3.
+INTEGER,SAVE :: NTRACECV
+!
+! Memorisation de la directive courante
+CHARACTER(LEN=2400) :: CDIRCUR, CDIRPREC ! LEN=LEN(CAR240) de diaprog.f90
+!
+! Longueur en fraction axe X de la fleche de l'echelle (<-> 20m/s ou a XVHCPH
+! s'il est =/= de 20 = PHA/4 = IPHAS4 dans echelle.f90 .Peut etre module dans
+! echelleph.f90)
+! dans le cas d'un PH vecteurs (LCH+LCV+LUMVM+LTRACECV)
+!
+REAL,SAVE :: XVRLPH=-1.
+REAL,SAVE :: XVHCPH=20.
+!
+! Logique d'eventuelle elimination de la legende des fleches en CH+CV
+! (Defaut : T)
+LOGICAL,SAVE :: LEGVECT=.TRUE.
+END MODULE MODD_MEMCV
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_memgriuv.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_memgriuv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2547de0d9f6fd9d8562bfa2173f5444c32fdd394
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_memgriuv.f90
@@ -0,0 +1,43 @@
+! ######spl
+ MODULE MODD_MEMGRIUV
+! #############################
+!
+!!**** *MODD_MEMGRIUV* -
+!!
+!! PURPOSE
+!! -------
+! Memorisation du numero de grille de U et V ds read_uvw
+! pour test dans precou pour faire ou non l'interpolation
+! sur la grille de masse
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 28/11/01
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+INTEGER,SAVE :: NGRIU=2 , NGRIV=3
+
+END MODULE MODD_MEMGRIUV
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_nmgrid.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_nmgrid.f90
new file mode 100644
index 0000000000000000000000000000000000000000..43a51b91807ce0e31b464a1bbfe85fb4de652092
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_nmgrid.f90
@@ -0,0 +1,58 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_nmgrid.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ##################
+ MODULE MODD_NMGRID
+! ##################
+!
+!!**** *MODD_NMGRID* - Global variable NMGRID declaration
+!!
+!! PURPOSE
+!! -------
+!! This declarative module defines the NMGRID global variable, which
+!! stores the value of the grid indicator for the current displayed field
+!! (local alias IGRID or KGRID). The grid indicator is the number of the
+!! grid where the displayed variable is located in the MESO-NH model. Seven
+!! different grids are used, so far. See Book-1 for grid definitions.
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book2 of the TRACE volume of the Meso-NH user manual
+!! (MODD_FIELD1_CV2D), to appear in 1994
+!!
+!! The 7 MESO-NH grid types are defined in:
+!!
+!! - Asencio N. et al., 1994, "Le projet de modele non-hydrostatique
+!! commun CNRM-LA, specifications techniques",
+!! Note CNRM/GMME, 26, 139p, (pages 39 to 43).
+!!
+!! - Fischer C., 1994, "File structure and content in the Meso-NH
+!! model", Meso-nh internal note, CNRM/GMME, July 5.
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/06/94
+!! Updated PM 17/11/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+IMPLICIT NONE
+!
+INTEGER :: NMGRID ! Current MESO-NH grid indicator
+!
+END MODULE MODD_NMGRID
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_out.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_out.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9085b455317f4f1a823ca2dd93ba6a9998a9fb8c
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_out.f90
@@ -0,0 +1,81 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_out.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! #################
+ MODULE MODD_OUT
+! #################
+!
+!!**** *MODD_OUT* - defines a logical unit number for printed outputs
+!!
+!! PURPOSE
+!! -------
+! So far, this declarative module is a garbage box containing items
+! fitting nothing else...
+! Content:
+! - logical unit number for the printed output,
+! - size of the matrix section to be displayed in the MESO-NH
+! field arrays,
+! - indexes to locate the displayed MESO-NH column in the
+! the "radio-sounding" mode,
+! - filename prefix of the LFI file to be displayed.
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book2 of the TRACE volume of the Meso-NH user manual
+!! (MODD_FIELD1_CV2D), to appear in 1994
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 02/06/94
+!! updated PM 21/11/94
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+INTEGER :: NLUOUT ! Logical unit number for
+ ! printed outputs
+
+INTEGER :: NIMAXT, NJMAXT, NKMAXT ! Size of the displayed
+ ! section of the MESO-NH
+ ! field arrays
+INTEGER :: NNAMRS ! =0 --> RS
+ ! =1 =/= RS
+
+INTEGER :: NIRS, NJRS ! Grid indexes to locate
+ ! a "radiosounding" point
+
+INTEGER :: NRRM ! Total number of water variables at time t
+INTEGER :: NRRT ! Total number of water variables at time t
+
+CHARACTER(LEN=20) :: CNAMRS ! Contains 'RS' in case of RS
+ ! something else in
+ ! the others cases
+CHARACTER(LEN=32) :: CLFIFM, CDESFM ! Full names of the ".lfi"
+ ! and ".des" files to be
+ ! processed
+
+CHARACTER(LEN=28) :: CNAMFILE ! Filename prefix of the files
+ ! to be processed
+!
+END MODULE MODD_OUT
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_out_dia.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_out_dia.f90
new file mode 100644
index 0000000000000000000000000000000000000000..03be4ceae9cc85bf788da0217ba7aaa89fcaebc1
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_out_dia.f90
@@ -0,0 +1,65 @@
+! ######spl
+ MODULE MODD_OUT_DIA
+! ####################
+!
+!!**** *MODD_OUT_DIA* - defines a logical unit number for printed outputs
+!!
+!! PURPOSE
+!! -------
+! So far, this declarative module is a garbage box containing items
+! fitting nothing else...
+! Content:
+! - logical unit number for the printed output,
+! - size of the matrix section to be displayed in the MESO-NH
+! field arrays,
+! - indexes to locate the displayed MESO-NH column in the
+! the "radio-sounding" mode,
+! - filename prefix of the LFI file to be displayed.
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book2 of the TRACE volume of the Meso-NH user manual
+!! (MODD_FIELD1_CV2D), to appear in 1994
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 01/02/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+INTEGER :: NLUOUTD ! Logical unit number for
+!INTEGER,DIMENSION(50) :: NLUOUTD ! Logical unit number for
+ ! printed outputs
+
+
+CHARACTER(LEN=16) :: CLUOUTD ! Names for printed outputs
+!CHARACTER(LEN=16),DIMENSION(50) :: CLUOUTD ! Names for printed outputs
+
+CHARACTER(LEN=32),DIMENSION(100) :: CLFIFMD ! Full names of the ".lfi"
+CHARACTER(LEN=32),DIMENSION(100) :: CDESFMD ! and ".des" files to be
+ ! processed
+
+CHARACTER(LEN=28),DIMENSION(100) :: CNAMFILED ! Filename prefix of the files
+ ! to be processed
+!
+END MODULE MODD_OUT_DIA
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_pt_for_ch_fordiachro.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_pt_for_ch_fordiachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..5819d1958a3f38cc39e68a6288c57b64cbd9dd3a
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_pt_for_ch_fordiachro.f90
@@ -0,0 +1,63 @@
+! ######spl
+ MODULE MODD_PT_FOR_CH_FORDIACHRO
+! ################################
+!
+!!**** *MODD_PT_FOR_CH_FORDIACHRO* - Global variables NMT declaration
+!! XPRES "
+!! XPHI "
+!! XTH "
+!!
+!! PURPOSE
+!! -------
+!! This declarative module defines the NMT global variable, which
+!! takes the value 1 for variables at t-dt time and 2 for variables
+!! at t time
+!! XPRES contains the pressure value computed either at t-dt or t
+!! times for constant pressure sections processing and RS.
+!! XTH contains either XTHM or XTHT
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/07/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+IMPLICIT NONE
+!
+INTEGER :: NMT
+INTEGER :: NLOOPT
+
+REAL,DIMENSION(:,:,:,:,:,:),ALLOCATABLE,SAVE :: XPRES, XPHI, XTH
+LOGICAL :: LTHSTAB=.TRUE. ! flag to write possibly 'UNSTABLE THETA' message
+! Ajout pour RS
+! 'CART'
+REAL,DIMENSION(:,:,:,:,:,:),ALLOCATABLE,SAVE :: XU, XV, XRVJD
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XTIMRS
+! 'CART' + 'RSPL'
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XTRS, XPRS, XURS, XVRS, XRVRS
+! 'RSPL'
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XTIMRS2
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: NST, NNST
+!
+! Ajout pour la composante W (Cas CV ULMWM et ULTWT)
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XWCV
+!
+! Septembre 2000 Pour =/= UMVM ou MUMVM ....
+REAL,DIMENSION(:,:,:,:,:,:),ALLOCATABLE,SAVE :: XUMEM, XVMEM
+!
+END MODULE MODD_PT_FOR_CH_FORDIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_pvt.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_pvt.f90
new file mode 100644
index 0000000000000000000000000000000000000000..380d56a68de18224d30148d0da3b95c8e7a785db
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_pvt.f90
@@ -0,0 +1,73 @@
+! ######spl
+ MODULE MODD_PVT
+! #############################
+!
+!!**** *MODD_PVT* - Contient les parametres de gestion de la couleur
+!! des fleches du vent horizontal UV (couleur induite par 1 3eme
+!! parametre) dans le seul cas a ce jour (22/3/2000) d'un PV
+!! enregistre dans un fic. diachronique de type 'CART'
+!! Le gpe contient U, V et d'autres parametres
+!! U et V doivent avoir ete enr. sur la grille 1
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 01/02/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+! Cas _UMVM_ et _PVT_ (L1DT=T)
+! Tableau avec les indices de couleur mis a jour ds OPER et utilise ds
+! VVUMXY
+INTEGER,DIMENSION(:,:), ALLOCATABLE,SAVE :: NCOL2DUV
+!
+! Logique mis a T par pg si _UMVM_ et _PVT_ et 3 processus fournis
+LOGICAL,SAVE :: LCOLPVT=.FALSE.
+
+INTEGER,DIMENSION(7),SAVE :: NCOLUVSTD=(/15,4,5,7,3,2,10/)
+INTEGER,SAVE :: NBCOLUVSTD=7, NBCOLUV
+INTEGER,SAVE :: NBPARCOLUVSTD=6, NBPARCOLUV
+
+REAL,DIMENSION(6), SAVE :: XPARCOLUVSTD
+
+! User
+INTEGER,DIMENSION(50),SAVE :: NINDCOLUV
+REAL,DIMENSION(50), SAVE :: XPARCOLUV
+
+LOGICAL,SAVE :: LCOLUSERUV=.FALSE.
+INTEGER,SAVE :: NISKIPVX=1, NISKIPVY=1
+
+! Septembre 2000 (Pour commodite)
+! Ajout pour les couleurs de fleches de imagev et imcouv
+INTEGER,SAVE :: NCOLUVG=1, NCOLUV1=1, NCOLUV2=1, NCOLUV3=1, NCOLUV4=1,NCOLUV5=1
+!
+! Octobre 2000 (Pour Jerome -> coordonnee verticale=pression pour _PVT_)
+LOGICAL,SAVE :: LPRESY=.FALSE., LPRESYT=.FALSE.
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XPRESM
+REAL,SAVE :: XPMIN=0.,XPMAX=0.,XPINT=0.
+!
+END MODULE MODD_PVT
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_radar.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_radar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4034231e79725a9051a13c896a8671a76187f73c
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_radar.f90
@@ -0,0 +1,51 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_title.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! #################
+ MODULE MODD_RADAR
+! #################
+!
+!!**** *MODD_RADAR* - Declare des variables concernant un (ou plusieurs)
+!! radars
+!!
+!! PURPOSE
+!! -------
+! Definit des variables pour localiser 1 ou +sieurs radars et
+! materialiser leur portee par un ou +esiurs cercles concentriques
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 23/04/2003
+!! Updated
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+IMPLICIT NONE
+!
+LOGICAL :: LRADAR=.FALSE., LRADIST=.FALSE., LRADRAY=.FALSE.
+REAL :: XLATRAD1=0., XLONRAD1=0.
+REAL :: XLATRAD2=0., XLONRAD2=0.
+REAL :: XLATRAD3=0., XLONRAD3=0.
+REAL :: XLATRAD4=0., XLONRAD4=0.
+REAL,DIMENSION(6) :: XPORTRAD1,XPORTRAD2,XPORTRAD3,XPORTRAD4
+REAL,DIMENSION(6) :: XLWRAD1=2.,XLWRAD2=2.,XLWRAD3=2.,XLWRAD4=2.
+INTEGER :: NPORTRAD1, NPORTRAD2, NPORTRAD3, NPORTRAD4
+INTEGER :: NLWRAD1, NLWRAD2, NLWRAD3, NLWRAD4
+CHARACTER(LEN=1) :: CSYMRAD1='+',CSYMRAD2='+',CSYMRAD3='+',CSYMRAD4='+'
+END MODULE MODD_RADAR
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_rea_lfi.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_rea_lfi.f90
new file mode 100644
index 0000000000000000000000000000000000000000..52d0807a7a0c95c321c2fb5f541f8396f77f65c7
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_rea_lfi.f90
@@ -0,0 +1,62 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_rea_lfi.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODD_REA_LFI
+! ###################
+!
+!!**** *MODD_REA_LFI* - Defines a LFIFM file record
+!!
+!! PURPOSE
+!! -------
+! This declarative module globally defines the set of variables
+! controlling the recors of the LFIFM file.
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! - Fischer C., 1994, "File structure and content in the Meso-NH
+!! model", Meso-nh internal note, CNRM/GMME, July 5.
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/06/94
+!! Updated PM 22/11/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+IMPLICIT NONE
+!
+INTEGER :: NRESP,NMELEV ! NRESP : return-code if a problem appears
+ ! opening the file
+ ! NMELEV : level of message printing in
+ ! LFI routines
+INTEGER :: NNPRAR,NFTYPE ! NNPRAR : number of predicted articles
+ ! NFTYPE : type of FM-file for FMCLOS
+INTEGER :: NNINAR ! number of articles initially present in
+ ! the file
+INTEGER :: NGRID,NLENG ! NGRID : grid indicator
+ ! NLENG : length of the data field
+INTEGER :: NLENCH ! NLENCH : length of comment string
+!
+CHARACTER(LEN=3) :: CSTATU ! Status of the file before the open
+CHARACTER(LEN=16) :: CRECFM ! Name of the article to be written
+CHARACTER(LEN=100):: CCOMMENT ! Comment string
+!
+LOGICAL :: LFATER,LSTATS ! LFATER : true if LFI-file manipulation
+ ! error is a fatal error
+ ! LSTATS : true if statistics of file
+ ! manipulation sould be printed
+END MODULE MODD_REA_LFI
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_resolvcar.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_resolvcar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..91954ea373030c934d3983dda9edc91f5ad86d0f
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_resolvcar.f90
@@ -0,0 +1,588 @@
+! ######spl
+ MODULE MODD_RESOLVCAR
+! ######################
+!
+!!**** *MODD_RESOLVCAR* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 24/11/95
+!! updated PM 21/11/94
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+!
+! Unite logique fichier de directives
+!
+INTEGER :: NDIR
+
+!
+! NLOOPN = JLOOPN OPER memorise pour SSOL + DRST + RAPL + RSPL
+!
+INTEGER :: NLOOPN
+
+!
+! NLOOPP = JLOOPP OPER memorise pour CART
+!
+INTEGER :: NLOOPP
+
+!
+! NLOOPK = JLOOPK OPER memorise pour CART et LANIMK
+! XLOOPZ = JLOOPZ " pour les niveaux =/= niv.modele
+!
+INTEGER :: NLOOPK
+REAL,SAVE :: XLOOPZ
+
+!
+! Logiques de gestion des differents types d'operations
+!
+LOGICAL :: LCH, LCV, LPV, LPH, LPVT, LCN, LFT, LFT1, LPVKT, L1K
+LOGICAL :: LTK, LPR, LPVKT1, LZT, LXT, LYT, LXYDIA, LZTPVKT1
+LOGICAL :: LXYWINCUR=.FALSE.
+LOGICAL :: LPXT, LPYT
+LOGICAL :: LEV ! Potential vorticity
+LOGICAL :: LMINUS, LPLUS
+LOGICAL :: LANIMK, LANIMT
+LOGICAL :: LCNCUM, LCNSUM, LCHXY, LCVXZ, LCVYZ, LRS, LRS1
+LOGICAL :: L1DT
+LOGICAL :: LPRINT=.FALSE., LPRINTXY=.FALSE.
+! Ecriture des dates dans le fichier FICVAL . Associe a XPRDAT
+LOGICAL :: LPRDAT=.FALSE.
+LOGICAL :: LPOINTG=.FALSE.
+LOGICAL :: L2DBX=.FALSE., L2DBY=.FALSE.
+LOGICAL :: LXYO=.FALSE.
+LOGICAL,SAVE :: LMNMXLOC=.FALSE.
+LOGICAL :: LXABSC=.FALSE. ! Cas V(x,t) --> X en abscisse ou non
+LOGICAL :: LXMINTOP=.FALSE. ! Cas V(x,t) --> Min X en ordonnee en haut
+ ! ou non
+! Streamlines
+LOGICAL,SAVE :: LSTREAM=.FALSE.
+LOGICAL,SAVE :: LINTERPOLSTR=.FALSE.
+INTEGER,SAVE :: NZSTR=80, NARSTR=4
+INTEGER,SAVE :: NSGD, NSEUIL
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XZSTR
+REAl,SAVE :: XLWSTR=1., XARLSTR=.009, XSSP=.004
+
+! Logique presence ou non des labels sur les axes .T. -> absence .F.presence
+LOGICAL :: LNOLABELX=.FALSE.
+LOGICAL :: LNOLABELY=.FALSE.
+!
+! logiques de gestion des combinaisons des composantes du vent
+!
+LOGICAL :: LUMVM, LUTVT, LMUMVM, LMUTVT
+LOGICAL :: LULM, LULT, LVTM, LVTT, LULMWM, LULTWT
+LOGICAL :: LSUMVM, LSUTVT, LMLSUMVM, LMLSUTVT
+! Representation anterieure de ULM et VTM
+LOGICAL,SAVE :: LULMVTMOLD=.FALSE.
+! CH orientation pour calcul ULM et VTM
+REAl,SAVE :: XANGULVT
+! CH direction du vent
+LOGICAL,SAVE :: LDIRWIND, LDIRWM, LDIRWT
+! Cas LDIRWIND _PVT_ Memorisation des temps
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XTDIRWIND
+! Logique de gestion des statistiques des vecteurs vents
+LOGICAL,SAVE :: LVST=.FALSE.
+! Logique pour supprimer la dilatation de la la composante W ds
+! representation ULMWM ou ULTWT
+LOGICAL,SAVE :: LDILW=.TRUE.
+! Logique pour conserver les valeurs > XVHC ds le cas ou XVHC est <0
+! c.a.d ou = scale
+LOGICAL,SAVE :: LVSUPSCA=.FALSE.
+!
+! logique de gestion des couleurs en cas de zoom en CV
+! =F -> iso +couleurs zoom ident. au graphique integral
+! =T -> " " fction du min et du max du zoom
+!
+LOGICAL,SAVE :: LCVZOOM=.FALSE.
+!
+! logique de gestion des couleurs a 0 (background)
+!
+LOGICAL :: LCOLZERO=.FALSE.
+!
+! rang de l'index de couleur a mettre a 0
+!
+INTEGER :: NCOLZERO
+!
+! RS
+!
+INTEGER :: NIRS, NJRS
+REAL :: XIRS, XJRS, XIRSCC, XJRSCC
+LOGICAL :: LNOUVRS=.FALSE.
+!
+! Ajout (ou - ou * ) constante entre ()
+!
+CHARACTER(LEN=20),DIMENSION(100) :: CFACT=' ' !(Nom gpe + fact * ou + ou -)
+REAL,DIMENSION(100) :: XCONSTANTE=0.
+INTEGER,DIMENSION(100) :: NOPE(100)
+INTEGER :: NPARG=0, NPARD=0 ! Parentheses Gauche et dte
+INTEGER :: NOPEL=0 ! Compteur fact * ou + ou -
+LOGICAL :: LFACTIMP=.TRUE. ! Impression fact * ou + ou -
+!
+! Superpositions
+!
+INTEGER :: NLOOPSUPER ! Indice de boucle des superpositions dans pg pal
+LOGICAL :: LSUPERDIA
+INTEGER :: NSUPERDIA
+! Fev 2001
+CHARACTER(LEN=600),DIMENSION(100) :: CARSUP
+!CHARACTER(LEN=240),DIMENSION(50) :: CARSUP
+INTEGER,DIMENSION(100) :: NFILESCUR
+!
+! Cas superpositions CV 3D + PH 2D Hor. (Oct 2000)
+! D'une maniere generale superp. coupes =/=
+! Conventions actuelles . 1 pour 1 CV 1+2=3 pour CV+K=PH
+!
+INTEGER,DIMENSION(100),SAVE :: NHISTORY=0
+REAL, SAVE :: XLWPH1=2,XLWPH2=2,XLWPH3=2,XLWPH4=2,XLWPH5=2,XLWPH6=2
+REAL, SAVE :: XLWPH7=2,XLWPH8=2
+!
+! Temps
+!
+! Les 2 derniers indices = superpositions + n.traj ou station...
+! 23/04/03 dim. n augmentee de 20 a 45
+! 17/01/05 dim. n augmentee de 45 a 100
+LOGICAL,DIMENSION(100,100) :: LTIMEDIALL, LTINCRDIA
+
+INTEGER,DIMENSION(100,100) :: NBTIMEDIA
+
+INTEGER, DIMENSION(120,100,100) :: NTIMEDIA
+
+REAL, DIMENSION(120,100,100) :: XTIMEDIA
+!
+! Processus
+!
+! Dernier indice = superpositions
+LOGICAL,DIMENSION(100) :: LPROCDIALL, LPINCRDIA
+
+INTEGER,DIMENSION(100) :: NBPROCDIA
+
+INTEGER, DIMENSION(120,100) :: NPROCDIA
+!
+! Niveaux K
+!
+! Les 2 derniers indices = superpositions + n.traj ou station...
+! 10/10/07 dim. 1 augmentee de 120 a 160 (nb de niveaux K)
+LOGICAL,DIMENSION(100,100) :: LVLKDIALL, LKINCRDIA
+
+INTEGER,DIMENSION(100,100) :: NBLVLKDIA
+
+INTEGER, DIMENSION(160,100,100) :: NLVLKDIA
+!
+! Niveaux Z
+!
+LOGICAL,DIMENSION(100) :: LZINCRDIA
+
+INTEGER,DIMENSION(100) :: NBLVLZDIA
+
+INTEGER, DIMENSION(120,100) :: NLVLZDIA
+
+REAL, DIMENSION(120,100) :: XLVLZDIA
+!
+! Numeros masques ou trajectoires
+!
+LOGICAL,DIMENSION(100) :: LNDIALL, LNINCRDIA
+
+INTEGER,DIMENSION(100) :: NBNDIA
+
+INTEGER, DIMENSION(120,100) :: NNDIA
+!
+! Nom du groupe
+!
+CHARACTER(LEN=100) :: CTIMECS
+CHARACTER(LEN=16) :: CGROUP, CTIMEC
+CHARACTER(LEN=22) :: CUNITGAL
+CHARACTER(LEN=40) :: CTITGAL
+CHARACTER(LEN=16),DIMENSION(100) :: CGROUPS
+!
+! Intervalle des isocontours , extremes ou valeurs
+!
+REAL :: XDIAINT
+REAL :: XISOMIN, XISOMAX
+REAL,DIMENSION(300) :: XISOLEV
+REAL :: XISOREF
+!
+! Nb chiffres signicatifs pour les High and Low isocontours + cste(champ cst)
+!
+INTEGER,SAVE :: NSD=0
+CHARACTER(LEN=10),SAVE :: CFMTMNMX=' '
+!
+! Formats axe X et axe Y et possibilite de * par un facteur ou donner bornes
+!
+LOGICAL,SAVE :: LFMTAXEX=.FALSE., LFMTAXEY=.FALSE.
+CHARACTER(LEN=10),SAVE :: CFMTAXEX=' ', CFMTAXEY=' '
+! Taille des labels= NSZLBX/1024 et NSZLBY/1024
+INTEGER,SAVE :: NSZLBX=10, NSZLBY=10
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! 19/12/2008 : modification pour controler la taille et le format des labels !!
+!! pour les retrotrajectoires !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!
+! Formats labels pour retrotrajectoire (ctraj3d_group)
+!
+LOGICAL,SAVE :: LFMTRTRAJ=.FALSE.
+CHARACTER(LEN=10),SAVE :: CFMTRTRAJ='(E10.5)'
+REAL,SAVE :: NSZRTRAJ=10.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Mars 2001
+LOGICAL,SAVE :: LFACTAXEX=.FALSE., LFACTAXEY=.FALSE.
+LOGICAL,SAVE :: LAXEXUSER=.FALSE., LAXEYUSER=.FALSE.
+REAL, SAVE :: XFACTAXEX=1., XFACTAXEY=1.
+REAL, SAVE :: XAXEXUSERD=1., XAXEXUSERF=1.
+REAL, SAVE :: XAXEYUSERD=1., XAXEYUSERF=1.
+!
+! Profil vertical: indice en X dans la CV (NLMAX,IKU)
+!
+INTEGER :: NPROFILE
+!
+! PV Bornes en X
+REAL :: XPVMINTRUE, XPVMAXTRUE ! Fournies par l'utilisateur
+REAL :: XPVMINT, XPVMAXT ! Fournies par l'utilisateur (Bornes ident.
+!
+! PV Epaisseur traits des =/= profils et figures
+REAL,save :: XLWPV1=0., XLWPV2=0., XLWPV3=0., XLWPV4=0.
+REAL,save :: XLWPV5=0., XLWPV6=0., XLWPV7=0., XLWPV8=0.
+!*JD*Mars2009 Pour les budgets
+REAL,save :: XLWPV9=0., XLWPV10=0., XLWPV11=0., XLWPV12=0.
+REAL,save :: XLWPV13=0., XLWPV14=0., XLWPV15=0.
+!*JD*Mars2009 Pour les budgets
+REAL,save :: XSTYLPV1=0., XSTYLPV2=0., XSTYLPV3=0., XSTYLPV4=0.
+REAL,save :: XSTYLPV5=0., XSTYLPV6=0., XSTYLPV7=0., XSTYLPV8=0.
+!*JD*Mars2009 Pour les budgets
+REAL,save :: XSTYLPV9=0., XSTYLPV10=0., XSTYLPV11=0., XSTYLPV12=0.
+REAL,save :: XSTYLPV13=0., XSTYLPV14=0., XSTYLPV15=0.
+!*JD*Mars2009 Pour les budgets
+! PV =/= entre parametre de GSLN pour 1 PV si > 4 (valeur max autorisee) et 1
+! pour assurer le passage de cette valeur entre trapro et pro1d
+INTEGER,save :: NGSLNP=0
+!
+!*JD*Mars2009 Gestion nom variables + position + taille
+!*JD*Mars2009
+LOGICAL,SAVE :: LVARNPVUSER=.FALSE.
+CHARACTER(LEN=22),SAVE :: CVARNPV1=' ',CVARNPV2=' ',CVARNPV3=' ',CVARNPV4=' '
+CHARACTER(LEN=22),SAVE :: CVARNPV5=' ',CVARNPV6=' ',CVARNPV7=' ',CVARNPV8=' '
+CHARACTER(LEN=22),SAVE :: CVARNPV9=' ',CVARNPV10=' ',CVARNPV11=' ',CVARNPV12=' '
+CHARACTER(LEN=22),SAVE :: CVARNPV13=' ',CVARNPV14=' ',CVARNPV15=' '
+REAL,save :: XSZVARNPVTOP=0.,XSZVARNPVBOT=0.
+REAL,save :: XPOSXVARNPV1TOP=0.,XPOSXVARNPV5BOT=0.
+REAL,save :: XPOSYVARNPV1TOP=0.,XPOSYVARNPV5BOT=0.
+!*JD*Mars2009 Ligne Zero sur PV
+LOGICAL,SAVE :: LINZEROPV=.FALSE.
+INTEGER,SAVE :: NSTYLINZEROPV=1
+!*JD*Mars2009
+LOGICAL,SAVE :: LCONVG2MASS
+!*JD*Mars2009
+LOGICAL,SAVE :: LVARNPHUSER=.FALSE.
+CHARACTER(LEN=22),SAVE :: CVARNPH1=' ',CVARNPH2=' ',CVARNPH3=' ',CVARNPH4=' '
+CHARACTER(LEN=22),SAVE :: CVARNPH5=' ',CVARNPH6=' ',CVARNPH7=' ',CVARNPH8=' '
+! pour plusieurs variables
+!
+! PVKT + FT Bornes en Y des processus
+REAL :: XPVMIN, XPVMAX ! Calculees par le programme
+!
+! Zones de recouvrement
+INTEGER,SAVE :: NBRECOUV
+INTEGER,DIMENSION(20),SAVE :: NRECOUV
+!Mai 2000
+! FT + PVKT + FT1 Epaisseur des traits de l'ensemble des traces
+! Presence de valeurs manquantes
+!
+REAL,SAVE :: XLWFTALL=2.
+REAL,SAVE :: XSPVALT
+LOGICAL,SAVE :: LSPVALT=.FALSE.
+!
+! FT + PVKT + FT1 Bornes des variables en X (Temps)
+LOGICAL,SAVE :: LTIMEUSER=.FALSE.
+LOGICAL,SAVE :: LFTCLIP=.TRUE. ! pour desactiver le clipping
+! cas LTIMEUSER=F et LMNMXUSER=F pour eviter la disparition de traits
+!aux bornes lors conversion en PS
+REAL,SAVE :: XTIMEMIN, XTIMEMAX
+!
+! FT + PVKT + FT1 Bornes des variables en Y, Noms des variables, Nb de variables
+REAL,SAVE :: XFTMIN, XFTMAX, XPVKTMIN, XPVKTMAX ! Fournies par l'utilisateur
+REAL,SAVE :: XFT1MIN, XFT1MAX ! Fournies par l'utilisateur cas +sieurs var.
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XFTMN, XFTMX
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: NCOLI
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: CFTMN, CFTMX, CCOLI
+INTEGER,SAVE :: NBFTMN=0, NBFTMX=0, NBCOLI=0
+INTEGER,SAVE :: NCOLIVAL
+LOGICAL,SAVE :: LMNMXUSER=.FALSE.
+LOGICAL,SAVE :: LCOLUSER=.FALSE.
+LOGICAL,SAVE :: LOK=.FALSE.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! FT1 Format courbes par USER (JD 240209) et nom variables representees
+! le tout controle par LFT1LUSER=T (et LCOLINE=T pour les entiers et reels)
+!
+LOGICAL,SAVE :: LFT1LUSER=.FALSE.
+INTEGER,SAVE :: NFT1COL1=0, NFT1COL2=0, NFT1COL3=0, NFT1COL4=0, NFT1COL5=0
+INTEGER,SAVE :: NFT1COL6=0, NFT1COL7=0, NFT1COL8=0, NFT1COL9=0, NFT1COL10=0
+INTEGER,SAVE :: NFT1COL11=0, NFT1COL12=0, NFT1COL13=0, NFT1COL14=0, NFT1COL15=0
+!
+REAL,SAVE :: XFT1LW1=2.,XFT1LW2=2.,XFT1LW3=2.,XFT1LW4=2.,XFT1LW5=2.
+REAL,SAVE :: XFT1LW6=2.,XFT1LW7=2.,XFT1LW8=2.,XFT1LW9=2.,XFT1LW10=2.
+REAL,SAVE :: XFT1LW11=2.,XFT1LW12=2.,XFT1LW13=2.,XFT1LW14=2.,XFT1LW15=2.
+!
+INTEGER,SAVE :: NFT1STY1=1,NFT1STY2=1,NFT1STY3=1,NFT1STY4=1,NFT1STY5=1
+INTEGER,SAVE :: NFT1STY6=1,NFT1STY7=1,NFT1STY8=1,NFT1STY9=1,NFT1STY10=1
+INTEGER,SAVE :: NFT1STY11=1,NFT1STY12=1,NFT1STY13=1,NFT1STY14=1,NFT1STY15=1
+!
+CHARACTER(LEN=10) :: CFT1TIT1=' ',CFT1TIT2=' ', &
+CFT1TIT3=' ',CFT1TIT4=' ',CFT1TIT5=' '
+CHARACTER(LEN=10) :: CFT1TIT6=' ',CFT1TIT7=' ', &
+CFT1TIT8=' ',CFT1TIT9=' ',CFT1TIT10=' '
+CHARACTER(LEN=10) :: CFT1TIT11=' ',CFT1TIT12=' ', &
+CFT1TIT13=' ',CFT1TIT14=' ',CFT1TIT15=' '
+!
+! FT1 gestion de la fenetre par l utilisateur
+!
+LOGICAL,SAVE :: LVPTFT1USER=.FALSE.
+REAL,SAVE :: XVPTFT1L,XVPTFT1R,XVPTFT1B,XVPTFT1T
+!
+! Pour supprimer les labels a droite du dessin cas FT1 (je ne sais pas pour FT)
+!
+LOGICAL,SAVE :: LBLFT1SUP=.FALSE.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! JD Avril 2009
+! Trace filaire 2D Suppression des noms de var. et leur figure en Top
+LOGICAL,SAVE :: LXYNVARTOP=.TRUE.
+LOGICAL,SAVE :: LXYSTYLTOP=.TRUE.
+LOGICAL,SAVE :: LPHCOLUSER=.FALSE.
+LOGICAL,SAVE :: LPHSTYUSER=.FALSE.
+INTEGER,SAVE :: NPHSTY1=1,NPHSTY2=1,NPHSTY3=1,NPHSTY4=1,NPHSTY5=1
+INTEGER,SAVE :: NPHSTY6=1,NPHSTY7=1,NPHSTY8=1
+INTEGER,SAVE :: NPHCOL1=1,NPHCOL2=1,NPHCOL3=1,NPHCOL4=1,NPHCOL5=1
+INTEGER,SAVE :: NPHCOL6=1,NPHCOL7=1,NPHCOL8=1
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Isocontours : cas NIMNMX=1
+!
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XISOMN, XISOMX, XISOINT
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: CISOMN, CISOMX, CISOINT
+INTEGER,SAVE :: NBISOMN, NBISOMX, NBISOINT
+LOGICAL :: LISOK=.FALSE.
+!
+! Isocontours : cas NIMNMX=2
+!
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XISOLEVP
+INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: NLENP
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: CISOLEVP
+INTEGER,SAVE :: NBISOLEVP
+LOGICAL :: LISOLEVP=.FALSE.
+!
+! Isocontours : cas NIMNMX=3
+!
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XISOREFP
+CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: CISOREF
+INTEGER,SAVE :: NBISOREF
+LOGICAL :: LISOREF=.FALSE.
+!
+! Isocontours : epaisseurs des traits en cas de superpositions ou non
+!
+REAL,save :: XLW1, XLW2, XLW3, XLW4
+! Epaisseur traits continents
+REAL,save :: XLWCONT=0.
+!
+! LXY=.TRUE. Bornes en Y
+REAL,SAVE :: XVARMIN=0., XVARMAX=0.
+!
+! LZT=.TRUE. Bornes en Y
+REAL,SAVE :: XZTMIN=0., XZTMAX=0.
+!
+! Sommes et differences
+!
+INTEGER :: NBPM ! Nb de sommes et differences et superpositions
+INTEGER :: NBPMT ! Nb de sommes et differences
+INTEGER,DIMENSION(99) :: NUMPM ! 1 --> + 2 --> - 0 --> rien
+!
+! Vents /= vent normal : suffixe
+!
+CHARACTER(LEN=2),SAVE :: CSUFWIND=' '
+INTEGER,SAVE :: NSUFWIND=0
+!
+LOGICAL :: LSYMBT
+INTEGER,SAVE :: NCOLSYMB, NTYPSYMB
+!
+! Spectres
+!
+LOGICAL,SAVE :: LINDSP=.FALSE.
+LOGICAL,SAVE :: LOGNEP=.TRUE.
+LOGICAL,SAVE :: LM5S3=.FALSE.
+LOGICAL,SAVE :: LSPMNMXUSER=.FALSE., LSPMNMXALLT=.FALSE.
+LOGICAL,SAVE :: LSPLO=.FALSE., LSPO=.FALSE., LOSPLO=.FALSE., LPHALO=.FALSE., LPHAO=.FALSE.
+LOGICAL,SAVE :: LSPSECT=.FALSE., LSPSECTXY=.FALSE., LSPSECTXZ=.FALSE., LSPSECTYZ=.FALSE.
+LOGICAL,SAVE :: LSPX=.FALSE., LSPY=.FALSE., LSPZ=.FALSE.
+REAL :: XOMEGAX, XOMEGAY, XOMEGAZ
+REAL,SAVE :: XSPMIN=0., XSPMAX=0.
+
+LOGICAL,SAVE :: LBID
+!
+! Table de couleurs N2
+!
+LOGICAL,SAVE :: LTABCOLDEF2=.FALSE.
+!
+! Trajectoires
+!
+LOGICAL,SAVE :: LCONV2XY=.FALSE., LCONT=.FALSE., LRELIEF=.FALSE.
+! L2CONT pour trace comme anterieurement des continents 2fois (Septembre 2000)
+LOGICAL,SAVE :: L2CONT=.FALSE.
+INTEGER,SAVE :: NLATLON
+!
+INTEGER,SAVE :: NVERBIA=0, NSSPG=0
+! LINVWB=.FALSE. (1,0,0.,0.,0.), (1,1,1.,1.,1.)
+! LINVWB=.TRUE. (1,1,0.,0.,0.), (1,0,1.,1.,1.)
+! Definition Noir et Blanc
+LOGICAL,SAVE :: LINVWB=.TRUE.
+!
+LOGICAL,SAVE :: LISOWHI2=.FALSE., LISOWHI3=.FALSE.
+!
+! Vecteurs vent (Les autres parametres de meme type sont ds MODN_NCAR)
+! = valeur en deca de laquelle les vecteurs ne st pas representes
+REAL,SAVE :: XVLC=0.
+!
+! Textes + symboles a ajouter a des plans horizontaux localises
+! a XLATCAR,XLONCAR (definis dans MODN_NCAR)
+!
+CHARACTER(LEN=20),DIMENSION(400) :: CNOMCAR=' '
+CHARACTER(LEN=1),DIMENSION(400) :: CSYMCAR='.'
+REAL,DIMENSION(400) :: XPOSNOM=90.
+REAL,DIMENSION(400) :: XSZNOM=.012
+REAL,DIMENSION(400) :: XSZSYM=.012
+INTEGER,DIMENSION(400) :: ICOLSYM=1
+INTEGER,DIMENSION(400) :: ICOLNOM=1
+INTEGER :: NOMCAR, NSYMCAR, NPOSNOM
+INTEGER :: NSZNOM, NSZSYM, NCOLSYM, NCOLNOM
+!
+! Tableau utilise ds imcoupv pour charger les composantes u et v (UMVM_PVT_)
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XTEM2D, XTEM2D2
+LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: LUMVMPVT
+LOGICAL,SAVE :: LUMVMPV=.FALSE.
+!
+! Logique de gestion d'interpolation a partir du haut ou du bas
+!
+LOGICAL,SAVE :: LINTERPTOP=.TRUE.
+! Logique precisant que l'on demande les niv. des CH en reel
+LOGICAL,SAVE :: LCHREEL=.FALSE.
+!
+! Profils horizontaux 07042000 pour trace UTVT ou UMVM pour recuperer
+! les coordonnees du debut des fleches
+!
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XTEMCVU, XTEMCVV
+! PH UTVT et UMVM pour expression des X en heures
+! Ajoute ds imcou pour _PVT_ et LHEURX=T en Mai 2000
+LOGICAL,SAVE :: LHEURX=.TRUE.
+LOGICAL,SAVE :: LMYHEURX=.FALSE.
+INTEGER,SAVE :: NHEURXLBL=2
+INTEGER,SAVE :: NHEURXGRAD=1
+! Avril 2009 ds imcou pour _PVT_
+! Possibilite mettre des temps exprimes sous forme hhHmm dont les bornes
+! sont fournies par utilisateur dans XAXUSERD= et XAXUSERF=(reels a 2 decimales)
+! avec LAXEXUSER=T LHEURX=T et LNOLABELX=T
+! Borne de fin toujours > borne debut mais si on veut une expression
+! des heures entre 0 et 24H , on met L24H=T
+LOGICAL,SAVE :: L24H=.FALSE.
+! Avril 2009 ds imcou pour _PVT_
+! Mai 2009 ds image + imcou
+LOGICAL,SAVE :: LNOLBLBAR=.FALSE.
+! Mai 2009 ds image + imcou
+! Avril 2002 lat,lon CV et PH
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XLATCV, XLONCV
+!
+! Limites du domaine fils sur le domaine pere.
+! Fournies en indices de grille du domaine pere
+!
+LOGICAL,SAVE :: LDOMAIN=.FALSE.
+INTEGER,SAVE :: NDOMAINL=1, NDOMAINR=1, NDOMAINB=1, NDOMAINT=1
+REAL,SAVE :: XLWDOMAIN=2.
+!
+! Trace segment de dte sur une coupe horizontale en proj. cart
+!
+LOGICAL,SAVE :: LSEGM=.FALSE.
+! Elements du tableau entiers mis a 1 si XSEGMx =/= 0
+INTEGER,DIMENSION(100),SAVE :: NSEGMS=0
+! nb couleurs lues
+INTEGER,SAVE :: NCOLSEGM=1
+! Numeros des couleurs
+INTEGER,DIMENSION(30),SAVE :: NCOLSEGMS=1
+! Couples lat,long extremites de segments de dte .
+! Si =0,0 discontinuite ds les segments (plume levee!!)
+!REAL,DIMENSION(2),SAVE :: XSEGM1=0.,XSEGM2=0.,XSEGM3=0.,XSEGM4=0.,XSEGM5=0.
+!REAL,DIMENSION(2),SAVE :: XSEGM6=0.,XSEGM7=0.,XSEGM8=0.,XSEGM9=0.,XSEGM10=0.
+!REAL,DIMENSION(2),SAVE :: XSEGM11=0., XSEGM12=0., XSEGM13=0., XSEGM14=0.
+REAL,DIMENSION(100,2),SAVE :: XCONFSEGMS=0., XSEGMS=0.
+REAL,SAVE :: XLWSEGM=2.
+!
+! Logique d'inversion des pointilles et tiretes pour les isocontours N/B
+!
+LOGICAL,SAVE :: LINVPTIR=.FALSE.
+! 15052000
+! Pour impression de la fenetre papier courante
+!
+REAL,SAVE :: XCURVPTL, XCURVPTR, XCURVPTB, XCURVPTT
+! Pour ecriture des dates dans le fichier FICVAL
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: XPRDAT
+!
+! Ajout constante de temps pour ch courbe FT PVKT PVKT1
+REAL,SAVE :: XFT_ADTIM1=0
+REAL,SAVE :: XFT_ADTIM2=0
+REAL,SAVE :: XFT_ADTIM3=0
+REAL,SAVE :: XFT_ADTIM4=0
+REAL,SAVE :: XFT_ADTIM5=0
+REAL,SAVE :: XFT_ADTIM6=0
+REAL,SAVE :: XFT_ADTIM7=0
+REAL,SAVE :: XFT_ADTIM8=0
+!
+! Ajout constante de temps pour ch courbe FT1
+REAL,SAVE :: XFT1_ADTIM1=0
+REAL,SAVE :: XFT1_ADTIM2=0
+REAL,SAVE :: XFT1_ADTIM3=0
+REAL,SAVE :: XFT1_ADTIM4=0
+REAL,SAVE :: XFT1_ADTIM5=0
+REAL,SAVE :: XFT1_ADTIM6=0
+REAL,SAVE :: XFT1_ADTIM7=0
+REAL,SAVE :: XFT1_ADTIM8=0
+!
+! FT PVKT 3 ou 4 courbes / 1 diagramme (meme parametre avec bornes fixees)
+LOGICAL,SAVE :: LFT3C=.FALSE., LFT4C=.FALSE.
+!
+! FT PVKT FT1 PVKT1 bornes calculees avec min et max effectifs
+!(pour evol. temp. ds varfct)
+LOGICAL,SAVE :: LFTBAUTO=.FALSE.
+LOGICAL,SAVE :: LFT1BAUTO=.FALSE.
+!
+!NOVEMBRE 2009 : ajout de l apossibilité de tourner les titres en Y
+LOGICAL,SAVE ::L90TITYT=.FALSE.
+LOGICAL,SAVE ::L90TITYM=.FALSE.
+LOGICAL,SAVE ::L90TITYB=.FALSE.
+LOGICAL,SAVE ::LPATCH=.FALSE.
+
+!
+END MODULE MODD_RESOLVCAR
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_rsisocol.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_rsisocol.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d9b6033684973db8b43b2abac21e3e1c12dc4daf
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_rsisocol.f90
@@ -0,0 +1,64 @@
+! ######spl
+ MODULE MODD_RSISOCOL
+! #############################
+!
+!!**** *MODD_RSISOCOL* - Contient les parametres de gestion de la couleur
+!! des RS et isocontours dans le cas ou on veut une seule couleur
+!! et en trait plein
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 01/02/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+! Cas _RS_ et _RS1_
+!
+LOGICAL, SAVE :: LCOLRSONE=.FALSE.
+INTEGER, SAVE :: NCOLRSONE=0
+LOGICAL, SAVE :: LCOLRS1ONE=.FALSE.
+INTEGER, SAVE :: NCOLRS1ONE1=0
+INTEGER, SAVE :: NCOLRS1ONE2=0
+INTEGER, SAVE :: NCOLRS1ONE3=0
+INTEGER, SAVE :: NCOLRS1ONE4=0
+INTEGER, SAVE :: NCOLRS1ONE5=0
+!
+! Pour recuperer les altitudes des RS sur la grille 1 pour les noter
+! sur les profils de vent
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: XALTRS
+!
+! Isocontours
+LOGICAL,SAVE :: LCOLISONE=.FALSE.
+!
+INTEGER,SAVE :: NCOLISONE1=0
+INTEGER,SAVE :: NCOLISONE2=0
+INTEGER,SAVE :: NCOLISONE3=0
+INTEGER,SAVE :: NCOLISONE4=0
+INTEGER,SAVE :: NCOLISONE5=0
+!
+END MODULE MODD_RSISOCOL
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_several_records.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_several_records.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a395db349bbe96e17fee103b05606de91c88fb57
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_several_records.f90
@@ -0,0 +1,46 @@
+! ######spl
+ MODULE MODD_SEVERAL_RECORDS
+! ############################
+!
+!!**** *MODD_SEVERAL_RECORDS* -
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 01/02/96
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+INTEGER,SAVE :: NAM1, NAM2, NBCNUM, NINCRNAM
+
+CHARACTER*8,SAVE :: CGPNAM, CGPNAM1, CGPNAM2
+
+LOGICAL,SAVE :: LGROUP, LTYPE
+!
+!
+END MODULE MODD_SEVERAL_RECORDS
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_super.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_super.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ad6f6fedabdc1c18507824306ab06bd9e3ab053e
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_super.f90
@@ -0,0 +1,59 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_super.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! #################
+ MODULE MODD_SUPER
+! #################
+!
+!!**** *MODD_SUPER* - This declaration module defines variables controlling
+!! the overlay of several successive plots over either
+!! an horizontal map or a vertical cross-section.
+!!
+!! PURPOSE
+!! -------
+! To control the possibility of plot overlay, two global variables are
+! defined. LSUPER is a logical specifying if the overlay option is
+! activated for the current plot. NSUPER is an integer giving the rank
+! of the current plot in the overlay sequence. The first plot of the
+! sequence, i.e. the background plot, is given the rank NSUPER=1.
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! The principle of overlay handling in TRACE is detailed in:
+!! - Book3 of the TRACE volume of the Meso-NH user manual.
+!!
+!! The technicalities are found in:
+!! - Book2 of the TRACE volume of the Meso-NH user manual
+!! (MODD_SUPER)
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 23/11/94
+!! Updated PM 24/11/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+IMPLICIT NONE
+!
+LOGICAL,SAVE :: LSUPER ! =.T. --> plot overlay is active
+ ! =.F. --> plot overlay is not active
+!
+INTEGER,SAVE :: NSUPER ! Rank of the current plot in the overlay
+ ! sequence. The initial plot is rank 1.
+!
+END MODULE MODD_SUPER
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_tit.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_tit.f90
new file mode 100644
index 0000000000000000000000000000000000000000..611a9eaa82c61fe7c64061d2cd3d82391d775298
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_tit.f90
@@ -0,0 +1,73 @@
+! ######spl
+ MODULE MODD_TIT
+! ################
+!
+!!**** *MODD_TIT* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original JD 08/01/96
+!! updated PM
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+
+! Nom fichier diachronique
+!
+CHARACTER(LEN=10),SAVE :: CTITALL
+CHARACTER(LEN=100),SAVE :: CTITT1, CTITT2, CTITT3, CTITB1, CTITB2, CTITB3
+CHARACTER(LEN=100),SAVE :: CTITB3MEM
+CHARACTER(LEN=40),SAVE :: CTITYT, CTITYM, CTITYB, CTITXL, CTITXM, CTITXR
+CHARACTER(LEN=40),SAVE :: CTITVAR1, CTITVAR2, CTITVAR3, CTITVAR4, CTITVAR5
+CHARACTER(LEN=40),SAVE :: CTITVAR6, CTITVAR7, CTITVAR8
+LOGICAL :: LTITDEF, LTITDEFM
+REAL,SAVE :: XSZTITT1=0., XSZTITT2=0., XSZTITT3=0.
+REAL,SAVE :: XPOSTITT1=0., XPOSTITT2=0., XPOSTITT3=0.
+REAL,SAVE :: XYPOSTITT1=0., XYPOSTITT2=0., XYPOSTITT3=0.
+!
+REAL,SAVE :: XSZTITB1=0., XSZTITB2=0., XSZTITB3=0.
+REAL,SAVE :: XPOSTITB1=0., XPOSTITB2=0., XPOSTITB3=0.
+REAL,SAVE :: XYPOSTITB1=0., XYPOSTITB2=0., XYPOSTITB3=0.
+!
+REAL,SAVE :: XSZTITYT=0., XSZTITYM=0., XSZTITYB=0.
+REAL,SAVE :: XPOSTITYT=0., XPOSTITYM=0., XPOSTITYB=0.
+REAL,SAVE :: XYPOSTITYT=0., XYPOSTITYM=0., XYPOSTITYB=0.
+!
+REAL,SAVE :: XSZTITVAR1=0., XSZTITVAR2=0., XSZTITVAR3=0.
+REAL,SAVE :: XSZTITVAR4=0., XSZTITVAR5=0., XSZTITVAR6=0.
+REAL,SAVE :: XSZTITVAR7=0., XSZTITVAR8=0.
+REAL,SAVE :: XPOSTITVAR1=0., XPOSTITVAR2=0., XPOSTITVAR3=0.
+REAL,SAVE :: XPOSTITVAR4=0., XPOSTITVAR5=0., XPOSTITVAR6=0.
+REAL,SAVE :: XPOSTITVAR7=0., XPOSTITVAR8=0.
+REAL,SAVE :: XYPOSTITVAR1=0., XYPOSTITVAR2=0., XYPOSTITVAR3=0.
+REAL,SAVE :: XYPOSTITVAR4=0., XYPOSTITVAR5=0., XYPOSTITVAR6=0.
+REAL,SAVE :: XYPOSTITVAR7=0., XYPOSTITVAR8=0.
+
+!
+END MODULE MODD_TIT
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_title.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_title.f90
new file mode 100644
index 0000000000000000000000000000000000000000..139d8e66d0ca24a80d23be11484f5515c1412c2a
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_title.f90
@@ -0,0 +1,48 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_title.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! #################
+ MODULE MODD_TITLE
+! #################
+!
+!!**** *MODD_TITLE* - Declares heading variables for the plots
+!!
+!! PURPOSE
+!! -------
+! This declarative module defines a character variable containing
+! the heading title of the current plot, and the rank of the current
+! plot from the start of the TRACE session.
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of the TRACE volume of the Meso-NH user manual
+!! (MODD_TITLE), to appear in 1994
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/06/94
+!! Updated PM 22/11/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+IMPLICIT NONE
+!
+INTEGER :: NCONT ! Current plot number
+
+CHARACTER(LEN=110) :: CLEGEND ! Current plot heading title
+CHARACTER(LEN=100) :: CLEGEND2 ! Current plot heading title
+
+END MODULE MODD_TITLE
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_traj3d.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_traj3d.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a77617c7fca355899e8a0ca60d382765d9559877
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_traj3d.f90
@@ -0,0 +1,48 @@
+! ######spl
+ MODULE MODD_TRAJ3D
+! ####################
+!
+!!**** *MODD_TRAJ3D* -
+!!
+!! PURPOSE
+!! -------
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! JS "MF"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 10/04/00
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+
+IMPLICIT NONE
+
+INTEGER, PARAMETER :: NPART_MAX=100
+REAL, DIMENSION(NPART_MAX),SAVE :: XXPART
+REAL, DIMENSION(NPART_MAX),SAVE :: XYPART
+REAL, DIMENSION(NPART_MAX),SAVE :: XZPART
+LOGICAL,SAVE :: LTRAJ3D=.FALSE.
+LOGICAL,SAVE :: LFLUX3D=.FALSE.
+INTEGER,SAVE :: NPART
+LOGICAL,SAVE :: LTRAJ_GROUP=.FALSE.
+CHARACTER (LEN=16), SAVE :: CTRAJ_GROUP
+!
+END MODULE MODD_TRAJ3D
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_type_allvar.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_type_allvar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bfae7a5b73cf69fbac90e0cf360e5eb9123f4849
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_type_allvar.f90
@@ -0,0 +1,68 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_type_allvar.f90, Version:1.2, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODD_TYPE_ALLVAR
+! ###################
+!
+!!**** *MODD_TYPE_ALLVAR* - Declaration des types de variables 3D, 2D, 1D,
+!!
+!! PURPOSE
+!! -------
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! P Jabouille
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 11/08/97
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+IMPLICIT NONE
+!
+TYPE X_Y_Z_
+ CHARACTER(LEN=16) :: NAME
+ INTEGER :: IGRID
+ CHARACTER(LEN=16) :: UNITS
+END TYPE X_Y_Z_
+!
+TYPE X_Y_
+ CHARACTER(LEN=16) :: NAME
+ INTEGER :: IGRID
+ CHARACTER(LEN=16) :: UNITS
+END TYPE X_Y_
+!
+TYPE VX_VY_VZ_
+ CHARACTER(LEN=16),DIMENSION(3) :: NAME
+ INTEGER,DIMENSION(3) :: IGRID
+ CHARACTER(LEN=16),DIMENSION(3) :: UNITS
+END TYPE VX_VY_VZ_
+!
+TYPE VX_VY_
+ CHARACTER(LEN=16),DIMENSION(3) :: NAME
+ INTEGER,DIMENSION(3) :: IGRID
+ CHARACTER(LEN=16),DIMENSION(3) :: UNITS
+END TYPE VX_VY_
+!
+TYPE Z_
+ CHARACTER(LEN=16) :: NAME
+ INTEGER :: IGRID
+ CHARACTER(LEN=16) :: UNITS
+END TYPE Z_
+!
+END MODULE MODD_TYPE_ALLVAR
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modd_type_and_lh.f90 b/LIBTOOLS/tools/diachro/src/MOD/modd_type_and_lh.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d3639c736bd6082a3126336463712d112977b950
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modd_type_and_lh.f90
@@ -0,0 +1,48 @@
+! ######spl
+ MODULE MODD_TYPE_AND_LH
+! #######################
+!
+!!**** *MODD_TYPE_AND_LH* -
+!!
+!! PURPOSE
+!! -------
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!! J. Duron *LA*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 23/11/96
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!
+CHARACTER (LEN=4), SAVE :: CTYPE ! type of data
+!
+INTEGER, SAVE :: NKL, NKH ! lowest and highest K indice values
+
+LOGICAL, SAVE :: LKCP ! switch for compression in K
+ ! direction
+INTEGER, SAVE :: NIL, NIH ! lowest and highest I indice values
+
+INTEGER, SAVE :: NJL, NJH ! lowest and highest J indice values
+
+LOGICAL, SAVE :: LICP ! switch for compression in I
+ ! direction
+LOGICAL, SAVE :: LJCP ! switch for comppression in J
+ ! direction
+END MODULE MODD_TYPE_AND_LH
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modn_ncar.f90 b/LIBTOOLS/tools/diachro/src/MOD/modn_ncar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4479c823f0662e64e7476218ba0d734f50b21ebd
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modn_ncar.f90
@@ -0,0 +1,136 @@
+! ######spl
+ MODULE MODN_NCAR
+! #################
+!
+!!**** *MODN_NCAR* - defines the NAM_DIRTRA_POS namelist (former NCAR common)
+!!
+!! PURPOSE
+!! -------
+! This declarative module defines the NAM_DIRTRA_POS namelist, which
+! contains the parameters controlling the NCAR plotting environnement
+! parameters.
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book2 of the TRACE volume of the Meso-NH user manual
+!! (MODD_FIELD1_CV2D), to appear in 1994
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 02/06/94
+!! updated PM 19/11/94
+!! JS change the pressure variable 25/07/97
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Former namelist NAM_DIRTRA_POS
+!
+INTEGER :: NIOFFD, & ! Label normalisation (=0 none, =/=0 active)
+ NULBLL, & ! Nb of contours between 2 labelled contours
+ NIOFFM, & ! =0 --> message at picture bottom
+ ! =/= 0 --> no message
+ NIOFFP, & ! Special point value detection
+ ! (=0 none, =/=0 active)
+ NHI, & ! Extrema detection
+ ! (=0 --> H+L, <0 nothing)
+ NINITA, & ! For streamlimes
+ NINITB, & ! (Not yet implemented)
+ NIGRNC, & !
+ NDOT, & ! Line style
+ ! (=0|1|1023|65535 --> solid lines;
+ ! <0 --> solid lines for positive values and
+ ! dotted lines(ABS(NDOT))for negative values;
+ ! >0 --> dotted lines(ABS(NDOT)) )
+ NIFDC, & ! Coastline data style (0 none, 1 NCAR, 2 IGN)
+ NLPCAR, & ! Number of land-mark points to be plotted
+ NIMNMX, & ! Contour selection option
+ ! (=-1 Min, max and inc. automatically set;
+ ! =0 Min, max automatically set; inc. given;
+ ! >0 Min, max, inc. given by user)
+ NISKIP ! Rate for drawing velocity vectors
+! Nov 2000
+INTEGER :: NIJCAR=0 ! Cartes. Equivalent de NLPCAR en proj. cart.
+
+CHARACTER(LEN=8) :: CTYPHOR ! Horizontal cross-section type
+ ! (='K' --> model level section;
+ ! ='Z' --> constant-altitude section;
+ ! ='P' --> isobar section (planned)
+ ! ='T' --> isentrope section (planned)
+
+REAL :: XSPVAL, & ! Special value
+ XSIZEL ! Label size
+REAL :: XVHC,XVRL,XAMX
+
+REAL,DIMENSION(100) :: X3DINT, X2DINT
+
+! Nov 2000
+REAL,DIMENSION(400) :: XICAR, XJCAR ! En cartesien en indices de grilles
+! les precedents sont les equivalents des suivants et leur nb=NIJCAR
+! Nov 2000
+REAL,DIMENSION(400) :: XLATCAR, XLONCAR ! Lat. and Long. of land-mark points
+
+LOGICAL :: LXY, & ! If =.T., plots a grid-mesh stencil background
+ LXZ, & ! If =.T., plots a model-level stencil background
+ LCOLAREA, LCOLAREASEL, LTABCOLDEF, &
+ LCOLINE, LCOLINESEL, LISOWHI, LCOLBR, LARROVL, LISO, &
+ LDATFILE, LVECTMNMX, LMINMAX, &
+ LSPOT
+!
+!* 0.2 Former namelist NAM_DIRTRA2_POS
+!
+! Gestion taille fenetre affichage
+! ********************************
+! Cas coupes horizontales (isocontours et vecteurs)
+REAL :: XVPTL, XVPTR, XVPTB, XVPTT
+REAL :: XWINL, XWINR, XWINB, XWINTT
+!
+! Cas coupes verticales (isocontours et vecteurs)
+REAL :: XVPTVL, XVPTVR, XVPTVB, XVPTVT
+REAL :: XWINVL, XWINVR, XWINVB, XWINVT
+!
+! Cas profils verticaux
+REAL :: XVPTPVL, XVPTPVR, XVPTPVB, XVPTPVT
+REAL :: XWINPVL, XWINPVR, XWINPVB, XWINPVT
+!
+! Cas TRAXY
+REAL :: XVPTXYL, XVPTXYR, XVPTXYB, XVPTXYT
+REAL :: XWINXYL, XWINXYR, XWINXYB, XWINXYT
+!
+! CH
+LOGICAL :: LVPTUSER, LWINUSER
+! CV
+LOGICAL :: LVPTVUSER, LWINVUSER
+! PV
+LOGICAL :: LVPTPVUSER, LWINPVUSER
+! XY
+LOGICAL :: LVPTXYUSER, LWINXYUSER
+!
+! Gestion epaisseur traits isocontours (CH et CV)
+! ***********************************************
+REAL :: XLWDEF, XLW, XLWVDEF, XLWV
+REAL :: XLWIDTH
+!
+END MODULE MODN_NCAR
diff --git a/LIBTOOLS/tools/diachro/src/MOD/modn_para.f90 b/LIBTOOLS/tools/diachro/src/MOD/modn_para.f90
new file mode 100644
index 0000000000000000000000000000000000000000..79f01b3b5a764bc95536f10291bdc6c3f61d4fc7
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/MOD/modn_para.f90
@@ -0,0 +1,91 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/modn/s.modn_para.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! #################
+ MODULE MODN_PARA
+! #################
+!
+!!**** *MODN_PARA* - defines the NAM_DOMAIN_POS namelist (former PARA common)
+!!
+!! PURPOSE
+!! -------
+! This declarative module declares the variables of the NAM_DOMAIN_POS
+! namelist, which specify all the geometrical characteristics of the
+! plotted domain as requested by the user.
+!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_DIM1 : contains dimensions of data arrays
+!! NIINF, NISUP : lower and upper bounds of arrays to be plotted in
+!! x direction
+!! NJINF, NJSUP : lower and upper bounds of arrays to be plotted in
+!! y direction
+!!
+!! REFERENCE
+!! ---------
+!! Bougeault et al., 1994, "The MESO-NH user's guide", Chapter 4: Run a
+!! post-processing session, Internal technical note, CNRM/GMME, Toulouse
+!!
+!! Book2 of the TRACE volume of the Meso-NH user manual
+!! (MODN_PARA), to appear in 1994
+!!
+!! AUTHOR
+!! ------
+!! JD "LA"
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 02/06/94
+!! updated PM 21/11/94
+!!
+!-------------------------------------------------------------------------
+!
+!* 0. Declarations
+! ------------
+!
+USE MODD_DIM1
+
+IMPLICIT NONE
+
+LOGICAL,SAVE :: LHORIZ, & ! =.T. to perform horizontal cross-sections
+ ! (LVERTI must be = to .F.)
+ LVERTI, & ! =.T. to perform vertical cross-sections, in-
+ ! -cluding vert. 1D profiles. (LHORIZ must be
+ ! = to .F.)
+ L3D ! =.T. to draw 3D perspective plots (LHORIZ and
+ ! LVERTI must be = to .F.).(Not yet implemented)
+
+INTEGER,SAVE :: NIDEBCOU,NJDEBCOU, & ! Origin of a vertical cross-section
+ ! in grid index integer values
+ ! (XIDEBCOU and XJDEBCOU must be = to
+ ! -999.)
+ NLANGLE, & ! Angle between X Meso-NH axis and
+ ! cross-section direction in degrees
+ ! (Integer value anticlockwise)
+ NLMAX, & ! Number of points horizontally along
+ ! the vertical section
+ NIFLAG
+
+REAL,SAVE :: XIDEBCOU,XJDEBCOU, & ! Origin of a vertical cross-section
+ ! in cartesian (or conformal) real
+ ! values
+ XHMIN, & ! altitude of the vert. cross-section
+ ! bottom (in meters above sea-level)
+ XHMAX, & ! altitude of the vert. cross-section
+ ! top (in meters above sea-level)
+ XDZTRA ! Not yet used
+
+REAL,DIMENSION(3):: XEYE ! Not yet used
+
+!
+!* 0.1 Namelist NAM_DOMAIN_POS
+!
+NAMELIST/NAM_DOMAIN_POS/LHORIZ,NIINF,NISUP,NJINF,NJSUP,LVERTI,NIDEBCOU,NJDEBCOU, &
+XIDEBCOU,XJDEBCOU,NLMAX,NLANGLE,XHMIN,XHMAX,XDZTRA,L3D,XEYE,NIFLAG
+!
+END MODULE MODN_PARA
diff --git a/LIBTOOLS/tools/diachro/src/POS/big.h b/LIBTOOLS/tools/diachro/src/POS/big.h
new file mode 100644
index 0000000000000000000000000000000000000000..5046de60c4fc41279dd49ff619787a33d60638e2
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/big.h
@@ -0,0 +1,15 @@
+#ifdef SMALL
+#ifndef f77
+INTEGER, PARAMETER :: N2DVERTX=1000 , NPMAP=800000
+#else
+ INTEGER N2DVERTX, NPMAP
+ PARAMETER(N2DVERTX=1000, NPMAP=800000)
+#endif
+#else
+#ifndef f77
+INTEGER, PARAMETER :: N2DVERTX=4000 , NPMAP=1800000
+#else
+ INTEGER N2DVERTX, NPMAP
+ PARAMETER(N2DVERTX=4000, NPMAP=1800000)
+#endif
+#endif
diff --git a/LIBTOOLS/tools/diachro/src/POS/ccolr.f b/LIBTOOLS/tools/diachro/src/POS/ccolr.f
new file mode 100644
index 0000000000000000000000000000000000000000..73330e702fc3b56328664ce0640964463a2a2753
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/ccolr.f
@@ -0,0 +1,160 @@
+! ######spl
+ SUBROUTINE CCOLR(XWRK,YWRK,NWRK,IAREA,IGRP,NGRPS)
+C #################################################
+C
+C
+CC**** *CCOLR* - Performs color filling of the contour intervals
+CC
+CC PURPOSE
+CC -------
+C When contour plot is drawn, the successive contour intervals are
+C filled with colors as given by a color index which is a function of
+C contor level.
+C
+CC** METHOD
+CC ------
+CC
+CC In IMAGE, IMAGEv or IMCOU.., as the contour plots are prepared, the
+CC areas between successive contour levels are identified using "area
+CC numbers". CCOLR uses these area numbers to select a color in the
+CC current color table, and fills the corresponding area using a GKS
+CC fill area call. See the NCAR manual to understand how "area numbers"
+CC work, this topic is slightly involved.. (NCAR contouring tutorial,
+CC Vol. 2, pages 12-19, page 120, and pages 130-133).
+CC
+CC To summarize, all the lines composing a plot are grouped by "edge
+CC groups" which may be individually accessed using "group numbers" to
+CC perform specific tasks. For the present purpose only the lines drawn
+CC by CONPACK are important, and they belong to group number 3.
+CC When the contours are computed, CONPACK assigns "area numbers" to the
+CC different sub-regions of the plot: typically screen points out of the
+CC model domain are given a negative area number, and areas between
+CC isocontours receive area numbers greater than 2, with increasing area
+CC numbers from the lower contour to the higher one.
+CC The coloring is therefore performed by scanning the group and area
+CC numbers to locate the screen locations to be colored, as follows:
+CC - CCOLR is called by CONPACK for each contour polygon, with XWRK-YWRK
+CC containing the NWRK points of the current contour, and IAREA-IGRP
+CC containing the corresponding group and area numbers;
+CC - First, the group number is checked to select CONPACK items only,
+CC - Second, the area numbers are checked to select positive ones, and
+CC a color values are picked up in the ICOL color table.
+CC - If so, the color parameter is set (GSFACI) and the color filling
+CC routine is called to fill the current contour (XWRK-YWRK) with the
+CC prescribed color.
+CC
+CC NOTICE: CCOLR and the NCAR graphical utilities are NOT written
+CC ------ in Fortran 90, but in Fortran 77.. This sub-section of TRACE
+CC does not follow the Meso-NH usual rules: it has to be directly
+CC called by the NCAR CONPACK utility.
+CC
+CC EXTERNAL
+CC --------
+CC None
+CC
+CC EXPLICIT ARGUMENTS
+CC ------------------
+CC
+CC XWRK : x-coordinates (in NCAR fractional system) of the successive
+CC points forming a given contour enclosing a polygonal area.
+CC YWRK : y-coordinates (in NCAR fractional system) of the successive
+CC points forming a given contour enclosing a polygonal area.
+CC NWRK : Number of points in XWRK-YWRK to build the contour.
+CC IAREA: Area identifiers for the polygon defined by the XWRK-YWRK and
+CC for each of the NGRPS groups of edges in this plot.
+CC IGRP : Group identifiers for the polygon defined by the XWRK-YWRK and
+CC for each of the NGRPS groups of edges in this plot.
+CC NGRPS: Maximum number of edge groups defined in this plot.
+CC
+CC NOTICE: All these dummy arguments are required
+CC ------ by the NCAR CALLS
+CC
+CC IMPLICIT ARGUMENTS
+CC ------------------
+CC
+CC Common COLAREA : color table information
+CC ICOL : Array of the possible values of the GKS color index. These
+CC GKS color index values are initialized earlier in the TRACE
+CC run by reading a user provided color table file.
+CC
+CC REFERENCE
+CC ---------
+CC
+CC MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+CC + Book1: Concepts and Fundamentals, to appear in 1994;
+CC + Book2: Technical Reference and Flowcharts, to appear in 1994;
+CC + Book3: Tutorial, November 1994.
+CC
+CC NCAR Graphics Technical documentation, UNIX version 3.2,
+CC Scientific computing division, NCAR/UCAR, Boulder, USA.
+CC Volume 1: Fundamentals, Vers. 1, May 1993
+CC Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+CC
+CC AUTHOR
+CC ------
+CC
+CC J. Duron * Laboratoire d'Aerologie *
+CC
+CC MODIFICATIONS
+CC -------------
+CC Original 01/07/94
+CC Updated PM 24/01/95
+C-------------------------------------------------------------------------------
+C
+C* 0. DECLARATIONS
+C ------------
+C
+C>>>>>>>DRAGOON NOTICE: I ENFORCED "IMPLICIT NONE" IT'S WISE CHECKING...
+C
+ IMPLICIT NONE
+C
+C* 0.0 Dummy arguments
+C
+ REAL XWRK(*), YWRK(*)
+ INTEGER IAREA(*), IGRP(*)
+ INTEGER NWRK,NGRPS
+C
+C* 0.1 Commons
+C
+ COMMON/COLAREA/ICOL(300)
+ INTEGER ICOL
+C
+C* 0.2 Local variables
+C
+
+ REAL RSCR(10000)
+ INTEGER ISCR(10000)
+ INTEGER I,IA
+C
+C-----------------------------------------------------------------------------
+C
+C* 1. PERFORMS CONTOUR INTERVAL COLORING
+C ----------------------------------
+C
+C* 1.1 Select a color index for each area number
+C* when edge group=3 (contour edges) and area number
+C* is positive (within plot limits)
+C
+ DO I=1,NGRPS
+C print *,' IGRP IAREA',IGRP(I),IAREA(I),' I',I
+ IF(IGRP(I).EQ.3)THEN
+ IA=-5
+ IF(IAREA(I).GT.0)IA=ICOL(IAREA(I))
+C IF(IAREA(I).GT.0)IA=IAREA(I)+2
+ END IF
+ ENDDO
+C
+C* 1.2 Fills the (XWRK,YWRK) polygon with selected color
+C
+ IF(IA.GT.0)THEN
+ CALL GSFACI(IA)
+ CALL GFA(NWRK-1,XWRK,YWRK)
+ ENDIF
+ RETURN
+C
+C----------------------------------------------------------------------------
+C
+C* 2. EXIT
+C ----
+C
+ END
diff --git a/LIBTOOLS/tools/diachro/src/POS/dewp.f90 b/LIBTOOLS/tools/diachro/src/POS/dewp.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6c7c703852ac45f811cfea859cdb79cbc38d2a9f
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/dewp.f90
@@ -0,0 +1,86 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/post/s.dewp.f90, Version:1.2, Date:98/10/02, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ######spl
+ FUNCTION DEWP(PQ,PP)
+! ####################
+!
+!!**** *DEWP* - Computes the dewpoint temperature
+!!
+!! PURPOSE
+!! -------
+! Computes the dewpoint temperature for given mixing ratio and pressure
+! used for the emagram routine of TRACE
+!
+!!** METHOD
+!! ------
+!! Analytical formula inverting the Tetens formula
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Among many others, see for instance:
+!! Bluestein H. B., 1992, "Synoptic-Dynamic Meteorology in mid-latitudes"
+!! Volume 1, Priciples of Kinematics and Dynamics, Section 4.3, p. 195,
+!! Oxford University Press.
+!!
+!! AUTHOR
+!! ------
+!! - Initial version Peridot TRACE Program, P.Bougeault *Meteo-France*,
+!! modified by R. Benoit (mc2, april 91) for the PYREX Oracle data base.
+!! - Present version J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 10/01/95
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declaration of arguments and result
+!
+REAL,INTENT(IN) :: PQ ! Mixing ratio ( g/kg)
+REAL,INTENT(IN) :: PP ! Pressure (millibars)
+!
+REAL :: DEWP ! Dewpoint temperature (Kelvin)
+
+!
+!* 0.2 Declaration of local variables
+!
+REAL :: ZX, ZY, ZPQ
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. CALCULATION OF DEWP
+! -------------------
+! PQ (G/KG), PP (MILIBARS), DEWP (KELVIN)
+!
+!
+ZPQ=PQ
+IF(PQ <= 0.)ZPQ=1.E-16
+ZX = PP*ZPQ/(622.+ZPQ)
+!ZX = PP*PQ/(622.+PQ)
+ZY = ALOG(ZX/6.1078)
+DEWP = ZY*237.3/(17.2693882-ZY)
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END FUNCTION DEWP
diff --git a/LIBTOOLS/tools/diachro/src/POS/echelle.f90 b/LIBTOOLS/tools/diachro/src/POS/echelle.f90
new file mode 100644
index 0000000000000000000000000000000000000000..da63d8a18d5b78245c793f41e8e1e64281e4ad21
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/echelle.f90
@@ -0,0 +1,249 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/post/s.echelle.f90, Version:1.2, Date:98/10/02, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ######spl
+ SUBROUTINE ECHELLE(KLEN,PHA)
+! ############################
+!
+!!**** *ECHELLE* - Sets the arrow scales for the emagram environment
+!!
+!! PURPOSE
+!! -------
+!
+! This routine initialize the emagram wind vector plotting by invoking
+! the NCAR "DRWVEC" utility (drawing of a single vector). KLEN and PHA
+! are returned to the calling program.
+!
+!!** METHOD
+!! ------
+!! The scaling is made is made by converting to the old-fashioned
+!! NCAR "metacode coordinate", see NCAR documentation volume I, page 345.
+!! A scaling vector is drawn to the page bottom as a visual guidance.
+!! Returned values are: KLEN maximum arrow size which can be plotted
+!! (given in metacode units), PHA maximum wind modulus which can be
+!! plotted (given in m/s). Values of KLEN and PHA have to be mutually
+!! consistent.
+!!
+!! EXTERNAL
+!! --------
+!! GETSI : Retrieves the parameters defining the size of the plotter
+!! in the plotter coordinate system. Size assumed between 1 and
+!! 2**ISX-1 and 2**ISY-1. This old-fashioned NCAR routine is
+!! documented in the SSPS reference manual of the Version 2
+!! (not in version 3!) of the NCAR package. We sincerely
+!! apologize for the inconvenience.
+!! GSCLIP : Controls NCAR window clipping.
+!! GETSET : Returns the current mapping of the NCAR user coordinate
+!! onto the current GKS viewport in normalized device coordinate.
+!! See NCAR reference manual volume 1, page 343 for details.
+!! CFUX : Converts a X "fractional coordinate" value into its
+!! X "user coordinate" counterpart. See NCAR manual volume 1,
+!! page 346 for details.
+!! CFUY : Converts a Y "fractional coordinate" value into its
+!! Y "user coordinate" counterpart. See NCAR manual volume 1,
+!! page 346 for details.
+!! FL2INT : Given a coordinate pair in the NCAR user system, returns the
+!! coresponding coordinate pair in the metacode system;
+!! DRWVEC : Draws a single vector given by two pairs of metacode
+!! coordinates, CALL DRWVEC (M1,M2,M3,M4,LABEL,NC), where
+!! (M1,M2) coordinate of arrow base on a 2**15x2**15 grid,
+!! (M3,M4) coordinate of arrow head on a 2**15x2**15 grid,
+!! LABEL character label to be put above arrow, and
+!! NC number of character in label. This routine is
+!! and documented in the VELVECT NCAR sources, but
+!! not really documented elsewhere... Sorry for this!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! For the vector utilities not documented in the NCAR package
+!! Version 3 idocumentation, a better reference is:
+!! The NCAR GKS-Compatible Graphics System Version 2,
+!! SPPS an NCAR System Plot Package Simulator.
+!! NCAR Technical note 267+1A, April 1986, NCAR/UCAR, Boulder, USA.
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 11/01/59
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_RESOLVCAR
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments and results
+!
+INTEGER, INTENT(OUT) :: KLEN ! KLEN maximum arrow size which can be plotted
+ ! (given in metacode units)
+REAL, INTENT(OUT) :: PHA ! PHA maximum wind modulus which can be plotted
+ ! (given in m/s)
+!
+!* 0.2 Local variables
+!
+INTEGER :: ILENGTH, IDUM5, IM1, IM2, IM3, IM4, IPHAS4, IL
+
+CHARACTER(LEN=10) :: YLABEL
+CHARACTER(LEN=1) :: Y1
+REAL :: ZU, ZV
+REAL :: ZFXMIN,ZFXMAX,ZFYMIN,ZFYMAX,ZUMIN,ZUMAX,ZVMIN,ZVMAX
+!
+!* 0.3 TRACE interface with the DRWVEC routine of the NCAR package
+!
+! NOTICE: The DRWVEC and the NCAR graphical utilities are NOT written
+! ------ in Fortran 90, but in Fortran 77.. This sub-section of TRACE
+! does not follow the Meso-NH usual rules: communication has
+! to be made using the /VEC1/ COMMON stack with static memory
+! allocation. Actually used variables are:
+! ICTRFG arrow centering control flag
+! ISX plotter size along x in plotter units
+! ISY plotter size along y in plotter units
+! ZMN plotter size along x in metacode units
+! ZMX plotter size along y in metacode units
+!
+INTEGER :: ICTRFG, ILAB, IOFFD, IOFFM, ISX, ISY
+REAL :: ASH, EXT, RMN, RMX, SIDE, SIZE, XLT, YBT, ZMN, ZMX
+!
+COMMON /VEC1/ ASH ,EXT ,ICTRFG ,ILAB , &
+IOFFD ,IOFFM ,ISX ,ISY , &
+RMN ,RMX ,SIDE ,SIZE , &
+XLT ,YBT ,ZMN ,ZMX
+!
+!* 0.4 Interface declarations
+!
+INTERFACE
+ FUNCTION CFUX (RX)
+ REAL :: RX, CFUX
+ END FUNCTION CFUX
+END INTERFACE
+!
+INTERFACE
+ FUNCTION CFUY (RY)
+ REAL :: RY, CFUY
+ END FUNCTION CFUY
+END INTERFACE
+INTERFACE
+ SUBROUTINE DRWVEC (M1,M2,M3,M4,LABEL,NC)
+ INTEGER :: M1,M2,M3,M4,NC
+ CHARACTER(LEN=10) LABEL
+ END SUBROUTINE DRWVEC
+END INTERFACE
+!
+!---------------------------------------------------------------------------
+!
+!* 1. ARROW SCALE CALCULATION
+!
+!* 1.0 Sets the plotter dimensions in metacode units
+!* and some upper bound wind value
+!
+ILENGTH=160 ! ILENGTH is the maximum possible arrow length in plotter units
+ ! (i.e.: with respect to the 2**10-1 default value)
+PHA=80. ! PHA is the maximum possible wind value corresponding to the
+ ! maximum possible arrow size given above. Thes two values have
+ ! to be consistent
+!
+! Retrieves plotter size, first in plotter units
+!
+CALL GETSI(ISX,ISY)
+ISX=2**(15-ISX)
+ISY=2**(15-ISY)
+!
+! Converts the maximum possiblble arrow length in metacode units
+! (i.e. with respect to 2**15-1)
+!
+KLEN=ILENGTH*ISX
+ZMN=0.
+ZMX=FLOAT(KLEN)+0.01
+!
+!* 1.1 Computes appropriate scale
+!
+CALL GSCLIP(0) ! Enables leader writing out of the frame
+!
+! Prepares header and scale.
+! Retrieves current window limits in normalized
+! device coordinate and NCAR user coordinate.
+!
+CALL GETSET(ZFXMIN,ZFXMAX,ZFYMIN,ZFYMAX,ZUMIN,ZUMAX,ZVMIN,ZVMAX,IDUM5)
+!
+! Computes the normalized device coordinates of the point located by
+! user coordinates (ZFXMAX-0.05,ZFYMIN-0.04)
+!
+ZU=CFUX(ZFXMAX-0.05)
+ZV=CFUY(ZFYMIN-0.04)
+!
+! Then, convert result to metacode coordinates
+!
+CALL FL2INT(ZU,ZV,IM1,IM2)
+IM3=IM1+KLEN/4
+IM4=IM2
+IPHAS4=IFIX(PHA/4)
+!
+!* 1.2 Draws a unit vector under the plot
+!
+!
+! The unit vector is 1/4 of the maximum possible wind PHA
+!
+CALL PCGETC('FC',Y1)
+!print *,' **echelle Y1',Y1
+CALL PCSETC('FC','?')
+YLABEL=' '
+WRITE(YLABEL,'(I2,'' M/S '')')IPHAS4
+YLABEL=ADJUSTL(YLABEL)
+!print *,' ECHELLE AV DRW..',YLABEL
+!CALL DRWVEC(IM1,IM2,IM3,IM4,YLABEL(1:LEN_TRIM(YLABEL)),LEN_TRIM(YLABEL))
+IL=10
+IF(LRS .OR. LRS1)THEN
+IL=0
+CALL DRWVEC(IM1,IM2,IM3,IM4,YLABEL,IL)
+CALL GSLWSC(1.)
+CALL PLCHHQ(25.5553226,-1.4807138,YLABEL(1:LEN_TRIM(YLABEL)),7.,0.,0.)
+CALL GSLWSC(2.)
+ELSE
+CALL DRWVEC(IM1,IM2,IM3,IM4,YLABEL,IL)
+ENDIF
+CALL SFLUSH
+!print *,' ECHELLE AP DRW..'
+!
+! Setting the ICTRFG flag controls the arrow centering.
+! Arrow is centered with ICTRFG=0, and the tail of the
+! arrow is placed at the grid point location with ICTRFG=1.
+!
+ICTRFG=1
+!
+! Window clipping restored after header writing
+!
+!CALL GSCLIP(1)
+CALL PCSETC('FC',Y1)
+!
+!----------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+!
+END SUBROUTINE ECHELLE
diff --git a/LIBTOOLS/tools/diachro/src/POS/esat.f90 b/LIBTOOLS/tools/diachro/src/POS/esat.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c8eb27924d570e05ff63b6a3ba0735aa8144380e
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/esat.f90
@@ -0,0 +1,82 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/post/s.esat.f90, Version:1.2, Date:98/10/02, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ######spl
+ FUNCTION ESAT(PT)
+! #################
+!
+!!**** *ESAT* - Computes the saturation water vapor pressure
+!!
+!!
+!! PURPOSE
+!! -------
+! Computes the saturation water vapor pressure at a given temperature,
+! used in the emagram routine of TRACE
+!
+!!** METHOD
+!! ------
+!! Analytical formula of Tetens (1930)
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Among many others, see for instance:
+!! Bluestein H. B., 1992, "Synoptic-Dynamic Meteorology in mid-latitudes"
+!! Volume 1, Priciples of Kinematics and Dynamics, Section 4.3, p. 195,
+!! Oxford University Press.
+!!
+!! AUTHOR
+!! ------
+!! - Initial version Peridot TRACE Program, P.Bougeault *Meteo-France*,
+!! modified by R. Benoit (mc2, april 91) for the PYREX Oracle data base.
+!! - Present version J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 10/01/95
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declaration of argument and result
+!
+REAL,INTENT(IN) :: PT
+REAL :: ESAT
+!
+!* 0.2 Declaration of local variables
+!
+!
+REAL :: ZABZ, ZTC
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. CALCULATION OF ESAT
+! -------------------
+!
+! ESAT (MILLIBARS), PT (KELVIN)
+!
+ZABZ=273.16
+ZTC = PT-ZABZ
+ESAT = 6.1078*EXP((17.2693882*ZTC)/(ZTC+237.3))
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END FUNCTION ESAT
diff --git a/LIBTOOLS/tools/diachro/src/POS/ficstr.f b/LIBTOOLS/tools/diachro/src/POS/ficstr.f
new file mode 100644
index 0000000000000000000000000000000000000000..598c7e140b2890871c319172022ee47d273d5463
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/ficstr.f
@@ -0,0 +1,4719 @@
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C AVRIL 2002
+C Ces routines ne sont presentes que pour les streamlines pour
+C augmenter la dimension d'1 tableau 750 -> 1500
+ccccc Intervention perso dans 2 routines des streamlines (Fin du fichier)
+C ce parametre existe aussi ds stinit.f ou je suis intervenue
+C Intervention totale ds stumxy.f
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C $Id$
+C
+ BLOCK DATA STDATA
+C
+C This routine defines the default values of the Streamline parameters.
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C ---------------------------------------------------------------------
+C Old STRMLN interface common blocks
+C
+ COMMON /STR02/ EXT , SIDE , XLT , YBT
+C
+ COMMON /STR03/ INITA , INITB , AROWL , ITERP , ITERC , IGFLG
+ + , IMSG , UVMSG , ICYC , DISPL , DISPC , CSTOP
+C
+C ---------------------------------------------------------------------
+C
+C Initialization of STPAR
+C
+C IUD1 -- 'UD1' -- First dimension of U
+C
+ DATA IUD1 / -1 /
+C
+C IVD1 -- 'VD1' -- First dimension of V
+C
+ DATA IVD1 / -1 /
+C
+C IPD1 -- 'PD1' -- First dimension of P
+C
+ DATA IPD1 / -1 /
+C
+C IXD1 -- 'XD1' -- Array index for start of data, first dimension
+C
+ DATA IXD1 / 1 /
+C
+C IXDM -- 'XDM' -- Array index for end of data, first dimension
+C
+ DATA IXDM / -1 /
+C
+C IYD1 -- 'YD1' -- Array index for start of data, second dimension
+C
+ DATA IYD1 / 1 /
+C
+C IYDN -- 'YDN' -- Array index for end of data, second dimension
+C
+ DATA IYDN / -1 /
+C
+C IWKD -- 'WKD' -- Dimension of work array
+C
+ DATA IWKD / -1 /
+C
+C IWKU -- 'WKU' -- Amount of work array actually used (read-only)
+C
+ DATA IWKU / 0 /
+C
+C ISET -- 'SET' -- The Set call flag - Old NSET parameter
+C
+ DATA ISET / 1 /
+C
+C IERR -- 'ERR' -- Error code set by STRMLN (read-only)
+C -101 - Cyclic flag set for non-cyclic data
+C
+ DATA IERR / 0 /
+C
+C
+C IXIN -- 'XIN' -- The X Axis grid increment, must be > 0
+C IYIN -- 'YIN' -- The Y Axis grid increment, must be > 0
+C
+ DATA IXIN / 1 /
+ DATA IYIN / 1 /
+C
+C IXM1 -- (IXDM - 1) (not user accessible)
+C IXM2 -- (IXDM - 2) (not user accessible)
+C IYM1 -- (IYDN - 1) (not user accessible)
+C IYM2 -- (IYDN - 2) (not user accessible)
+C
+C IMSK -- 'MSK' -- Mask streamlines to an area map: <1 -- no mapping,
+C >=1 - mapping;
+C
+ DATA IMSK / 0 /
+C
+C ICPM -- 'CPM' -- the compatibility mode. If >0 the FX,FY,
+C functions are used. Additionally, when
+C used in conjunction with the STRMLN routine,
+C has a meaningful range from -4 to +4 inclusive,
+C where various combinations are allowed to use or
+C ignore 1) the optional input parameters to
+C VELVCT, 2) the data in STR01,STR02,STR03,STR04
+C common, 3) FX, etc routines, as follows:
+C
+C -4: no FX, ignore params, ignore old common data
+C -3: no FX, ignore params, use old common data
+C -2: no FX, use params, ignore old common data
+C -1: no FX, use params, use old common data
+C 0: default, same as -4 if STINIT,STREAM called,
+C same as +1 if STRMLN or EZSTRM called
+C +1: FX, use params, use old common data
+C +2: FX, use params, ignore old common data
+C +3: FX, ignore params, use old common data
+C +4: FX, ignore params, ignore old common data
+C
+C FX means using FX,FY
+C When parameters and common block values are
+C used they override any values set using the
+C STSETx routines
+C
+ DATA ICPM / 0 /
+C
+C NLVL -- 'NLV' -- number of distinct colors to use for the
+C independent variable mapping -- cannot exceed
+C IPLVLS -- default: 16
+C
+ DATA NLVL / 0 /
+C
+C IPAI -- 'PAI' -- the current level -- must be set before
+C modifying an internal level array value
+C
+ DATA IPAI / 1 /
+C
+C ICTV -- 'CTV' -- compute thresholds flag:
+C 0 -- no vector coloring
+C < 0: color vectors by magnitude
+C > 0: color vectors by contents of scalar array P
+C +-1: number of levels and threshold values already
+C set
+C >1,<1: use CTV equally spaced levels
+C
+ DATA ICTV / 0 /
+C
+C WDLV -- 'LWD' -- the width of a streamline
+C
+ DATA WDLV / 1.0 /
+C
+C UVMN -- 'VMN' -- the minimum displayed vector magnitude, read-only
+C UVMX -- 'VMX' -- the maximum displayed vector magnitude, read-only
+C PMIN -- 'PMN' -- the minimum scalar array value, read-only
+C PMAX -- 'PMX' -- the maximum scalar array value, read-only
+C
+ DATA UVMN / 0.0 /
+ DATA UVMX / 0.0 /
+ DATA PMIN / 0.0 /
+ DATA PMAX / 0.0 /
+C
+C ITHN -- 'THN' -- streamline thinning flag
+C
+ DATA ITHN / 0 /
+C
+C IPLR -- 'PLR' -- Polar coordinates for UV array flag
+C
+ DATA IPLR / 0 /
+C
+C ISST -- 'SST' -- Streamline statistics flag
+C
+ DATA ISST / 0 /
+C
+C ICLR -- 'CLR' -- the GKS color index value
+C
+ DATA ICLR / IPLVLS * 1 /
+C
+C TVLU -- 'TVL' -- the list of threshold values
+C
+ DATA TVLU / IPLVLS * 0.0 /
+C
+C End of STPAR intialization
+C
+C --------------------------------------------------------------------
+C
+C STTRAN initialization
+C
+C User coordinate system to viewport, UV array to user coordinates
+C
+C UVPS -- 'VPS' -- The viewport mode
+C
+ DATA UVPS / 0.25 /
+C
+C UVPL -- 'VPL' -- Viewport left
+C
+ DATA UVPL / 0.05 /
+C
+C UVPR -- 'VPR' -- Viewport right
+C
+ DATA UVPR / 0.95 /
+C
+C UVPB -- 'VPB' -- Viewport bottom
+C
+ DATA UVPB / 0.05 /
+C
+C UVPT -- 'VPT' -- Viewport top
+C
+ DATA UVPT / 0.95 /
+C
+C UWDL -- 'WDL' -- Window left
+C
+ DATA UWDL / 0.0 /
+C
+C UWDR -- 'WDR' -- Window right
+C
+ DATA UWDR / 0.0 /
+C
+C UWDB -- 'WDB' -- Window bottom
+C
+ DATA UWDB / 0.0 /
+C
+C UWDT -- 'WDT' -- Window top
+C
+ DATA UWDT / 0.0 /
+C
+C UXC1 -- 'XC1' -- minimum X coord
+C
+ DATA UXC1 / 0.0 /
+C
+C UXCM -- 'XCM' -- maximum Y coord
+C
+ DATA UXCM / 0.0 /
+C
+C UYC1 -- 'YC1' -- minimum Y coord
+C
+ DATA UYC1 / 0.0 /
+C
+C UYCN -- 'YCN' -- maximum Y coord
+C
+ DATA UYCN / 0.0 /
+C
+C End of STTRAN
+C ----------------------------------------------------------------------
+C
+C STSTRM - Parameters affecting the stream processing algorithm
+C
+C ISGD -- 'SGD' - Stream starting grid increment (INITA)
+C
+ DATA ISGD / 2 /
+C
+C IAGD -- 'AGD' - Arrow placement grid increment (INITB)
+C
+ DATA IAGD / 2 /
+C
+C RARL -- 'ARL' - Length of one side of arrow as fraction
+C of the viewport width (replaces AROWL)
+C
+ DATA RARL / 0.012 /
+C
+C ICKP -- 'CKP' - Check progress after this many iterations (ITERP)
+C
+ DATA ICKP / 35 /
+C
+C ICKX -- 'CKX' - Check streamline crossover after this many
+C iterations (ITERC). (If negative crossover is
+C checked at each entrance to a new grid cell)
+C
+ DATA ICKX / -99 /
+C
+C ITRP -- 'TRP' - Interpolaton method (IGFLG)
+C 0 - Use 16 point bessel where possible
+C non 0 - use bi-linear interpolation everywhere
+C
+ DATA ITRP / 0 /
+C
+C ICYK -- 'CYK' - Cyclical data flag (ICYC) If non-zero, instructs
+C the utility to use cyclic interpolation formulas.
+C If set and data is non-cyclic the error flag is set.
+C
+ DATA ICYK / 0 /
+C
+C RVNL -- 'VNL' - Normalization factor for the differential magnitude.
+C This controls number of steps in compatibility mode
+C only when the FX,FY mapping routines are used. See
+C parameter 'DFM' for step control when STMPXY and
+C associated routines are used
+C
+ DATA RVNL / 0.33 /
+C
+C ISVF -- 'SVF' - Special value flag (IMSG)
+C 0 - no special values
+C non 0 - there may be special values, use only
+C bi-linear interpolation
+ DATA ISVF / 0 /
+C
+C RUSV -- 'USV' -- The U array special value (UVMSG)
+C
+ DATA RUSV / 1.0E12 /
+C
+C RVSV -- 'VSV' -- The V array special value (UVMSG)
+C
+ DATA RVSV / 1.0E12 /
+C
+C RNDA -- assigned the NDC value of the arrow size.
+C
+C ISPC -- 'SPC' -- Special color --
+C < 0: no P special value
+C = 0: don't draw streamline that has a P spec val
+C > 0: draw P special values using color SPC
+C
+ DATA ISPC / -1 /
+C
+C RPSV -- 'PSV' -- The P array special value
+C
+ DATA RPSV / 1.0E12 /
+C
+C RCDS -- 'CDS' - The critical displacement as a multiple of 'DFM'.
+C Replaces DISPC. If the streamline has not moved
+C CDS*DFM units in NDC space after ICKP iterations,
+C the streamline is terminated
+C
+ DATA RCDS / 2.0 /
+C
+C RSSP -- 'SSP' - Stream spacing value as a fraction of the viewport
+C width; replaces CSTOP. Checked when a new grid box is
+C entered.
+C
+ DATA RSSP / 0.015 /
+C
+C RDFM -- 'DFM' - Differential magnitude as a fraction of the viewport
+C width. Smaller values result in more steps and a more
+C accurate approximation of the streamline.
+C
+ DATA RDFM / 0.02 /
+C
+C RSMD -- 'SMD' - Streamline minimum distance as a fraction of the
+C viewport width.
+C
+ DATA RSMD / 0.0 /
+C
+C RAMD -- 'AMD' - Arrow minimum distance as a fraction of the
+C viewport width.
+C
+ DATA RAMD / 0.0 /
+C
+C IGBS -- 'GBS' - Grid based spacing flag
+C
+ DATA IGBS / 0 /
+C
+C End of STSTRM
+C --------------------------------------------------------------------
+C
+C STTXP - Text parameters
+C
+C ICCM -- internal - maximum length of character strings
+C
+ DATA ICSZ / IPCHSZ /
+C
+C FZFS -- 'ZFS' -- size of text for zero field string as FVPW
+C FZFX -- 'ZFX' -- X position of zero field string as FVPW
+C FZFY -- 'ZFY' -- Y position of zero field string as FVPW
+C IZFP -- 'ZFP' -- zero field string position flag
+C IZFC -- 'ZFC' -- color of text for zero field label
+C
+ DATA FZFS / 0.033 /
+ DATA FZFX / 0.5 /
+ DATA FZFY / 0.5 /
+ DATA IZFP / 0 /
+ DATA IZFC / -1 /
+C
+C ---------------------------------------------------------------------
+C
+C Beginning of STCHAR initialization
+C
+ DATA CZFT / 'ZERO FIELD' /
+C
+C End of STCHAR initialization
+C
+C
+C ---------------------------------------------------------------------
+C
+C STMAP initialization
+C
+C IMAP -- 'MAP' -- the mapping transformation to use
+C
+ DATA IMAP / 0 /
+C
+C ITRT -- 'TRT' -- Transform type flag:
+C 0 - transform position only
+C 1 - transform position and angle
+C -1 - transform position, angle, and magnitude
+C
+ DATA ITRT / 1 /
+C
+C XVPL,XVPT,YVPB,YVPT -- the viewport values (NDC boundaries)
+C
+C WXMN,WXMX,WYMN,WYMX -- the window minimum and maximum values
+C (User coordinate space)
+C
+C XLOV,XHIV,YLOV,YHIV -- the mapped array endpoint values
+C (Data coordinate space)
+C
+C XGDS,YGDS -- size in data coordinates of a grid box
+C
+C NXCT,NYCT -- number of points in X and Y used for the plot
+C
+C DFMG -- The magnitude of the diffential increment in NDC space
+C
+C LNLG -- the log scale mapping flag from SET call
+C
+C INVX,INVY -- inverse flags for the window boundaries
+C
+C IWCT - unused
+C
+C FW2W,FH2H -- fraction of viewport to fraction of viewspace
+C
+C RBIG,IBIG -- maximum expressible real and integer values
+C
+C ---------------------------------------------------------------------
+C
+C STRMLN compatibility common blocks
+C
+C Beginning of STR02 initialization
+C
+ DATA EXT / 0.25 /
+ DATA SIDE / 0.90 /
+ DATA XLT / 0.05 /
+ DATA YBT / 0.05 /
+C
+C End of STR02 initialization
+C
+C Beginning of STR03 initialization
+C
+ DATA INITA / 2 /
+ DATA INITB / 2 /
+ DATA AROWL / 0.33 /
+ DATA ITERP / 35 /
+ DATA ITERC / -99 /
+ DATA IGFLG / 0 /
+ DATA ICYC / 0 /
+ DATA IMSG / 0 /
+ DATA UVMSG / 1.E+36 /
+ DATA DISPL / 0.33 /
+ DATA DISPC / 0.67 /
+ DATA CSTOP / 0.50 /
+C
+C End of STR03 initialization
+C
+ END
+C
+C $Id$
+C
+ SUBROUTINE STDRAW (U,V,UX,VY,IAM,STUMSL)
+C
+C This routine draws the streamlines.
+C
+ DIMENSION U(IUD1,*) ,V(IVD1,*)
+ DIMENSION UX(IXDM,IYDN) ,VY(IXDM,IYDN)
+ DIMENSION IAM(*)
+ EXTERNAL STUMSL
+C
+C Input parameters:
+C
+C U,V - Vector component arrays
+C UX,UY - Work arrays
+C IAM - Mask array
+C STUMSL - User-defined masked streamline drawing routine
+C
+C The work array has been broken up into two arrays for clarity. The
+C top half of WORK (called UX) will have the normalized (and
+C possibly transformed) U components and will be used for book
+C keeping. the lower half of the WORK array (called VY) will
+C contain the normalized (and possibly transformed) V components.
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C ---------------------------------------------------------------------
+C
+C Local declarations
+C
+C Point and list buffers
+C
+C The XLS and YLS arrays serve as a circular list. they
+C are used to prevent lines from crossing one another.
+C
+ DIMENSION PX(IPNPTS), PY(IPNPTS)
+ DIMENSION XLS(IPLSTL), YLS(IPLSTL)
+C
+C Parameters:
+C
+C IPZERO, IPONE, IPTWO - the numbers 0,1,2
+C PRZERO - the number 0.0
+C PTHREE - the number 3.0
+C PSMALL - a small floating point number, large enough to be
+C detectable by any standard processor
+C PMXITR - maximum iteration count for figuring when determining
+C the streamline edge
+C
+ PARAMETER (IPZERO=0, IPONE=1, IPTWO=2, PRZERO=0.0, PTHREE=3.0)
+ PARAMETER (PSMALL=0.000001, PMXITR=32)
+C
+C Local variables
+C
+C VSM - A small value in comparison to the normalized vector mag.
+C ISK - Number of bits to skip in bit routines
+C IS1 - ISK + 1
+C SSP - Stream spacing value in fractional (ND) coordinates
+C CDS - Critical displacement in fractional (ND) coordinates
+C LCT - Count of streamlines drawn
+C ITO - Total number of points used to draw all the streamlines
+C LCU - Amount of list currently in use
+C LCK - Current list index
+C IDR - drawing direction 0 + direction 1 - direction
+C SGN - multiplier to change sign based on drawing direction
+C IPC - number of points currently in the point buffer
+C ICT - count of iterations in current streamline
+C I,J - Grid indices
+C UIJ,VIJ - individual vector components
+C CVF - component-wise vector normalizing factor
+C LST - flag indicating the last point in a streamline
+C IUX - integer storage for retrieved bits
+C ISV, JSV - saved grid indices where stream starts in + direction
+C NBX - count of grid boxes for current streamline
+C LBC - box checking variable
+C X, Y - current X,Y coordinates (grid coordinates
+C DU, DV - Current normalized interpolated vector components
+C XDA, YDA - Current position in data coordinates
+C XUS, YUS - Current position in user coordinates
+C XND, YND - Current position in NDC space
+C XNS, YNS - value of XND and YND saved at the start of the streamline
+C and after each progress check
+C XN1, YN1 - Previous position in NDC space
+C TA - The tangent angle in NDC space
+C DUV - The differential normalized interpolated vector magnitude
+C CSA,SNA - Cosine and sine of the tangent angle
+C XN2,YN2 - The previous previous position in NDC space
+C TMG - Temporary magnitude
+C XT,YT - Temporary x and y values
+C XU1,YU1 - Previous X and Y user coordinate values
+C NCT - Iteration count for determining the streamline edge
+C LI - Index into circular crossover checking list
+C IZO - Zero field flag
+C
+C --------------------------------------------------------------------
+C
+C Initialize local variables.
+C
+C Bit manipulation values
+C
+c print *,' ++entree STDRAW'
+ VSM = R1MACH(3)*VNML
+ ISK = I1MACH(5) - 2
+ IS1 = ISK + 1
+C
+C Stream spacing (setting depends on whether grid relative sizing is
+C in effect) and critical displacement
+C
+ IF (IGBS.EQ.0) THEN
+ SSP=RSSP*FW2W
+ ELSE
+ SSP=RSSP*FW2W/REAL(IXDM)
+ END IF
+ CDS=RCDS*DFMG
+ SMD=RSMD*FW2W
+ AMD=RAMD*FW2W
+C
+C Stream and arrow counters
+C
+ LCT=0
+ ITO=0
+ IAC=0
+C
+C Crossover list variables
+C
+ LCU = 1
+ LCK = 1
+ XLS(1) = 0.0
+ YLS(1) = 0.0
+C
+C Current streamline variables
+C
+ IDR = 0
+ SGN = 1.0
+ IPC = 0
+ ICT = 0
+ IUC = 0
+ JSV = IYD1
+C
+C
+C Compute the X and Y normalized (and possibly transformed)
+C displacement components (UX and VY).
+C
+ IZO = 1
+ DO 40 J=IYD1,IYDN
+ DO 30 I=IXD1,IXDM
+C
+ CALL STMPUV(U(I,J),V(I,J),UIJ,VIJ,IST)
+ IF (UIJ.NE.0. .OR. VIJ.NE.0.) THEN
+ IZO = 0
+ CVF = VNML/SQRT(UIJ*UIJ + VIJ*VIJ)
+ UIJ = CVF*UIJ
+ VIJ = CVF*VIJ
+ END IF
+C
+C Bookkeeping is done in the least significant bits of the UX array.
+C When UIJ is exactly zero this can present some problems.
+C To get around this problem, set it to a relatively small number.
+C
+ IF (UIJ.EQ.0.0) UIJ = VSM
+C
+C Mask out the least significant two bits as flags for each grid box
+C A grid box is any region surrounded by four grid points.
+C Flag 1 indicates whether any streamline has previously passed
+C through this box.
+C Flag 2 indicates whether any directional arrow has already
+C appeared in this box.
+C Judicious use of these flags prevents overcrowding of
+C streamlines and directional arrows.
+C
+ CALL SBYTES(UIJ,IPZERO,ISK,2,0,1)
+C
+ IF (MOD(I,ISGD).NE.0 .OR. MOD(J,ISGD).NE.0) THEN
+ CALL SBYTES(UIJ,IPONE,IS1,1,0,1)
+ END IF
+ IF (MOD(I,IAGD).NE.0 .OR. MOD(J,IAGD).NE.0) THEN
+ CALL SBYTES(UIJ,IPONE,ISK,1,0,1)
+ END IF
+C
+ UX(I,J) = UIJ
+ VY(I,J) = VIJ
+C
+ 30 CONTINUE
+ 40 CONTINUE
+C
+C If Zero field bail out
+C
+ IF (IZO .EQ. 1) THEN
+ LCT = 0
+ ITO = 0
+ GO TO 190
+ END IF
+C
+C
+C Start a streamline. Experience has shown that a pleasing picture
+C will be produced if new streamlines are started only in grid
+C boxes that previously have not had other streamlines pass through
+C them. As long as a reasonably dense pattern of available boxes
+C is initially prescribed, the order of scanning the grid pts. for
+C available boxes is immaterial.
+C
+ 50 CONTINUE
+C
+C First ensure that the point buffer is clear
+C
+ IF (IPC.GT.1) CALL STLNSG(PX,PY,IPC,IAM,STUMSL)
+C
+ LST=0
+C
+C Find an available box for starting a streamline.
+C
+ IF (IDR .EQ. 0) THEN
+C
+ LCT=LCT+1
+ ITO = ITO+ICT
+ ICT = 0
+ DO 70 J=JSV,IYM1
+ DO 60 I=IXD1,IXM1
+ CALL GBYTES(UX(I,J),IUX,ISK,2,0,1)
+ IF (IAND(IUX,IPONE) .EQ. IPZERO) GO TO 80
+ 60 CONTINUE
+ 70 CONTINUE
+C
+C Must be no available boxes for starting a streamline.
+C This is the final exit from the streamline drawing loop
+C
+ GO TO 190
+C
+ 80 CONTINUE
+C
+C Initialize parameters for starting a streamline.
+C Turn the box off for starting a streamline.
+C If the special value parameter is turned on, check to see if
+C this box has missing data. If so, find a new starting box.
+C
+ CALL SBYTES(UX(I,J),IPONE,IS1,1,0,1)
+ IF (ISVF .NE. 0) THEN
+ CALL STSVCK(U,V,I,J,IST)
+ IF (IST .NE. 0) GO TO 50
+ END IF
+C
+ ISV = I
+ JSV = J
+ IDR = 1
+ SGN = +1.0
+ IUC = 0
+ DST = 0.0
+C
+ ELSE
+C
+C Come to here to draw in the opposite direction
+C
+ IDR = 0
+ SGN = -1.
+ I = ISV
+ J = JSV
+ DST = 0.0
+ ITO = ITO+ICT
+ END IF
+C
+C Initiate the drawing sequence, resetting counters.
+C Start all streamlines in the center of a box.
+C Find the initial normalized interpolated vector components.
+C
+ NBX = 0
+ IF (IDR.NE.0) LBC = LCK+1
+ IF (LBC.GT.IPLSTL) LBC = 1
+ X = FLOAT(I)+0.5
+ Y = FLOAT(J)+0.5
+ CALL STDUDV(UX,VY,I,J,X,Y,DU,DV)
+ XDA=XLOV+(X-1.0)*XGDS
+ YDA=YLOV+(Y-1.0)*YGDS
+ DU=DU*SGN
+ DV=DV*SGN
+C
+C Get initial point in the various coordinate systems
+C and the tangent angle of the stream. If the compatibility flag
+C is positive the FX,FY routines must be used.
+C
+ IF (ICPM.LE.0) THEN
+C
+ XDA=XLOV+(X-1.0)*XGDS
+ YDA=YLOV+(Y-1.0)*YGDS
+ CALL HLUSTMPXY(XDA,YDA,XUS,YUS,IST)
+ IF (IST .LT. 0) GO TO 50
+ XND=CUFX(XUS)
+ YND=CUFY(YUS)
+ XN1=XND
+ YN1=YND
+ CALL HLUSTMPTA(XDA,YDA,XUS,YUS,XND,YND,DU,DV,TA,IST)
+ IF (IST .LT. 0) GO TO 50
+C
+ ELSE
+C
+ XUS=FX(X,Y)
+ IF (XUS.LT.WXMN .OR. XUS.GT.WXMX) GO TO 50
+ YUS=FY(X,Y)
+ IF (YUS.LT.WYMN .OR. YUS.GT.WYMX) GO TO 50
+ XND=CUFX(XUS)
+ YND=CUFY(YUS)
+ TA=ATAN2(DV,DU)
+C
+ END IF
+C
+ XNS=XND
+ YNS=YND
+ ICT=1
+ IPC=1
+ PX(IPC)=XUS
+ PY(IPC)=YUS
+C
+C Check grid box directional arrow eligibility
+C If a minimum arrow distance is set then the first arrow is not drawn
+C
+ IF (AMD.LE.0.0) THEN
+ CALL GBYTES(UX(I,J),IUX,ISK,2,0,1)
+C
+ IF (IDR.NE.0 .AND. IAND(IUX,IPTWO).EQ.0) THEN
+ IAC=IAC+1
+ CALL STARDR(XUS,YUS,XND,YND,TA,IAM,STUMSL,IST)
+ IF (IST.EQ.0) THEN
+ CALL SBYTES(UX(I,J),IPONE,ISK,1,0,1)
+ END IF
+C
+ END IF
+ END IF
+C
+ ADS = 0.0
+C
+C Loop to this point until streamline ends
+C
+ 110 CONTINUE
+C
+C Check to see if the streamline has entered a new grid box.
+C
+ IF (I.EQ.IFIX(X) .AND. J.EQ.IFIX(Y)) THEN
+C
+C Must be in same box -- Clear the point buffer if required
+C
+ IF (IPC .EQ. IPNPTS) THEN
+c print *,' IPC IPNPTS ',IPC,IPNPTS
+ CALL STLNSG(PX,PY,IPNPTS,IAM,STUMSL)
+ PX(1)=PX(IPNPTS)
+ PY(1)=PY(IPNPTS)
+ IPC=1
+ ENDIF
+C
+C Determine the interpolated normalized vector at this point
+C
+ CALL STDUDV (UX,VY,I,J,X,Y,DU,DV)
+ IF (DU.EQ.0.0 .AND. DV.EQ.0.0) GO TO 50
+C
+C Processing diverges depending on the compatibility mode
+C
+ IF (ICPM .LE. 0) THEN
+C
+C Get the tangent angle of the streamline at the current point
+C in NDC space
+C
+ CALL HLUSTMPTA(XDA,YDA,XUS,YUS,XND,YND,DU,DV,TA,IST)
+ IF (IST.NE.0) GO TO 50
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ IF (XUS.LT.WXMN .OR. XUS.GT.WXMX) GO TO 50
+ IF (YUS.LT.WYMN .OR. YUS.GT.WYMX) GO TO 50
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+C
+ ELSE
+C
+C A new point is found in grid space, then transformed into
+C user and NDC space. There is no transformation of the tangent
+C angle.
+ X=X+SGN*DU
+ Y=Y+SGN*DV
+ XUS=FX(X,Y)
+ IF (XUS.LT.WXMN .OR. XUS.GT.WXMX) GO TO 50
+ YUS=FY(X,Y)
+ IF (YUS.LT.WYMN .OR. YUS.GT.WYMX) GO TO 50
+ XND=CUFX(XUS)
+ YND=CUFY(YUS)
+ TA=ATAN2(DV,DU)
+C
+ END IF
+C
+C Count the point and add it to the point buffer
+C
+ ICT=ICT+1
+ IPC=IPC+1
+ PX(IPC)=XUS
+ PY(IPC)=YUS
+C
+ IF (ICPM.LT.1) THEN
+C
+ IF (LST .EQ. 1) GO TO 50
+C
+C The increment in NDC space needs to be proportional to the
+C magnitude of the interpolated vector, in order to ensure that
+C progress checking works at points of convergence or divergence.
+C The square enhances the effectiveness of the technique.
+C
+ DUV=(DU*DU+DV*DV)/(VNML*VNML)
+ CSA=COS(TA)*SGN
+ SNA=SIN(TA)*SGN
+C
+C The current point is adjusted one third of the distance back to
+C the previous point. Empirically, in most cases, this seems to
+C decrease the inaccuracy resulting from the use of a finite valued
+C differential step.
+C
+ XN2=XN1
+ YN2=YN1
+ XN1=XND+(XN2-XND)/PTHREE
+ YN1=YND+(YN2-YND)/PTHREE
+ XND=XN1+CSA*DFMG*DUV
+ YND=YN1+SNA*DFMG*DUV
+ XD = XND - XN1
+ YD = YND - YN1
+ DST = DST + SQRT(XD*XD+YD*YD)
+C
+C If the increment takes the line outside the viewport, find an
+C interpolated point on the grid edge. Set a flag indicating
+C the end of the stream
+C
+ IF (XND .LT. XVPL) THEN
+ XND = XVPL
+ IF (ABS(CSA).GT.0.1) THEN
+ TMG = (XND-XN1)/CSA
+ YND = YN1+SNA*TMG
+ ENDIF
+ LST = 1
+ ELSE IF (XND .GT. XVPR) THEN
+ XND = XVPR
+ IF (ABS(CSA).GT.0.1) THEN
+ TMG = (XND-XN1)/CSA
+ YND = YN1+SNA*TMG
+ ENDIF
+ LST = 1
+ ELSE IF (YND .LT. YVPB) THEN
+ YND = YVPB
+ IF (ABS(SNA).GT.0.1) THEN
+ TMG = (YND-YN1)/SNA
+ XND = XN1+CSA*TMG
+ END IF
+ LST = 1
+ ELSE IF (YND .GT. YVPT) THEN
+ YND = YVPT
+ IF (ABS(SNA).GT.0.1) THEN
+ TMG = (YND-YN1)/SNA
+ XND = XN1+CSA*TMG
+ END IF
+ LST = 1
+ END IF
+C
+C Now that the new point has been found in NDC space, find its
+C coordinates in user, data, and grid space.
+C
+ XU1=XUS
+ YU1=YUS
+ XUS=CFUX(XND)
+ YUS=CFUY(YND)
+C
+C Even if the point is within NDC and User boundaries it can still be
+C outside the data area. In this case we use an iterative technique to
+C determine the end of the streamline.
+C
+ CALL HLUSTIMXY(XUS,YUS,XDA,YDA,IST)
+ IF (IST.GE.0) THEN
+ X=(XDA-XLOV)/XGDS+1.0
+ Y=(YDA-YLOV)/YGDS+1.0
+ ELSE
+ NCT=1
+C
+C Loop to this point dividing the distance in half at each step
+C
+ 120 CONTINUE
+ XT=XU1+(XUS-XU1)/2.0
+ YT=YU1+(YUS-YU1)/2.0
+ IF (NCT.GE.PMXITR) GO TO 50
+ IF (ABS(XUS-XU1).LE.PSMALL .AND.
+ + ABS(YUS-YU1).LE.PSMALL) THEN
+ XUS=XU1
+ YUS=YU1
+ CALL HLUSTIMXY(XUS,YUS,XDA,YDA,IST)
+ IF (IST.LT.0) GO TO 50
+ ELSE
+ CALL HLUSTIMXY(XT,YT,XDA,YDA,IST)
+ NCT=NCT+1
+ IF (IST.LT.0) THEN
+ XUS=XT
+ YUS=YT
+ ELSE
+ XU1=XT
+ YU1=YT
+ END IF
+ GO TO 120
+ END IF
+C
+ XND=CUFX(XUS)
+ YND=CUFY(YUS)
+ LST=1
+ END IF
+C
+C
+C If on the top or right edge of the grid space, decrease the X and/or
+C Y value by a small amount so the interpolation routine still works.
+C
+ IF (IFIX(X).GE.IXDM) X=FLOAT(IXDM)-PSMALL
+ IF (IFIX(Y).GE.IYDN) Y=FLOAT(IYDN)-PSMALL
+C
+ END IF
+C
+C Check streamline progress every 'ICKP' iterations.
+C
+ IF (MOD(ICT,ICKP).EQ.0) THEN
+ IF (ABS(XND-XNS).LT.CDS
+ + .AND. ABS(YND-YNS).LT.CDS) THEN
+ GO TO 50
+ END IF
+ XNS=XND
+ YNS=YND
+ END IF
+C
+C If the circular list does not need to be checked for
+C streamline crossover, return to the top of the main loop.
+C
+ IF (ICKX.LT.0 .OR. MOD(ICT,ICKX).NE.0) GO TO 110
+C
+ ELSE
+C
+C Must have entered a new grid box check for the following :
+C (1) Are the new points on the grid?
+C (2) Check for missing data if msg data flag (ISVF) has been set.
+C (3) Is this box eligible for a directional arrow?
+C (4) Location of this entry versus other streamline entries
+C
+ I = IFIX(X)
+ J = IFIX(Y)
+ NBX = NBX+1
+C
+C Check (1) (Only performed in compatibility mode)
+C
+ IF (ICPM.GT.0) THEN
+ IF (I.LT.IXD1 .OR. I.GT.IXM1
+ + .OR. J.LT.IYD1 .OR. J.GT.IYM1) THEN
+ GO TO 50
+ END IF
+ END IF
+C
+C Check (2)
+C
+ IF (ISVF.NE.0) THEN
+ CALL STSVCK(U,V,I,J,IST)
+ IF (IST .NE. 0) GO TO 50
+ END IF
+C
+C Check (3) -- postpone actually drawing the arrow until after the
+C crossover check, if crossover detected the arrow will not be drawn.
+C
+ IDA = 0
+ CALL GBYTES(UX(I,J),IUX,ISK,2,0,1)
+ IF (IAND(IUX,IPTWO) .EQ. 0) THEN
+ IF (DST-ADS .GT. AMD) THEN
+ ADS = DST
+ IDA = 1
+ END IF
+ END IF
+C
+ END IF
+C
+C Check (4) (performed any time streamline crossover is checked)
+C
+ DO 140 LI=1,LCU
+ IF (ABS(XND-XLS(LI)) .LE. SSP .AND.
+ + ABS(YND-YLS(LI)) .LE. SSP) THEN
+ IF (LBC.LE.LCK .AND.
+ + (LI.LT.LBC .OR. LI.GT.LCK)) THEN
+ GO TO 50
+ ELSE IF (LBC.GT.LCK .AND.
+ + (LI.LT.LBC .AND. LI.GT.LCK)) THEN
+ GO TO 50
+ END IF
+ END IF
+ 140 CONTINUE
+C
+ LCU = MIN0(LCU+1,IPLSTL)
+ LCK = LCK+1
+c IF (LCK.GT.IPLSTL)print *,'***attention LCK= ',IPLSTL
+ IF (LCK.GT.IPLSTL) LCK = 1
+ XLS(LCK) = XND
+ YLS(LCK) = YND
+ CALL SBYTES(UX(I,J),IPONE,IS1,1,0,1)
+ IF (NBX.GE.5) THEN
+ LBC = LBC+1
+ IF (LBC.GT.IPLSTL) LBC = 1
+ END IF
+C
+ IF (IDA.EQ.1) THEN
+ CALL STARDR(XUS,YUS,XND,YND,TA,IAM,STUMSL,IST)
+ IAC = IAC + 1
+ IF (IST .EQ. 0) THEN
+ CALL SBYTES(UX(I,J),IPONE,ISK,1,0,1)
+ END IF
+ IDA = 0
+ END IF
+
+C
+C Return to top of drawing loop
+C
+ GO TO 110
+C
+C
+C Final exit
+C
+ 190 CONTINUE
+C
+ IF (IZO .EQ. 1) THEN
+ CALL STZERO
+ END IF
+C
+C Plot statistics
+C
+ IF (ISST.EQ.1) THEN
+ LUN=I1MACH(2)
+ WRITE(LUN,*) 'STREAM Statistics'
+ WRITE(LUN,*) ' Streamlines plotted:',LCT
+ WRITE(LUN,*) ' Total differential step count:',ITO
+ WRITE(LUN,*) ' '
+ END IF
+C
+C Set the workspace used parameter
+C
+ IWKU = 2*IXDM*IYDN
+C
+ RETURN
+ END
+C
+C ---------------------------------------------------------------------
+C
+ SUBROUTINE STARDR(XUS,YUS,XND,YND,TA,IAM,STUMSL,IST)
+C
+C This routine draws the arrow. Calculations are in fractional
+C coordinates to ensure uniform arrows irrespective of the
+C mapping in effect.
+C A small fraction of the differential change is used to find the
+C tangent angle at the current position. Once the angle is known the
+C arrow can be drawn at a fixed size independent of the mapping
+C routine currently employed.
+C
+C Input parameters:
+C
+C XUS,YUS - current position in user space
+C XND,YND - current position in NDC space
+C TA - Angle in NDC
+C IAM - Area mask array
+C STUMSL - User defined masked streamline drawing routine
+C
+C Output parameters:
+C
+C IST - Status code, indicates success or failure
+C
+ DIMENSION IAM(*)
+ EXTERNAL STUMSL
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C ---------------------------------------------------------------------
+C
+C Point buffers
+C
+ DIMENSION AX(3), AY(3)
+C
+C Local variables
+C
+C AX, AY - Arrow head point buffers
+C DXW, DYW - Change in X,Y in window coordinates
+C XF, YF - Arrow head position in the fractional system
+C DXF,DYF - Incremental change in the fractional system
+C PHI - Tangent angle
+C K - Loop index and sign factor for each edge of the arrow
+C KK - Index for the arrow head array, within the loop
+C D30 - Half the angle of the point of the arrow head (about 30 o)
+C XX,YY - Ends of the arrow in window coordinates
+C
+C Parameters:
+C
+C PHFANG - Half the angle of the arrow head (0.5 in radians is
+C approximately equivalent to 30 degrees)
+C PLWFCT - Linewidth factor, arrow size is increased by this
+C much when the linewidth is greater than 1.0
+
+ PARAMETER (PHFANG=0.5, PLWFCT=0.15)
+C
+C ---------------------------------------------------------------------
+C
+c print *,' ++entree STARDR'
+ IST=0
+C
+ AX(2) = XUS
+ AY(2) = YUS
+ FLW = 1.0 + PLWFCT*MAX(0.0,WDLV-1.0)
+C
+ DO 10 K = -1,1,2
+C
+C K serves as a sign determining factor; KK indexes the point array.
+C
+ KK=K+2
+ D30 = -(P1D2PI-TA)+FLOAT(K)*PHFANG
+ XX = +RNDA*FLW*SIN(D30)+XND
+ YY = -RNDA*FLW*COS(D30)+YND
+ AX(KK) = CFUX(XX)
+ AY(KK) = CFUY(YY)
+C
+ 10 CONTINUE
+C
+ CALL STLNSG(AX,AY,3,IAM,STUMSL)
+
+C
+C Done
+C
+ RETURN
+ END
+C
+C ---------------------------------------------------------------------
+C
+ SUBROUTINE STLNSG(X,Y,IPC,IAM,STUMSL)
+C
+C This routine draws a single streamline segment based on the current
+C contents of the point buffers. If masking is in effect the area
+C line drawing subroutine, ARDRLN is called. Otherwise CURVE is
+C invoked.
+C
+C Input parameters:
+C
+C X,Y - Point arrays
+C IPC - Number of points
+C IAM - Area mask array
+C STUMSL - User-defined masked streamline drawing routine
+C
+ DIMENSION X(IPC), Y(IPC)
+ DIMENSION IAM(*)
+ EXTERNAL STUMSL
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+ DIMENSION IAI(IPGRCT),IAG(IPGRCT)
+ DIMENSION XO(IPNPTS), YO(IPNPTS)
+C
+C ---------------------------------------------------------------------
+C
+c print *,' ++entree STLNSG'
+ IF (IMSK.LT.1) THEN
+ CALL CURVE(X,Y,IPC)
+ CALL SFLUSH
+ ELSE
+ CALL ARDRLN(IAM, X, Y, IPC, XO, YO, IPC,
+ + IAI, IAG, IPGRCT, STUMSL)
+ END IF
+C
+C Done
+C
+ RETURN
+ END
+C
+C ---------------------------------------------------------------------
+C
+ SUBROUTINE STSVCK(U,V,I,J,IST)
+C
+ DIMENSION U(IUD1,*), V(IVD1,*)
+C
+C Checks for special values in the vicinity of I,J
+C
+C Input parameters
+C
+C U,V - vector field components array
+C I,J - current array position
+C
+C Output parameters:
+C
+C IST - status value, 0 if no special values in neighborhood
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C ---------------------------------------------------------------------
+C
+c print *,' ++entree STSVCK'
+ IST = 0
+C
+ IF (I.EQ.IXDM .OR. J.EQ.IYDN) THEN
+ IF (U(I,J).EQ.RUSV) THEN
+ IST = -1
+ ELSE IF (V(I,J).EQ.RVSV) THEN
+ IST = -1
+ END IF
+ RETURN
+ END IF
+
+ IF (U(I,J).EQ.RUSV) THEN
+ IST = -1
+ ELSE IF (U(I,J+1).EQ.RUSV) THEN
+ IST = -1
+ ELSE IF (U(I+1,J).EQ.RUSV) THEN
+ IST = -1
+ ELSE IF (U(I+1,J+1).EQ.RUSV) THEN
+ IST = -1
+ ELSE IF (V(I,J).EQ.RVSV) THEN
+ IST = -1
+ ELSE IF (V(I,J+1).EQ.RVSV) THEN
+ IST = -1
+ ELSE IF (V(I+1,J).EQ.RVSV) THEN
+ IST = -1
+ ELSE IF (V(I+1,J+1).EQ.RVSV) THEN
+ IST = -1
+ END IF
+C
+C Done
+C
+ RETURN
+ END
+C
+C ---------------------------------------------------------------------
+C
+ SUBROUTINE STMPUV(UI,VI,UO,VO,IST)
+C
+C Maps the U,V vector component values
+C
+C Input parameters:
+C
+C UI,VI - Input values of U,V
+C
+C Output parameters:
+C
+C UO,VO - Output mapped component values
+C IST - Status value
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C Statement functions for field tranformations
+C
+ FU(X,Y) = X
+ FV(X,Y) = Y
+C
+C ---------------------------------------------------------------------
+C
+c print *,' ++entree STMPUV'
+ IST = 0
+C
+C Input array polar mode
+C
+ IF (IPLR .LT. 1) THEN
+ UT=UI
+ VT=VI
+ ELSE IF (IPLR .EQ. 1) THEN
+ UT = UI*COS(PDTOR*VI)
+ VT = UI*SIN(PDTOR*VI)
+ ELSE IF (IPLR .GT. 1) THEN
+ UT = UI*COS(VI)
+ VT = UI*SIN(VI)
+ END IF
+C
+C Allow mapping using FU,FV functions
+C
+ UO = FU(UT,VT)
+ VO = FV(UT,VT)
+C
+C Done
+C
+ RETURN
+ END
+C
+C ---------------------------------------------------------------------
+C
+ SUBROUTINE STZERO
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+c print *,' ++entree STZERO'
+ IF (CZFT(1:1) .EQ. ' ') THEN
+ RETURN
+ END IF
+C
+ CALL GQPLCI(IER,IOC)
+ CALL GQTXCI(IER,IOT)
+C
+C Turn clipping off and SET to an identity transform
+C
+ CALL GQCLIP(IER,ICL,IAR)
+ CALL GSCLIP(0)
+ CALL GETSET(VPL,VPR,VPB,VPT,WDL,WDR,WDB,WDT,ILG)
+ CALL SET(0.0,1.0,0.0,1.0,0.0,1.0,0.0,1.0,1)
+C
+ XF = XVPL + FZFX * FW2W
+ YF = YVPB + FZFY * FH2H
+ CALL VVTXLN(CZFT,IPCHSZ,IB,IE)
+ CALL VVTXIQ(CZFT(IB:IE),FZFS*FW2W,W,H)
+ CALL VVTXPO(IZFP,XF,YF,W,H,XW,YW)
+ IF (IZFC .GE. 0) THEN
+ CALL GSTXCI(IZFC)
+ CALL GSPLCI(IZFC)
+ ELSE
+ CALL GSPLCI(IOT)
+ END IF
+C
+ CALL PLCHHQ(XW,YW,CZFT(IB:IE),FZFS*FW2W,0.0,0.0)
+C
+ CALL GSTXCI(IOT)
+ CALL GSPLCI(IOC)
+C
+C Restore clipping and the set transformation.
+C
+ CALL GSCLIP(ICL)
+ CALL SET(VPL,VPR,VPB,VPT,WDL,WDR,WDB,WDT,ILG)
+C
+C Done
+C
+ RETURN
+ END
+
+
+
+C
+C $Id$
+C
+ SUBROUTINE STDUDV (UX,VY,I,J,X,Y,DU,DV)
+C
+C Input parameters:
+C
+C UX,VY - the arrays containing normalized vector field data
+C I,J - the current grid indices
+C X,Y - the X,Y position relative to the grid
+C
+C Output parameters:
+C
+C DU,DV - Interpolated value of the vector field components
+C at the specified point
+C
+C Interpolation routine to calculate the displacemant components.
+C The philosphy here is to utilize as many points as possible
+C (within reason) in order to obtain a pleasing and accurate plot.
+C Interpolation schemes desired by other users may easily be
+C substituted if desired.
+C
+ DIMENSION UX(IXDM,*), VY(IXDM,*)
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C FDLI - Double linear interpolation formula
+C FBESL - Bessel 16 pt interpolation formula ( most used formula )
+C FQUAD - Quadratic interpolation formula
+C
+ FDLI(Z,Z1,Z2,Z3,DX,DY) = (1.-DX)*((1.-DY)*Z +DY*Z1)
+ + + DX *((1.-DY)*Z2+DY*Z3)
+ FBESL(Z,ZP1,ZP2,ZM1,DZ)=Z+DZ*(ZP1-Z+0.25*(DZ-1.)*((ZP2-ZP1-Z+ZM1)
+ + +0.666667*(DZ-0.5)*(ZP2-3.*ZP1+3.*Z-ZM1)))
+ FQUAD(Z,ZP1,ZM1,DZ)=Z+0.5*DZ*(ZP1-ZM1+DZ*(ZP1-2.*Z+ZM1))
+C
+C ---------------------------------------------------------------------
+C
+c print *,' ++entree STDUDV'
+ DX = X-AINT(X)
+ DY = Y-AINT(Y)
+ ITF = 1
+ IM1 = I-1
+ IP2 = I+2
+C
+C Determine which interpolation formula to use
+C depending on I,J location or the special flags
+C
+ IF (I.GE.IXDM .OR. J.GE.IYDN) THEN
+C
+C This branch should never be taken if STDRAW is correct, but is
+C included for safety
+C
+ RETURN
+C
+ ELSE IF(ISVF.NE.0 .OR. ITRP.NE.0) THEN
+ ITF = 1
+ ELSE IF (J.GT.IYD1 .AND. J.LT.IYM1
+ + .AND. I.GT.IXD1 .AND. I.LT.IXM1) THEN
+ ITF = 2
+ ELSE IF (J.EQ.IYM1 .AND. I.GT.IXD1 .AND. I.LT.IXM1) THEN
+ ITF = 3
+ ELSE IF (J.EQ.IYD1) THEN
+ ITF = 1
+ ELSE IF (ICYK.NE.1) THEN
+ IF (I.EQ.IXD1) THEN
+ ITF = 1
+ ELSE IF (I.EQ.IXM1) THEN
+ ITF = 4
+ END IF
+ ELSE IF (I.EQ.IXD1 .AND. J.LT.IYM1) THEN
+ IM1 = IXM1
+ ITF = 2
+ ELSE IF (I.EQ.IXM1 .AND. J.LT.IYM1) THEN
+ IP2 = IXD1+1
+ ITF = 2
+ ELSE IF (J.EQ.IYM1 .AND. I.EQ.IXD1) THEN
+ IM1 = IXM1
+ ITF = 3
+ ELSE IF (J.EQ.IYM1 .AND. I.EQ.IXM1) THEN
+ IP2 = IXD1+1
+ ITF = 3
+ END IF
+C
+ IF (ITF .EQ. 1) THEN
+C
+C Double linear interpolation formula. This scheme works at all points
+C but the resulting streamlines are not as pleasing as those drawn
+C by FBESL or FQUAD. Currently this is utilized
+C only at certain boundary points or if ITRP is not equal to zero,
+C or if special value processing is turned on.
+C
+ DU = FDLI(UX(I,J),UX(I,J+1),UX(I+1,J),UX(I+1,J+1),DX,DY)
+ DV = FDLI(VY(I,J),VY(I,J+1),VY(I+1,J),VY(I+1,J+1),DX,DY)
+C
+ ELSE IF (ITF .EQ. 2) THEN
+C
+C 16 point bessel interpolation scheme.
+C
+ UJM1 = FBESL(UX(I,J-1),UX(I+1,J-1),UX(IP2,J-1),UX(IM1,J-1),DX)
+ UJ = FBESL(UX(I,J),UX(I+1,J),UX(IP2,J),UX(IM1,J),DX)
+ UJP1 = FBESL(UX(I,J+1),UX(I+1,J+1),UX(IP2,J+1),UX(IM1,J+1),DX)
+ UJP2 = FBESL(UX(I,J+2),UX(I+1,J+2),UX(IP2,J+2),UX(IM1,J+2),DX)
+ DU = FBESL(UJ,UJP1,UJP2,UJM1,DY)
+ VJM1 = FBESL(VY(I,J-1),VY(I+1,J-1),VY(IP2,J-1),VY(IM1,J-1),DX)
+ VJ = FBESL(VY(I,J),VY(I+1,J),VY(IP2,J),VY(IM1,J),DX)
+ VJP1 = FBESL(VY(I,J+1),VY(I+1,J+1),VY(IP2,J+1),VY(IM1,J+1),DX)
+ VJP2 = FBESL(VY(I,J+2),VY(I+1,J+2),VY(IP2,J+2),VY(IM1,J+2),DX)
+ DV = FBESL(VJ,VJP1,VJP2,VJM1,DY)
+C
+ ELSE IF (ITF .EQ. 3) THEN
+C
+C 12 point interpolation scheme applicable to one row from top boundary
+C
+ UJM1 = FBESL(UX(I,J-1),UX(I+1,J-1),UX(IP2,J-1),UX(IM1,J-1),DX)
+ UJ = FBESL(UX(I,J),UX(I+1,J),UX(IP2,J),UX(IM1,J),DX)
+ UJP1 = FBESL(UX(I,J+1),UX(I+1,J+1),UX(IP2,J+1),UX(IM1,J+1),DX)
+ DU = FQUAD(UJ,UJP1,UJM1,DY)
+ VJM1 = FBESL(VY(I,J-1),VY(I+1,J-1),VY(IP2,J-1),VY(IM1,J-1),DX)
+ VJ = FBESL(VY(I,J),VY(I+1,J),VY(IP2,J),VY(IM1,J),DX)
+ VJP1 = FBESL(VY(I,J+1),VY(I+1,J+1),VY(IP2,J+1),VY(IM1,J+1),DX)
+ DV = FQUAD(VJ,VJP1,VJM1,DY)
+C
+ ELSE IF (ITF .EQ. 4) THEN
+C
+C 9 point interpolation scheme for use in the non-cyclic case
+C at I=IXM1; J > IYD1 and J <= IYM1
+C
+ UJP1 = FQUAD(UX(I,J+1),UX(I+1,J+1),UX(IM1,J+1),DX)
+ UJ = FQUAD(UX(I,J),UX(I+1,J),UX(IM1,J),DX)
+ UJM1 = FQUAD(UX(I,J-1),UX(I+1,J-1),UX(IM1,J-1),DX)
+ DU = FQUAD(UJ,UJP1,UJM1,DY)
+ VJP1 = FQUAD(VY(I,J+1),VY(I+1,J+1),VY(IM1,J+1),DX)
+ VJ = FQUAD(VY(I,J),VY(I+1,J),VY(IM1,J),DX)
+ VJM1 = FQUAD(VY(I,J-1),VY(I+1,J-1),VY(IM1,J-1),DX)
+ DV = FQUAD(VJ,VJP1,VJM1,DY)
+C
+ END IF
+C
+C Done
+C
+ RETURN
+ END
+C
+C
+C
+C-----------------------------------------------------------------------
+C
+ SUBROUTINE STGETC (CNM,CVL)
+C
+ CHARACTER*(*) CNM,CVL
+C
+C This subroutine is called to retrieve the character value of a
+C specified parameter.
+C
+C CNM is the name of the parameter whose value is to be retrieved.
+C
+C CVL is a character variable in which the desired value is to be
+C returned by STGETC.
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C ---------------------------------------------------------------------
+C
+C Check for a parameter name that is too short.
+C
+c print *,' ++entree STGETC'
+ IF (LEN(CNM).LT.3) THEN
+ CSTR(1:36)='STGETC - PARAMETER NAME TOO SHORT - '
+ CSTR(37:36+LEN(CNM))=CNM
+ CALL SETER (CSTR(1:36+LEN(CNM)),1,1)
+ RETURN
+ END IF
+C
+C Get the proper parameter.
+C
+ IF (CNM(1:3).EQ.'ZFT'.OR.CNM(1:3).EQ.'zft') THEN
+ CALL VVTXLN(CZFT,IPCHSZ,IB,IE)
+ CVL=CZFT(IB:IE)
+ ELSE
+C
+ CSTR(1:36)='STGETC - PARAMETER NAME NOT KNOWN - '
+ CSTR(37:39)=CNM(1:3)
+ CALL SETER (CSTR(1:39),3,1)
+ RETURN
+C
+ END IF
+C
+C
+C Done.
+C
+ RETURN
+C
+ END
+C
+C $Id$
+C
+C
+C-----------------------------------------------------------------------
+C
+ SUBROUTINE STGETR (CNM,RVL)
+C
+ CHARACTER*(*) CNM
+C
+C This subroutine is called to retrieve the real value of a specified
+C parameter.
+C
+C CNM is the name of the parameter whose value is to be retrieved.
+C
+C RVL is a real variable in which the desired value is to be returned
+C by STGETR.
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C ---------------------------------------------------------------------
+C
+C Check for a parameter name that is too short.
+C
+c print *,' ++entree STGETR'
+ IF (LEN(CNM).LT.3) THEN
+ CSTR(1:46)='STGETI OR STGETR - PARAMETER NAME TOO SHORT - '
+ CSTR(47:46+LEN(CNM))=CNM
+ CALL SETER (CSTR(1:46+LEN(CNM)),1,1)
+ RETURN
+ END IF
+C
+C Check for incorrect use of the index parameter.
+C
+ IF (CNM(1:3).EQ.'CLR'.OR.CNM(1:3).EQ.'clr'
+ + .OR.CNM(1:3).EQ.'TVL'.OR.CNM(1:3).EQ.'tvl') THEN
+ IF (IPAI.LT.1.OR.IPAI.GT.NLVL) THEN
+ CSTR(1:46)='STGETI OR STGETR - GETTING XXX - PAI INCORRECT'
+ CSTR(28:30)=CNM(1:3)
+ CALL SETER (CSTR(1:46),2,1)
+ RETURN
+ END IF
+ END IF
+C
+C Get the appropriate parameter value.
+C
+C ---------------------------------------------------------------------
+C
+C Values in STPAR
+C
+ IF (CNM(1:3).EQ.'UD1'.OR. CNM(1:3).EQ.'ud1') THEN
+ RVL=REAL(IUD1)
+ ELSE IF (CNM(1:3).EQ.'VD1'.OR. CNM(1:3).EQ.'vd1') THEN
+ RVL=REAL(IVD1)
+ ELSE IF (CNM(1:3).EQ.'PD1'.OR. CNM(1:3).EQ.'pd1') THEN
+ RVL=REAL(IPD1)
+ ELSE IF (CNM(1:3).EQ.'XD1'.OR. CNM(1:3).EQ.'xd1') THEN
+ RVL=REAL(IXD1)
+ ELSE IF (CNM(1:3).EQ.'XDM'.OR. CNM(1:3).EQ.'xdm') THEN
+ RVL=REAL(IXDM)
+ ELSE IF (CNM(1:3).EQ.'YD1'.OR. CNM(1:3).EQ.'yd1') THEN
+ RVL=REAL(IYD1)
+ ELSE IF (CNM(1:3).EQ.'YDN'.OR. CNM(1:3).EQ.'ydn') THEN
+ RVL=REAL(IYDN)
+ ELSE IF (CNM(1:3).EQ.'WKD'.OR.CNM(1:3).EQ.'wkd') THEN
+ RVL=REAL(IWKD)
+ ELSE IF (CNM(1:3).EQ.'WKU'.OR.CNM(1:3).EQ.'wku') THEN
+ RVL=REAL(IWKU)
+ ELSE IF (CNM(1:3).EQ.'SET'.OR. CNM(1:3).EQ.'set') THEN
+ RVL=REAL(ISET)
+ ELSE IF (CNM(1:3).EQ.'ERR'.OR. CNM(1:3).EQ.'err') THEN
+ RVL=REAL(IERR)
+ ELSE IF (CNM(1:3).EQ.'XIN'.OR.CNM(1:3).EQ.'xin') THEN
+ RVL=IXIN
+ ELSE IF (CNM(1:3).EQ.'YIN'.OR.CNM(1:3).EQ.'yin') THEN
+ RVL=IYIN
+ ELSE IF (CNM(1:3).EQ.'MSK'.OR. CNM(1:3).EQ.'msk') THEN
+ RVL=REAL(IMSK)
+ ELSE IF (CNM(1:3).EQ.'CPM'.OR. CNM(1:3).EQ.'cpm') THEN
+ RVL=REAL(ICPM)
+ ELSE IF (CNM(1:3).EQ.'NLV'.OR.CNM(1:3).EQ.'nlv') THEN
+ RVL=REAL(NLVL)
+ ELSE IF (CNM(1:3).EQ.'PAI'.OR.CNM(1:3).EQ.'pai') THEN
+ RVL=REAL(IPAI)
+ ELSE IF (CNM(1:3).EQ.'CTV'.OR.CNM(1:3).EQ.'ctv') THEN
+ RVL=REAL(ICTV)
+ ELSE IF (CNM(1:3).EQ.'LWD'.OR.CNM(1:3).EQ.'lwd') THEN
+ RVL=WDLV
+ ELSE IF (CNM(1:3).EQ.'VMN'.OR.CNM(1:3).EQ.'vmn') THEN
+ RVL=UVMN
+ ELSE IF (CNM(1:3).EQ.'VMX'.OR.CNM(1:3).EQ.'vmx') THEN
+ RVL=UVMX
+ ELSE IF (CNM(1:3).EQ.'PMN'.OR.CNM(1:3).EQ.'pmn') THEN
+ RVL=PMIN
+ ELSE IF (CNM(1:3).EQ.'PMX'.OR.CNM(1:3).EQ.'pmx') THEN
+ RVL=PMAX
+ ELSE IF (CNM(1:3).EQ.'THN'.OR. CNM(1:3).EQ.'thn') THEN
+ RVL=REAL(ITHN)
+ ELSE IF (CNM(1:3).EQ.'PLR'.OR. CNM(1:3).EQ.'plr') THEN
+ RVL=REAL(IPLR)
+ ELSE IF (CNM(1:3).EQ.'SST'.OR. CNM(1:3).EQ.'sst') THEN
+ RVL=REAL(ISST)
+ ELSE IF (CNM(1:3).EQ.'CLR'.OR.CNM(1:3).EQ.'clr') THEN
+ RVL=REAL(ICLR(IPAI))
+ ELSE IF (CNM(1:3).EQ.'TVL'.OR.CNM(1:3).EQ.'tvl') THEN
+ RVL=TVLU(IPAI)
+C
+C ---------------------------------------------------------------------
+C
+C Values in STTRAN
+C
+ ELSE IF (CNM(1:3).EQ.'VPS'.OR. CNM(1:3).EQ.'vps') THEN
+ RVL=REAL(UVPS)
+ ELSE IF (CNM(1:3).EQ.'VPL'.OR.CNM(1:3).EQ.'vpl') THEN
+ RVL=UVPL
+ ELSE IF (CNM(1:3).EQ.'VPR'.OR.CNM(1:3).EQ.'vpr') THEN
+ RVL=UVPR
+ ELSE IF (CNM(1:3).EQ.'VPB'.OR.CNM(1:3).EQ.'vpb') THEN
+ RVL=UVPB
+ ELSE IF (CNM(1:3).EQ.'VPT'.OR.CNM(1:3).EQ.'vpt') THEN
+ RVL=UVPT
+ ELSE IF (CNM(1:3).EQ.'WDL'.OR.CNM(1:3).EQ.'wdl') THEN
+ RVL=UWDL
+ ELSE IF (CNM(1:3).EQ.'WDR'.OR.CNM(1:3).EQ.'wdr') THEN
+ RVL=UWDR
+ ELSE IF (CNM(1:3).EQ.'WDB'.OR.CNM(1:3).EQ.'wdb') THEN
+ RVL=UWDB
+ ELSE IF (CNM(1:3).EQ.'WDT'.OR.CNM(1:3).EQ.'wdt') THEN
+ RVL=UWDT
+ ELSE IF (CNM(1:3).EQ.'XC1'.OR.CNM(1:3).EQ.'xc1') THEN
+ RVL=UXC1
+ ELSE IF (CNM(1:3).EQ.'XCM'.OR.CNM(1:3).EQ.'xcm') THEN
+ RVL=UXCM
+ ELSE IF (CNM(1:3).EQ.'YC1'.OR.CNM(1:3).EQ.'yc1') THEN
+ RVL=UYC1
+ ELSE IF (CNM(1:3).EQ.'YCN'.OR.CNM(1:3).EQ.'ycn') THEN
+ RVL=UYCN
+C
+C ---------------------------------------------------------------------
+C
+C Values in STSTRM
+C
+ ELSE IF (CNM(1:3).EQ.'SGD'.OR. CNM(1:3).EQ.'sgd') THEN
+ RVL=REAL(ISGD)
+ ELSE IF (CNM(1:3).EQ.'AGD'.OR. CNM(1:3).EQ.'agd') THEN
+ RVL=REAL(IAGD)
+ ELSE IF (CNM(1:3).EQ.'ARL'.OR. CNM(1:3).EQ.'arl') THEN
+ RVL=RARL
+ ELSE IF (CNM(1:3).EQ.'CKP'.OR. CNM(1:3).EQ.'ckp') THEN
+ RVL=REAL(ICKP)
+ ELSE IF (CNM(1:3).EQ.'CKX'.OR. CNM(1:3).EQ.'ckx') THEN
+ RVL=REAL(ICKX)
+ ELSE IF (CNM(1:3).EQ.'TRP'.OR. CNM(1:3).EQ.'trp') THEN
+ RVL=REAL(ITRP)
+ ELSE IF (CNM(1:3).EQ.'CYK'.OR. CNM(1:3).EQ.'cyk') THEN
+ RVL=REAL(ICYK)
+ ELSE IF (CNM(1:3).EQ.'VNL'.OR. CNM(1:3).EQ.'vnl') THEN
+ RVL=RVNL
+ ELSE IF (CNM(1:3).EQ.'SVF'.OR. CNM(1:3).EQ.'svf') THEN
+ RVL=REAL(ISVF)
+ ELSE IF (CNM(1:3).EQ.'USV'.OR. CNM(1:3).EQ.'usv') THEN
+ RVL=RUSV
+ ELSE IF (CNM(1:3).EQ.'VSV'.OR. CNM(1:3).EQ.'vsv') THEN
+ RVL=RVSV
+ ELSE IF (CNM(1:3).EQ.'PSV'.OR. CNM(1:3).EQ.'psv') THEN
+ RVL=RPSV
+ ELSE IF (CNM(1:3).EQ.'SPC'.OR. CNM(1:3).EQ.'spc') THEN
+ RVL=REAL(ISPC)
+ ELSE IF (CNM(1:3).EQ.'CDS'.OR. CNM(1:3).EQ.'cds') THEN
+ RVL=RCDS
+ ELSE IF (CNM(1:3).EQ.'SSP'.OR. CNM(1:3).EQ.'ssp') THEN
+ RVL=RSSP
+ ELSE IF (CNM(1:3).EQ.'DFM'.OR. CNM(1:3).EQ.'dfm') THEN
+ RVL=RDFM
+ ELSE IF (CNM(1:3).EQ.'SMD'.OR. CNM(1:3).EQ.'smd') THEN
+ RVL=RSMD
+ ELSE IF (CNM(1:3).EQ.'AMD'.OR. CNM(1:3).EQ.'amd') THEN
+ RVL=RAMD
+ ELSE IF (CNM(1:3).EQ.'GBS'.OR. CNM(1:3).EQ.'gbs') THEN
+ RVL=REAL(IGBS)
+C
+C ---------------------------------------------------------------------
+C
+C Values in STTXP
+C
+C character attributes
+C
+C
+ ELSE IF (CNM(1:3).EQ.'ZFS'.OR.CNM(1:3).EQ.'zfs') THEN
+ RVL=FZFS
+ ELSE IF (CNM(1:3).EQ.'ZFX'.OR.CNM(1:3).EQ.'zfx') THEN
+ RVL=FZFX
+ ELSE IF (CNM(1:3).EQ.'ZFY'.OR.CNM(1:3).EQ.'zfy') THEN
+ RVL=FZFY
+ ELSE IF (CNM(1:3).EQ.'ZFP'.OR. CNM(1:3).EQ.'zfp') THEN
+ RVL=REAL(IZFP)
+ ELSE IF (CNM(1:3).EQ.'ZFC'.OR. CNM(1:3).EQ.'zfc') THEN
+ RVL=REAL(IZFC)
+C
+C ---------------------------------------------------------------------
+C
+C Values in STMAP
+C
+ ELSE IF (CNM(1:3).EQ.'MAP'.OR. CNM(1:3).EQ.'map') THEN
+ RVL=REAL(IMAP)
+ ELSE IF (CNM(1:3).EQ.'TRT'.OR. CNM(1:3).EQ.'trt') THEN
+ RVL=REAL(ITRT)
+ ELSE IF (CNM(1:3).EQ.'VPL'.OR.CNM(1:3).EQ.'vpl') THEN
+ RVL=XVPL
+ ELSE IF (CNM(1:3).EQ.'VPR'.OR.CNM(1:3).EQ.'vpr') THEN
+ RVL=XVPR
+ ELSE IF (CNM(1:3).EQ.'VPB'.OR.CNM(1:3).EQ.'vpb') THEN
+ RVL=YVPB
+ ELSE IF (CNM(1:3).EQ.'VPT'.OR.CNM(1:3).EQ.'vpt') THEN
+ RVL=YVPT
+ ELSE IF (CNM(1:3).EQ.'XMN'.OR.CNM(1:3).EQ.'xmn') THEN
+ RVL=WXMN
+ ELSE IF (CNM(1:3).EQ.'XMX'.OR.CNM(1:3).EQ.'xmx') THEN
+ RVL=WXMX
+ ELSE IF (CNM(1:3).EQ.'YMN'.OR.CNM(1:3).EQ.'ymn') THEN
+ RVL=WYMN
+ ELSE IF (CNM(1:3).EQ.'YMX'.OR.CNM(1:3).EQ.'ymx') THEN
+ RVL=WYMX
+ ELSE IF (CNM(1:3).EQ.'XLV'.OR.CNM(1:3).EQ.'xlv') THEN
+ RVL=XLOV
+ ELSE IF (CNM(1:3).EQ.'XHV'.OR.CNM(1:3).EQ.'xhv') THEN
+ RVL=XHIV
+ ELSE IF (CNM(1:3).EQ.'YLV'.OR.CNM(1:3).EQ.'ylv') THEN
+ RVL=YLOV
+ ELSE IF (CNM(1:3).EQ.'YHV'.OR.CNM(1:3).EQ.'yhv') THEN
+ RVL=YHIV
+ ELSE IF (CNM(1:3).EQ.'NXC'.OR. CNM(1:3).EQ.'nxc') THEN
+ RVL=REAL(NXCT)
+ ELSE IF (CNM(1:3).EQ.'NYC'.OR. CNM(1:3).EQ.'nyc') THEN
+ RVL=REAL(NYCT)
+ ELSE IF (CNM(1:3).EQ.'LLG'.OR. CNM(1:3).EQ.'llg') THEN
+ RVL=REAL(LNLG)
+ ELSE IF (CNM(1:3).EQ.'IVX'.OR. CNM(1:3).EQ.'ivx') THEN
+ RVL=REAL(INVX)
+ ELSE IF (CNM(1:3).EQ.'IVY'.OR. CNM(1:3).EQ.'ivy') THEN
+ RVL=REAL(INVY)
+ ELSE IF (CNM(1:3).EQ.'RBG'.OR. CNM(1:3).EQ.'rbg') THEN
+ RVL=REAL(RBIG)
+ ELSE IF (CNM(1:3).EQ.'IBG'.OR. CNM(1:3).EQ.'ibg') THEN
+ RVL=REAL(IBIG)
+C
+C ---------------------------------------------------------------------
+C
+ ELSE
+ CSTR(1:46)='STGETI OR STGETR - PARAMETER NAME NOT KNOWN - '
+ CSTR(47:49)=CNM(1:3)
+ CALL SETER (CSTR(1:49),3,1)
+ RETURN
+ END IF
+C
+C Done.
+C
+ RETURN
+C
+ END
+C
+C $Id$
+C
+ SUBROUTINE STREAM (U,V,P,IAM,STUMSL,WRK)
+C
+ DIMENSION U(IUD1,*), V(IVD1,*), P(IPD1,*), IAM(*), WRK(*)
+C
+ EXTERNAL STUMSL
+C
+C Input parameters:
+C
+C U,V - arrays containing vector field data
+C P - 2-d scalar data array. (dummy - not implemented yet)
+C IAM - An area map array, may be dummied if 'MSK' is zero
+C STUMSL - User modifiable masked drawing function; also may
+C be dummied if 'MSK is zero
+C WRK - workspace
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C -----------------------------------------------------------------
+C
+C Check for valid area map and area group overflow if masking is enabled
+C
+c print *,' ++entree STREAM'
+ IF (IMSK.GT.0) THEN
+ IF (IAM(7).GT.IPGRCT) THEN
+ CSTR(1:29)='STREAM - TOO MANY AREA GROUPS'
+ CALL SETER (CSTR(1:29),1,1)
+ RETURN
+ END IF
+ IF (IAM(7).LE.0) THEN
+ CSTR(1:25)='STREAM - INVALID AREA MAP'
+ CALL SETER (CSTR(1:29),2,1)
+ RETURN
+ END IF
+ END IF
+C
+C Save the line color, text color and linewidth.
+C Then set up the new linewidth values
+C
+ CALL GQPLCI(IER,IOC)
+ CALL GQTXCI(IER,IOT)
+ CALL GQLWSC(IER,ROW)
+ CALL GSLWSC(WDLV)
+C
+C Calculation of NDC sizing values varies based on whether grid
+C relative sizing is in effect.
+C
+ IF (IGBS .EQ. 0) THEN
+ RNDA=RARL*FW2W
+ DFMG=RDFM*FW2W
+ ELSE
+ RNDA=RARL*FW2W/REAL(IXDM)
+ DFMG=RDFM*FW2W/REAL(IXDM)
+ END IF
+C
+C If not using the FX,FY routines, then the vector normalization
+C value is fixed.
+C
+ IF (ICPM.LT.1) THEN
+ VNML=0.3333333
+ ELSE
+ VNML=RVNL
+ END IF
+C
+C Draw the streamlines.
+C Break the work array into two parts. See STDRAW for further
+C comments on this.
+C
+ CALL STDRAW (U,V,WRK(1),WRK(IXDM*IYDN+1),IAM,STUMSL)
+C
+C Reset the polyline color, text color, and the linewidth
+C
+ CALL GSPLCI(IOC)
+ CALL GSLWSC(ROW)
+ CALL GSTXCI(IOT)
+C
+ RETURN
+ END
+C
+C --------------------------------------------------------------------
+C Original disucussion of the STRMLN algorithm follows:
+C
+C HISTORY Written and standardized in November 1973.
+C
+C Converted to FORTRAN 77 and GKS in June, 1984.
+C
+C
+C PORTABILITY FORTRAN 77
+C
+C ALGORITHM Wind components are normalized to the value
+C of DISPL. The least significant two
+C bits of the work array are
+C utilized as flags for each grid box. Flag 1
+C indicates whether any streamline has
+C previously passed through this box. Flag 2
+C indicates whether a directional arrow has
+C already appeared in a box. Judicious use
+C of these flags prevents overcrowding of
+C streamlines and directional arrows.
+C Experience indicates that a final pleasing
+C picture is produced when streamlines are
+C initiated in the center of a grid box. The
+C streamlines are drawn in one direction then
+C in the opposite direction.
+C
+C REFERENCE The techniques utilized here are described
+C in an article by Thomas Whittaker (U. of
+C Wisconsin) which appeared in the notes and
+C correspondence section of Monthly Weather
+C Review, June 1977.
+C
+C TIMING Highly variable
+C It depends on the complexity of the
+C flow field and the parameters: DISPL,
+C DISPC , CSTOP , INITA , INITB , ITERC ,
+C and IGFLG. (See below for a discussion
+C of these parameters.) If all values
+C are default, then a simple linear
+C flow field for a 40 x 40 grid will
+C take about 0.4 seconds on the CRAY1-A;
+C a fairly complex flow field will take about
+C 1.5 seconds on the CRAY1-A.
+C
+C
+C INTERNAL PARAMETERS
+C
+C NAME DEFAULT FUNCTION
+C ---- ------- --------
+C
+C EXT 0.25 Lengths of the sides of the
+C plot are proportional to
+C IPTSX and JPTSY except in
+C the case when MIN(IPTSX,JPT)
+C / MAX(IPTSX,JPTSY) .LT. EXT;
+C in that case a square
+C graph is plotted.
+C
+C SIDE 0.90 Length of longer edge of
+C plot. (See also EXT.)
+C
+C XLT 0.05 Left hand edge of the plot.
+C (0.0 = left edge of frame)
+C (1.0 = right edge of frame)
+C
+C YBT 0.05 Bottom edge of the plot.
+C (0.0 = bottom ; 1.0 = top)
+C
+C (YBT+SIDE and XLT+SIDE must
+C be .LE. 1. )
+C
+C INITA 2 Used to precondition grid
+C boxes to be eligible to
+C start a streamline.
+C For example, a value of 4
+C means that every fourth
+C grid box is eligible ; a
+C value of 2 means that every
+C other grid box is eligible.
+C (see INITB)
+C
+C INITB 2 Used to precondition grid
+C boxes to be eligible for
+C direction arrows.
+C If the user changes the
+C default values of INITA
+C and/or INITB, it should
+C be done such that
+C MOD(INITA,INITB) = 0 .
+C For a dense grid try
+C INITA=4 and INITB=2 to
+C reduce the CPU time.
+C
+C AROWL 0.33 Length of direction arrow.
+C For example, 0.33 means
+C each directional arrow will
+C take up a third of a grid
+C box.
+C
+C ITERP 35 Every 'ITERP' iterations
+C the streamline progress
+C is checked.
+C
+C ITERC -99 The default value of this
+C parameter is such that
+C it has no effect on the
+C code. When set to some
+C positive value, the program
+C will check for streamline
+C crossover every 'ITERC'
+C iterations. (The routine
+C currently does this every
+C time it enters a new grid
+C box.)
+C Caution: When this
+C parameter is activated,
+C CPU time will increase.
+C
+C IGFLG 0 A value of zero means that
+C the sixteen point Bessel
+C Interpolation Formula will
+C be utilized where possible;
+C when near the grid edges,
+C quadratic and bi-linear
+C interpolation will be
+C used. This mixing of
+C interpolation schemes can
+C sometimes cause slight
+C raggedness near the edges
+C of the plot. If IGFLG.NE.0,
+C then only the bilinear
+C interpolation formula
+C is used; this will generally
+C result in slightly faster
+C plot times but a less
+C pleasing plot.
+C
+C IMSG 0 If zero, then no missing
+C U and V components are
+C present.
+C If .NE. 0, STRMLN will
+C utilize the
+C bi-linear interpolation
+C scheme and terminate if
+C any data points are missing.
+C
+C UVMSG 1.E+36 Value assigned to a missing
+C point.
+C
+C ICYC 0 Zero means the data are
+C non-cyclic in the X
+C direction.
+C If .NE 0, the
+C cyclic interpolation
+C formulas will be used.
+C (Note: Even if the data
+C are cyclic in X, leaving
+C ICYC = 0 will do no harm.)
+C
+C DISPL 0.33 The wind speed is
+C normalized to this value.
+C (See the discussion below.)
+C
+C DISPC 0.67 The critical displacement.
+C If after 'ITERP' iterations
+C the streamline has not
+C moved this distance, the
+C streamline will be
+C terminated.
+C
+C CSTOP 0.50 This parameter controls
+C the spacing between
+C streamlines. The checking
+C is done when a new grid
+C box is entered.
+C
+C DISCUSSION OF Assume a value of 0.33 for DISPL. This
+C DISPL,DISPC means that it will take three steps to move
+C AND CSTOP across one grid box if the flow was all in the
+C X direction. If the flow is zonal, then a
+C larger value of DISPL is in order.
+C If the flow is highly turbulent, then
+C a smaller value is in order. The smaller
+C DISPL, the more the CPU time. A value
+C of 2 to 4 times DISPL is a reasonable value
+C for DISPC. DISPC should always be greater
+C than DISPL. A value of 0.33 for CSTOP would
+C mean that a maximum of three stream-
+C lines will be drawn per grid box. This max
+C will normally only occur in areas of singular
+C points.
+C
+C ***************************
+C Any or all of the above
+C parameters may be changed
+C by utilizing common blocks
+C STR02 and/or STR03
+C ***************************
+C
+C UXSML A number which is small
+C compared to the average
+C normalized u component.
+C Set automatically.
+C
+C NCHK 750 This parameter is located
+C in STDRAW. It specifies the
+C length of the circular
+C lists used for checking
+C for STRMLN crossovers.
+C For most plots this number
+C may be reduced to 500
+C or less and the plots will
+C not be altered.
+C
+C ISKIP Number of bits to be
+C skipped to get to the
+C least two significant bits
+C in a floating point number.
+C The default value is set to
+C I1MACH(5) - 2 . This value
+C may have to be changed
+C depending on the target
+C computer; see subroutine
+C STDRAW.
+C
+C --------------------------------------------------------------------
+C
+C $Id$
+C
+C
+C-----------------------------------------------------------------------
+C
+ SUBROUTINE STRSET
+C
+C This subroutine may be called to reset all variables which have
+C default values to those values.
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C ---------------------------------------------------------------------
+C
+C Reset individual parameters.
+C
+C Common block STPAR
+C
+c print *,' ++entree STRSET'
+ IUD1 = -1
+ IVD1 = -1
+ IPD1 = -1
+ IXD1 = 1
+ IXDM = -1
+ IYD1 = 1
+ IYDN = -1
+ IWKD = -1
+ IWKU = 0
+ ISET = 1
+ IERR = 0
+ IXIN = 1
+ IYIN = 1
+ IMSK = 0
+ ICPM = 0
+ NLVL = 0
+ IPAI = 1
+ ICTV = 0
+ WDLV = 1.0
+ UVMN = 0.0
+ UVMX = 0.0
+ PMIN = 0.0
+ PMAX = 0.0
+ ITHN = 0
+ IMAP = 0
+ IPLR = 0
+ ISST = 0
+C
+C Parameter arrays
+C
+ DO 101 I=1,IPLVLS,1
+ ICLR(I) = 1
+ TVLU(I) = 0.0
+ 101 CONTINUE
+C
+C
+C ---------------------------------------------------------------------
+C
+C STTRAN
+C
+ UVPS = 0.25
+ UVPL = 0.05
+ UVPR = 0.95
+ UVPB = 0.05
+ UVPT = 0.95
+ UWDL = 0.0
+ UWDR = 0.0
+ UWDB = 0.0
+ UWDT = 0.0
+ UXC1 = 0.0
+ UXCM = 0.0
+ UYC1 = 0.0
+ UYCN = 0.0
+C
+C ---------------------------------------------------------------------
+C
+C STSTRM
+C
+ ISGD = 2
+ IAGD = 2
+ RARL = 0.012
+ ICKP = 35
+ ICKX = -99
+ ITRP = 0
+ ICYK = 0
+ RVNL = 0.33
+ ISVF = 0
+ RUSV = 1.0E12
+ RVSV = 1.0E12
+ RPSV = 1.0E12
+ ISPC = -1
+ RCDS = 2.0
+ RSSP = 0.015
+ RDFM = 0.02
+ RSMD = 0.0
+ RAMD = 0.0
+ IGBS = 0
+C
+C ---------------------------------------------------------------------
+C
+C
+ FZFS = 0.033
+ FZFX = 0.5
+ FZFY = 0.5
+ IZFP = 0
+ IZFC = -1
+C
+C ---------------------------------------------------------------------
+C
+C STCHAR values
+C
+ CZFT = 'ZERO FIELD'
+C
+C ---------------------------------------------------------------------
+C
+C STMAP values
+C
+ IMAP = 0
+ ITRT = 1
+ IBIG = I1MACH(9)
+ RBIG = R1MACH(2)
+C
+C ---------------------------------------------------------------------
+C
+C Done
+C
+ RETURN
+C
+ END
+C
+C
+C
+C-----------------------------------------------------------------------
+C
+ SUBROUTINE STSETC (CNM,CVL)
+C
+ CHARACTER*(*) CNM,CVL
+C
+C This subroutine is called to give a specified character value to a
+C specified parameter.
+C
+C CNM is the name of the parameter whose value is to be set.
+C
+C CVL is a character variable containing the new value of the
+C parameter.
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C ---------------------------------------------------------------------
+C
+C Check for a parameter name that is too short.
+C
+c print *,' ++entree STSETC'
+ IF (LEN(CNM).LT.3) THEN
+ CSTR(1:36)='STSETC - PARAMETER NAME TOO SHORT - '
+ CSTR(37:36+LEN(CNM))=CNM
+ CALL SETER (CSTR(1:36+LEN(CNM)),1,1)
+ RETURN
+ END IF
+C
+C Set the proper parameter.
+C
+ IF (CNM(1:3).EQ.'ZFT'.OR.CNM(1:3).EQ.'zft') THEN
+ CZFT=CVL
+ ELSE
+C
+ CSTR(1:36)='STSETC - PARAMETER NAME NOT KNOWN - '
+ CSTR(37:39)=CNM(1:3)
+ CALL SETER (CSTR(1:39),3,1)
+ RETURN
+C
+ END IF
+C
+C Done.
+C
+ RETURN
+C
+ END
+C
+C $Id$
+C
+C
+C-----------------------------------------------------------------------
+C
+ SUBROUTINE STSETR (CNM,RVL)
+C
+ CHARACTER*(*) CNM
+C
+C This subroutine is called to set the real value of a specified
+C parameter.
+C
+C CNM is the name of the parameter whose value is to be set.
+C
+C RVL is a real variable containing the new value of the parameter.
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+ PARAMETER (IPNPTS = 256, IPLSTL = 1500, IPGRCT = 64)
+c PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C ---------------------------------------------------------------------
+C
+C Check for a parameter name that is too short.
+C
+c print *,' ++entree STSETR'
+ IF (LEN(CNM).LT.3) THEN
+ CSTR(1:46)='STSETI OR STSETR - PARAMETER NAME TOO SHORT - '
+ CSTR(47:46+LEN(CNM))=CNM
+ CALL SETER (CSTR(1:46+LEN(CNM)),1,1)
+ RETURN
+ END IF
+C
+C Check for incorrect use of the index parameter.
+C
+ IF (CNM(1:3).EQ.'CLR'.OR.CNM(1:3).EQ.'clr'
+ + .OR.CNM(1:3).EQ.'TVL'.OR.CNM(1:3).EQ.'tvl') THEN
+ IF (IPAI.LT.1.OR.IPAI.GT.IPLVLS) THEN
+ CSTR(1:46)='STSETI OR STSETR - SETTING XXX - PAI INCORRECT'
+ CSTR(28:30)=CNM(1:3)
+ CALL SETER (CSTR(1:46),2,1)
+ RETURN
+ END IF
+ END IF
+C
+C Set the appropriate parameter value.
+C
+C ---------------------------------------------------------------------
+C
+C Values in STPAR
+C
+ IF (CNM(1:3).EQ.'UD1'.OR. CNM(1:3).EQ.'ud1') THEN
+ IUD1=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'VD1'.OR. CNM(1:3).EQ.'vd1') THEN
+ IVD1=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'PD1'.OR. CNM(1:3).EQ.'pd1') THEN
+ IPD1=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'XD1'.OR. CNM(1:3).EQ.'xd1') THEN
+ IXD1=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'XDM'.OR. CNM(1:3).EQ.'xdm') THEN
+ IXDM=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'YD1'.OR. CNM(1:3).EQ.'yd1') THEN
+ IYD1=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'YDN'.OR. CNM(1:3).EQ.'ydn') THEN
+ IYDN=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'WKD'.OR.CNM(1:3).EQ.'wkd') THEN
+ IWKD=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'WKU'.OR.CNM(1:3).EQ.'wku') THEN
+ IWKU=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'SET'.OR. CNM(1:3).EQ.'set') THEN
+ ISET=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'ERR'.OR. CNM(1:3).EQ.'err') THEN
+ IERR=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'XIN'.OR. CNM(1:3).EQ.'xin') THEN
+ IXIN=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'YIN'.OR. CNM(1:3).EQ.'yin') THEN
+ IYIN=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'MSK'.OR. CNM(1:3).EQ.'msk') THEN
+ IMSK=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'CPM'.OR. CNM(1:3).EQ.'cpm') THEN
+ ICPM=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'NLV'.OR.CNM(1:3).EQ.'nlv') THEN
+ NLVL=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'PAI'.OR.CNM(1:3).EQ.'pai') THEN
+ IF (RVL .LT. 1.0 .OR. RVL .GT. IPLVLS) GO TO 9800
+ IPAI=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'CTV'.OR.CNM(1:3).EQ.'ctv') THEN
+ ICTV=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'LWD'.OR.CNM(1:3).EQ.'lwd') THEN
+ IF (RVL .LE. 0.0) GO TO 9800
+ WDLV=RVL
+C
+C UVMN,UVMX, PMIN, PMAX are read-only
+C
+ ELSE IF (CNM(1:3).EQ.'THN'.OR. CNM(1:3).EQ.'thn') THEN
+ ITHN=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'PLR'.OR. CNM(1:3).EQ.'plr') THEN
+ IPLR=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'SST'.OR. CNM(1:3).EQ.'sst') THEN
+ ISST=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'CLR'.OR.CNM(1:3).EQ.'clr') THEN
+ ICLR(IPAI)=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'TVL'.OR.CNM(1:3).EQ.'tvl') THEN
+ TVLU(IPAI)=RVL
+C
+C ---------------------------------------------------------------------
+C
+C Values in STTRAN
+C
+ ELSE IF (CNM(1:3).EQ.'VPS'.OR. CNM(1:3).EQ.'vps') THEN
+ UVPS=RVL
+ ELSE IF (CNM(1:3).EQ.'VPL'.OR.CNM(1:3).EQ.'vpl') THEN
+ UVPL=MIN(1.0,MAX(0.0,RVL))
+ ELSE IF (CNM(1:3).EQ.'VPR'.OR.CNM(1:3).EQ.'vpr') THEN
+ UVPR=MIN(1.0,MAX(0.0,RVL))
+ ELSE IF (CNM(1:3).EQ.'VPB'.OR.CNM(1:3).EQ.'vpb') THEN
+ UVPB=MIN(1.0,MAX(0.0,RVL))
+ ELSE IF (CNM(1:3).EQ.'VPT'.OR.CNM(1:3).EQ.'vpt') THEN
+ UVPT=MIN(1.0,MAX(0.0,RVL))
+ ELSE IF (CNM(1:3).EQ.'WDL'.OR.CNM(1:3).EQ.'wdl') THEN
+ UWDL=RVL
+ ELSE IF (CNM(1:3).EQ.'WDR'.OR.CNM(1:3).EQ.'wdr') THEN
+ UWDR=RVL
+ ELSE IF (CNM(1:3).EQ.'WDB'.OR.CNM(1:3).EQ.'wdb') THEN
+ UWDB=RVL
+ ELSE IF (CNM(1:3).EQ.'WDT'.OR.CNM(1:3).EQ.'wdt') THEN
+ UWDT=RVL
+ ELSE IF (CNM(1:3).EQ.'XC1'.OR.CNM(1:3).EQ.'xc1') THEN
+ UXC1=RVL
+ ELSE IF (CNM(1:3).EQ.'XCM'.OR.CNM(1:3).EQ.'xcm') THEN
+ UXCM=RVL
+ ELSE IF (CNM(1:3).EQ.'YC1'.OR.CNM(1:3).EQ.'yc1') THEN
+ UYC1=RVL
+ ELSE IF (CNM(1:3).EQ.'YCN'.OR.CNM(1:3).EQ.'ycn') THEN
+ UYCN=RVL
+C
+C ---------------------------------------------------------------------
+C
+C Values in STSTRM
+C
+ ELSE IF (CNM(1:3).EQ.'SGD'.OR. CNM(1:3).EQ.'sgd') THEN
+ ISGD=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'AGD'.OR. CNM(1:3).EQ.'agd') THEN
+ IAGD=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'ARL'.OR. CNM(1:3).EQ.'arl') THEN
+ RARL=RVL
+ ELSE IF (CNM(1:3).EQ.'CKP'.OR. CNM(1:3).EQ.'ckp') THEN
+ ICKP=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'CKX'.OR. CNM(1:3).EQ.'ckx') THEN
+ ICKX=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'TRP'.OR. CNM(1:3).EQ.'trp') THEN
+ ITRP=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'CYK'.OR. CNM(1:3).EQ.'cyk') THEN
+ ICYK=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'VNL'.OR. CNM(1:3).EQ.'vnl') THEN
+ RVNL=RVL
+ ELSE IF (CNM(1:3).EQ.'SVF'.OR. CNM(1:3).EQ.'svf') THEN
+ ISVF=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'USV'.OR. CNM(1:3).EQ.'usv') THEN
+ RUSV=RVL
+ ELSE IF (CNM(1:3).EQ.'VSV'.OR. CNM(1:3).EQ.'vsv') THEN
+ RVSV=RVL
+ ELSE IF (CNM(1:3).EQ.'PSV'.OR. CNM(1:3).EQ.'psv') THEN
+ RPSV=RVL
+ ELSE IF (CNM(1:3).EQ.'SPC'.OR. CNM(1:3).EQ.'spc') THEN
+ ISPC=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'CDS'.OR. CNM(1:3).EQ.'cds') THEN
+ RCDS=RVL
+ ELSE IF (CNM(1:3).EQ.'SSP'.OR. CNM(1:3).EQ.'ssp') THEN
+ RSSP=RVL
+ ELSE IF (CNM(1:3).EQ.'DFM'.OR. CNM(1:3).EQ.'dfm') THEN
+ RDFM=RVL
+ ELSE IF (CNM(1:3).EQ.'SMD'.OR. CNM(1:3).EQ.'smd') THEN
+ RSMD=RVL
+ ELSE IF (CNM(1:3).EQ.'AMD'.OR. CNM(1:3).EQ.'amd') THEN
+ RAMD=RVL
+ ELSE IF (CNM(1:3).EQ.'GBS'.OR. CNM(1:3).EQ.'gbs') THEN
+ IGBS=INT(RVL)
+C
+C This parameter is special in that it causes RSSP,RDFM, and RARL
+C to be reset.
+C
+ IF (IGBS .EQ. 0) THEN
+ RARL = 0.012
+ RDFM = 0.02
+ RSSP = 0.015
+ ELSE
+ RARL = 0.33
+ RDFM = 0.33
+ RSSP = 0.5
+ END IF
+C
+C ---------------------------------------------------------------------
+C
+C Values in STTXP
+C
+C Character attributes
+C
+C
+ ELSE IF (CNM(1:3).EQ.'ZFS'.OR.CNM(1:3).EQ.'zfs') THEN
+ FZFS=RVL
+ ELSE IF (CNM(1:3).EQ.'ZFX'.OR.CNM(1:3).EQ.'zfx') THEN
+ FZFX=RVL
+ ELSE IF (CNM(1:3).EQ.'ZFY'.OR.CNM(1:3).EQ.'zfy') THEN
+ FZFY=RVL
+ ELSE IF (CNM(1:3).EQ.'ZFP'.OR. CNM(1:3).EQ.'zfp') THEN
+ IZFP=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'ZFC'.OR. CNM(1:3).EQ.'zfc') THEN
+ IZFC=INT(RVL)
+C
+C ---------------------------------------------------------------------
+C
+C Values in STMAP
+C
+ ELSE IF (CNM(1:3).EQ.'MAP'.OR. CNM(1:3).EQ.'map') THEN
+ IMAP=INT(RVL)
+ ELSE IF (CNM(1:3).EQ.'TRT'.OR. CNM(1:3).EQ.'trt') THEN
+ ITRT=INT(RVL)
+C
+C ---------------------------------------------------------------------
+C
+ ELSE
+ CSTR(1:46)='STSETI OR STSETR - PARAMETER NAME NOT KNOWN - '
+ CSTR(47:49)=CNM(1:3)
+ CALL SETER (CSTR(1:49),3,1)
+ RETURN
+ END IF
+C
+ GOTO 9900
+C
+ 9800 CONTINUE
+C
+ CSTR(1:50)='STSETI OR STSETR - PARAMETER VALUE OUT OF RANGE - '
+ CSTR(51:53)=CNM(1:3)
+ CALL SETER (CSTR(1:53),3,1)
+ RETURN
+C
+ 9900 CONTINUE
+C
+C Done.
+C
+ RETURN
+C
+ END
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C $Id$
+C
+C-----------------------------------------------------------------------
+C
+ SUBROUTINE STINIT (U,LU,V,LV,P,LP,M,N,WRK,LW)
+
+ USE MODD_RESOLVCAR
+C
+C Argument dimensions.
+C
+ DIMENSION U(LU,N) ,V(LV,N) ,P(LP,N)
+ DIMENSION WRK(LW)
+C
+C Input parameters
+C
+C U,V - 2-d arrays holding the component values of a vector field
+C LU,LV - The first dimensions of the U and V arrays, respectively
+C ----------------
+C P - A 2-d array containing a scalar data field. The contents
+C of this array may be used to color the streamlines.
+C LP - The first dimension of the P array
+C NOTE:
+C Coloring by means of the P scalar data field is not yet
+C implemented
+C ----------------
+C M - The first data dimension (must be less than or equal to
+C MIN(LU,LV) (or MIN(LU,LV,LP) if the P array is used
+C WRK - an internally used work array
+C LW - dimension of the work array (must be at least 2*M*N)
+C
+C Output parameters:
+C
+C None
+C
+C Force the block data routine, which sets default variables, to load.
+C
+ EXTERNAL STDATA
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the ST common blocks.
+C
+ PARAMETER (IPLVLS = 64)
+C
+C Integer and real common block variables
+C
+C
+ COMMON / STPAR /
+ + IUD1 ,IVD1 ,IPD1 ,
+ + IXD1 ,IXDM ,IYD1 ,IYDN ,
+ + IXM1 ,IYM1 ,IXM2 ,IYM2 ,
+ + IWKD ,IWKU ,ISET ,IERR ,
+ + IXIN ,IYIN ,IMSK ,ICPM ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + ITHN ,IPLR ,ISST ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+ COMMON / STTRAN /
+ + UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN
+C
+C Stream algorithm parameters
+C
+ COMMON / STSTRM /
+ + ISGD ,IAGD ,RARL ,ICKP ,
+ + ICKX ,ITRP ,ICYK ,RVNL ,
+ + ISVF ,RUSV ,RVSV ,RNDA ,
+ + ISPC ,RPSV ,RCDS ,RSSP ,
+ + RDFM ,RSMD ,RAMD ,IGBS
+C
+C Text related parameters
+C Note: graphical text output is not yet implemented for the
+C Streamline utility.
+C
+ COMMON / STTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=80)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CILT
+C
+C Text string parameters
+C
+ COMMON / STCHAR / CSTR,CMNT,CMXT,CZFT,CILT
+C
+ SAVE /STPAR/, /STTRAN/, /STSTRM/, /STTXP/, /STCHAR/
+C
+C Internal buffer lengths
+C
+C IPNPTS - Number of points in the point buffer -- not less than 3
+C IPLSTL - Streamline-crossover-check circular list length
+C IPGRCT - Number of groups supported for area masking
+C
+c PARAMETER (IPNPTS = 256, IPLSTL = 15000, IPGRCT = 64)
+ PARAMETER (IPNPTS = 256, IPLSTL = 750, IPGRCT = 64)
+C
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C ---------------------------------------------------------------------
+C
+C Write the array sizes into the common block
+C
+ IUD1=LU
+ IVD1=LV
+ IPD1=LP
+ IWKD=LW
+C
+C Error if M > LU or M > LV?
+C
+ IF (LU.LT.M .OR. LV.LT.M) THEN
+ CSTR(1:45)='STINIT - U AND/OR V ARRAY DIMENSIONS EXCEEDED'
+ CALL SETER (CSTR(1:45),1,1)
+ RETURN
+ END IF
+ IXDM=MIN(M,LU,LV)
+ IYDN=N
+ IXD1=1
+ccJD
+ IYD1=1
+ if(nverbia > 0)then
+ print *,' **stinit AV ISGD,IYD1,IYDN NSEUIL ',ISGD,
+ 1IYD1,IYDN,NSEUIL
+ endif
+ IF(ISGD == 1)THEN
+ IYD1=NSEUIL
+ ELSE
+ IYD1=1
+ IF(NSGD==2)IYDN=NSEUIL+1
+ ENDIF
+c IYD1=1
+ if(nverbia > 0)then
+ print *,' **stinit ISGD,IYD1,IYDN ',ISGD,IYD1,IYDN,NSEUIL
+ endif
+ccJD
+ IXM1=IXDM-1
+ IXM2=IXDM-2
+ IYM1=IYDN-1
+ IYM2=IYDN-2
+ IF (LW .LT. 2*IXDM*IYDN) THEN
+ CSTR(1:37)='STINIT - WRK ARRAY DIMENSION EXCEEDED'
+ CALL SETER (CSTR(1:37),2,1)
+ RETURN
+ END IF
+C
+C Initialize and transfer some arguments to local variables.
+C
+ IBIG = I1MACH(9)
+ RBIG = R1MACH(2)
+C
+C Decide what the range of values in X and Y should be.
+C
+ IF (UXC1.EQ.UXCM) THEN
+ XLOV=1.
+ XHIV=REAL(IXDM)
+ ELSE
+ XLOV=UXC1
+ XHIV=UXCM
+ END IF
+C
+ IF (UYC1.EQ.UYCN) THEN
+ YLOV=1.
+ YHIV=REAL(IYDN)
+ ELSE
+ YLOV=UYC1
+ YHIV=UYCN
+ END IF
+C
+ IXIN = MAX(IXIN,1)
+ IYIN = MAX(IYIN,1)
+C
+ NXCT = IXDM/IXIN
+ NYCT = IYDN/IYIN
+C
+C If the user has done a SET call, retrieve the arguments; if he hasn't
+C done a SET call, do it for him.
+C
+ IF (ISET .EQ .0) THEN
+C
+ CALL GETSET (XVPL,XVPR,YVPB,YVPT,WXMN,WXMX,WYMN,WYMX,LNLG)
+C
+ ELSE
+C
+ LNLG=1
+C
+ IF (UWDL.EQ.UWDR) THEN
+ WXMN=XLOV
+ WXMX=XHIV
+ ELSE
+ WXMN=UWDL
+ WXMX=UWDR
+ END IF
+C
+ IF (UWDB.EQ.UWDT) THEN
+ WYMN=YLOV
+ WYMX=YHIV
+ ELSE
+ WYMN=UWDB
+ WYMX=UWDT
+ END IF
+C
+C Determine the viewport based on the setting of the viewport
+C shape and viewport extent parameters
+C
+ IF (UVPS.LT.0.) THEN
+ AR=ABS(UVPS)
+ ELSE IF (UVPS.EQ.0.) THEN
+ AR=(UVPR-UVPL)/(UVPT-UVPB)
+ ELSE IF (UVPS.LE.1.) THEN
+ AR=ABS((WXMX-WXMN)/(WYMX-WYMN))
+ IF (MIN(AR,1./AR).LT.UVPS) AR=(UVPR-UVPL)/(UVPT-UVPB)
+ ELSE
+ AR=ABS((WXMX-WXMN)/(WYMX-WYMN))
+ IF (MAX(AR,1./AR).GT.UVPS) AR=1.
+ END IF
+C
+ IF (AR.LT.(UVPR-UVPL)/(UVPT-UVPB)) THEN
+ XVPL=.5*(UVPL+UVPR)-.5*(UVPT-UVPB)*AR
+ XVPR=.5*(UVPL+UVPR)+.5*(UVPT-UVPB)*AR
+ YVPB=UVPB
+ YVPT=UVPT
+ ELSE
+ XVPL=UVPL
+ XVPR=UVPR
+ YVPB=.5*(UVPB+UVPT)-.5*(UVPR-UVPL)/AR
+ YVPT=.5*(UVPB+UVPT)+.5*(UVPR-UVPL)/AR
+ END IF
+C
+ CALL SET (XVPL,XVPR,YVPB,YVPT,WXMN,WXMX,WYMN,WYMX,LNLG)
+C
+ END IF
+C
+C Calculate fraction of VP width to fractional size factor.
+C Calculate fraction of VP height to fractional size factor.
+C These are for convenience.
+C
+ FW2W = XVPR - XVPL
+ FH2H = YVPT - YVPB
+C
+C Swap window rectangle if it is inverted, but keep track
+C This makes it easier to exclude out-of-bounds points in the
+C projection mapping routines
+C
+ INVX=0
+ INVY=0
+ IF (WXMN .GT. WXMX) THEN
+ T=WXMN
+ WXMN=WXMX
+ WXMX=T
+ INVX=1
+ END IF
+ IF (WYMN .GT. WYMX) THEN
+ T=WYMN
+ WYMN=WYMX
+ WYMX=T
+ INVY=1
+ END IF
+C
+C If cyclic data specified check to ensure the cyclic condition exists.
+C The error flag is set if necessary within STCYCL
+C
+ IF (ICYK.NE.0) CALL STCYCL(U,V)
+C
+C Calculate the grid size
+C
+ XGDS=(XHIV-XLOV)/(REAL(NXCT)-1.0)
+ YGDS=(YHIV-YLOV)/(REAL(NYCT)-1.0)
+C
+C Done.
+C
+ RETURN
+C
+ END
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C $Id$
+C
+C-----------------------------------------------------------------------
+C
+ SUBROUTINE STUMXY(XDA,YDA,XUS,YUS,IST)
+C
+C User modifiable routine for mapping data coordinate space to
+C user space
+C
+C
+C Input parameters:
+C
+C XDA,YDA - Point in data coordinate space
+C
+C Output parameters:
+C
+C XUS,YUS - Point in user coordinate space
+C IST - Status code indicating success or failure
+C
+C --------------------------------------------------------------------
+ USE MODD_RESOLVCAR
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C* 0.1 Commons
+C
+ COMMON/TEMV/ZWORKZ,ZZDS,INX,INY
+ COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+ COMMON/TEMH/ZZXX,ZZXY,IIMAX,IJMAX
+ SAVE /TEMH/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C -------------------------------------------------------------
+c IMPLICIT NONE
+C
+C* 0.1 Dummy arguments
+C
+#include "big.h"
+ INTEGER IST
+ REAL XDA,YDA
+ REAL XUS,YUS
+ REAL ZZXX(N2DVERTX),ZZXY(N2DVERTX)
+c REAL ZZXX(4000),ZZXY(400)
+cc REAL ZZXX(1000),ZZXY(400)
+ REAL ZWORKZ(N2DVERTX,2500),ZZDS(N2DVERTX)
+c REAL ZWORKZ(4000,400),ZZDS(4000)
+cc REAL ZWORKZ(1000,400),ZZDS(1000)
+ LOGICAL LVERT,LHOR,LPT,LXABS
+ INTEGER INX,INY,IIMAX,IJMAX
+C
+C* 0.2 Local variables
+C
+ INTEGER LL,JJ,I,J,IX,IY,IXP1,IYP1
+ REAL ZDIFX,ZX1,ZX2,ZY,ZDIFY,ZW1,ZW2,ZW3,ZW4,Z1,Z2,ZR
+ccc Avec Interpol en Z
+c INTEGER IPASZ
+c REAL ZPASZ
+c REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZW
+c IF(ALLOCATED(ZW))DEALLOCATE(ZW)
+c IPASZ=100
+c ALLOCATE(ZW(IPASZ))
+c ZW(1)=0.
+c ZPASZ=MAXVAL(ZWORKZ) /(IPASZ-1)
+c print *,' IPASZ ZPASZ MAXVAL(XZWORKZ) ',IPASZ,ZPASZ,
+c 1MAXVAL(ZWORKZ)
+c DO J=2,IPASZ
+c ZW(J)=ZW(J-1)+ZPASZ
+c ENDDO
+c print *,' **stum LVERT LHOR ',LVERT,LHOR
+ccc Avec Interpol en Z
+
+
+C
+C Identity transformation
+C
+ IST=0
+c XUS=XDA
+c YUS=YDA
+
+C* 1.2 Computes streched X's
+ IF(IMAP == 4)THEN
+
+ IX=INT(XDA)
+
+ IF(LVERT)THEN
+ IF(IX < 1 .OR. IX > INX)THEN
+ print *,' **stumxy AV IX= XDA bizarre IX INX ',XDA,IX,INX
+ IX=NINT(XDA)
+ print *,' **stumxy AP IX= XDA bizarre IX ',XDA,IX
+ ENDIF
+
+ ELSE
+
+ IF(IX < 1 .OR. IX > IIMAX)THEN
+ print *,' **stumxy AV IX= XDA bizarre IX IIMAX ',XDA,IX,IIMAX
+ IX=NINT(XDA)
+ print *,' **stumxy AP IX=XDA bizarre IX ',XDA,IX
+ ENDIF
+ ENDIF
+C IF(FLOAT(IX)+.989.LE.XDA)IX=IX+1
+ ZDIFX=XDA-FLOAT(IX)
+c print *,' XDA IX ZDIFX LHOR+V ',XDA,IX,ZDIFX,LHOR,LVERT
+
+ IF(LVERT)THEN
+ ZX1=ZZDS(MAX(IX,1))
+ ZX2=ZZDS(MIN(IX+1,INX))
+c PRINT *,' cpmpxy XDA IX',XDA,IX,' ZX1 2',ZX1,ZX2,' XUS ',
+c 1XUS
+ ELSE
+
+ ZX1=ZZXX(MAX(IX,1))
+ ZX2=ZZXX(MIN(IX+1,IIMAX))
+ ENDIF
+ IF(LVERT)THEN
+c PRINT *,' cpmpxy XDA IX',XDA,IX,' ZX1 2',ZX1,ZX2,' ZDIFX ',
+c 1ZDIFX,' INX ',INX
+ ELSE
+c PRINT *,' cpmpxy XDA IX',XDA,IX,' ZX1 2',ZX1,ZX2,' ZDIFX ',
+c 1ZDIFX,' IIMAX ',IIMAX
+ ENDIF
+ XUS=ZX1+ZDIFX*(ZX2-ZX1)
+c PRINT *,' cpmpxy XDA IX',XDA,IX,' ZX1 2',ZX1,ZX2,' XUS ',
+c 1XUS
+
+C* 1.3 Computes streched Y's
+
+ ZY=YDA
+ IY=INT(ZY)
+C IF(FLOAT(IY)+.989.LE.YDA)IY=IY+1
+ ZDIFY=ZY-FLOAT(IY)
+
+ IF(LVERT)THEN
+c PRINT *,' cpmpxy YINP IY',YINP,IY
+ IXP1=MIN(INX,IX+1)
+ IF(LINTERPOLSTR)THEN
+
+ccc Avec Interpol en Z
+ IYP1=MIN(NZSTR,IY+1)
+ ZW1=XZSTR(MAX(IY,1))
+ ZW2=XZSTR(MIN(IYP1,NZSTR))
+ ZR=ZW1+ZDIFY*(ZW2-ZW1)
+ if(nverbia > 0)then
+ print *,' **stum** YDA,IY,ZW1,ZW2,ZR,NZSTR ',
+ 1YDA,IY,ZW1,ZW2,ZR,NZSTR
+ endif
+ccc Avec Interpol en Z
+ccc SANS Interpol en Z
+ ELSE
+ IYP1=MIN(INY,IY+1)
+ ZW1=ZWORKZ(IX,IY)
+ ZW2=ZWORKZ(IX,IYP1)
+ ZW3=ZWORKZ(IXP1,IY)
+ ZW4=ZWORKZ(IXP1,IYP1)
+ Z1=ZW1+ZDIFY*(ZW2-ZW1)
+ Z2=ZW3+ZDIFY*(ZW4-ZW3)
+ ZR=Z1+ZDIFX*(Z2-Z1)
+ if(nverbia > 0)then
+ print *,' **stum** YDA,IY,ZW1,ZW2,ZW3,ZW4,Z1,Z2,ZR,INY ',
+ 1YDA,IY,ZW1,ZW2,ZW3,ZW4,Z1,Z2,ZR,INY
+ endif
+ ENDIF
+ccc SANS Interpol en Z
+
+ ELSE
+
+ ZW1=ZZXY(MAX(IY,1))
+ ZW2=ZZXY(MIN(IY+1,IJMAX))
+ ZR=ZW1+ZDIFY*(ZW2-ZW1)
+ ENDIF
+c PRINT *,' cpmpxy YDA IY',YDA,IY,' ZW1 2',ZW1,ZW2,' ZDIFY ',
+c 1ZDIFY,' IJMAX ',IJMAX
+ YUS=ZR
+ if(nverbia > 0)then
+ print *,' ***stumxy... xda,yda,xus,yus ',XDA,YDA,XUS,YUS
+ endif
+ ENDIF
+
+C
+C Done.
+C
+ RETURN
+C
+ END
+C
+C ---------------------------------------------------------------------
+C
+C ---------------------------------------------------------------------
+C
+ SUBROUTINE STUIXY(XUS,YUS,XDA,YDA,IST)
+C
+C User modifiable routine for inversely transforming
+C a point in user coordinate space to data space
+C
+C Input parameters:
+C
+C XUS,YUS - Point in user coordinate space
+C
+C Output parameters:
+C
+C XDA,YDA - Point in data coordinate space
+C IST - Status code indicating success or failure
+C
+C --------------------------------------------------------------------
+ USE MODN_NCAR
+ USE MODD_RESOLVCAR
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C* 0.1 Commons
+C
+ COMMON/TEMV/ZWORKZ,ZZDS,INX,INY
+ COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+ COMMON/TEMH/ZZXX,ZZXY,IIMAX,IJMAX
+ SAVE /TEMH/
+
+
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C ---------------------------------------------------------------------
+C
+c IMPLICIT NONE
+C
+C* 0.1 Dummy arguments
+C
+#include "big.h"
+ INTEGER IST
+ REAL XDA,YDA
+ REAL XUS,YUS
+ REAL ZZXX(N2DVERTX),ZZXY(N2DVERTX)
+c REAL ZZXX(4000),ZZXY(400)
+cc REAL ZZXX(1000),ZZXY(400)
+ REAL ZWORKZ(N2DVERTX,2500),ZZDS(N2DVERTX)
+c REAL ZWORKZ(4000,400),ZZDS(4000)
+cc REAL ZWORKZ(1000,400),ZZDS(1000)
+ LOGICAL LVERT,LHOR,LPT,LXABS
+ INTEGER INX,INY, IIMAX,IJMAX
+ INTEGER IVM,IVM1,IVM2
+
+C
+C* 0.2 Local variables
+C
+ INTEGER LL,JJ,I,J,IX,IY,IXP1,IYP1
+ REAL ZDIFX,ZX1,ZX2,ZY,ZDIFY,ZW1,ZW2,ZW3,ZW4,Z1,Z2,ZR
+ LOGICAL GOK
+
+ccc Avec Interpol en Z
+c INTEGER IPASZ
+c REAL ZPASZ
+c REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZW
+c IF(ALLOCATED(ZW))DEALLOCATE(ZW)
+c IPASZ=100
+c ALLOCATE(ZW(IPASZ))
+c ZW(1)=0.
+c ZPASZ=MAXVAL(ZWORKZ) /(IPASZ-1)
+c print *,' IPASZ ZPASZ MAXVAL(XZWORKZ) ',IPASZ,ZPASZ,
+c 1MAXVAL(ZWORKZ)
+c DO J=2,IPASZ
+c ZW(J)=ZW(J-1)+ZPASZ
+c ENDDO
+c print *,' **stum LVERT LHOR ',LVERT,LHOR
+ccc Avec Interpol en Z
+
+
+ IF(IMAP == 4)THEN
+ IST=0
+c XDA=XUS
+c YDA=YUS
+
+ IF(LVERT)THEN
+ DO I=1,INX
+ IVM=0
+ IF(XUS == ZZDS(I))THEN
+ XDA=I
+ IVM=1
+ IVM1=I
+ GOK=.TRUE.
+ EXIT
+ ELSEIF(XUS >= ZZDS(MAX(I,1)) .AND.
+ 1 XUS < ZZDS(MIN(I+1,INX)))THEN
+ ZDIFX=XUS-ZZDS(MAX(I,1))
+ ZX1=ZZDS(MAX(I,1))
+ ZX2=ZZDS(MIN(I+1,INX))
+ XDA=I+ZDIFX/(ZX2-ZX1)
+ IVM=2
+ IVM1=MAX(I,1)
+ IVM2=MIN(I+1,INX)
+ GOK=.TRUE.
+ EXIT
+ ELSE
+c GOK=.FALSE.
+ CYCLE
+c IST=-2
+ ENDIF
+ IF(I == INX)THEN
+ XDA=XSPVAL
+ IST=-2
+ ELSE
+ ENDIF
+ ENDDO
+
+ ELSE
+
+ DO I=1,IIMAX
+ IF(XUS == ZZXX(I))THEN
+ XDA=I
+ GOK=.TRUE.
+ EXIT
+ ELSEIF(XUS >= ZZXX(MAX(I,1)) .AND.
+ 1 XUS < ZZXX(MIN(I+1,IIMAX)))THEN
+ ZDIFX=XUS-ZZXX(MAX(I,1))
+ ZX1=ZZXX(MAX(I,1))
+ ZX2=ZZXX(MIN(I+1,IIMAX))
+ XDA=I+ZDIFX/(ZX2-ZX1)
+ GOK=.TRUE.
+ EXIT
+ ELSE
+c GOK=.FALSE.
+ CYCLE
+c IST=-2
+ ENDIF
+ ENDDO
+
+ ENDIF
+
+ IF(LVERT)THEN
+
+ IF(LINTERPOLSTR)THEN
+ccc Avec Interpol en Z
+ DO J=1,NZSTR-1
+ IF(YUS == XZSTR(J))THEN
+ YDA=J
+ GOK=.TRUE.
+ EXIT
+ ELSEIF(YUS >= XZSTR(MAX(J,1)) .AND.
+ 1 YUS < XZSTR(MIN(J+1,NZSTR)))THEN
+ ZDIFY=YUS-XZSTR(MAX(J,1))
+ ZW1=XZSTR(MAX(J,1))
+ ZW2=XZSTR(MIN(J+1,NZSTR))
+ YDA=J+ZDIFY/(ZW2-ZW1)
+ GOK=.TRUE.
+ EXIT
+ ELSE
+c GOK=.FALSE.
+ CYCLE
+ ENDIF
+ IF(J == NZSTR-1)THEN
+ IST=-2
+ ENDIF
+ ENDDO
+ccc Avec Interpol en Z
+
+ ELSE
+
+ccc SANS Interpol en Z
+ IF(IVM == 0)THEN
+ YDA=XSPVAL
+ IST=-2
+ RETURN
+ ELSEIF(IVM == 1)THEN
+ DO J=2,INY-1
+ IF(YUS < ZWORKZ(IVM1,2))THEN
+ YDA=XSPVAL
+ XDA=XSPVAL
+ RETURN
+ ELSEIF(YUS == ZWORKZ(IVM1,J))THEN
+ YDA=J
+ EXIT
+c ELSEIF(YUS >= ZWORKZ(IVM1,J) .AND.
+ ELSEIF(YUS >= ZWORKZ(IVM1,MAX(J,2)) .AND.
+ 1 YUS < ZWORKZ(IVM1,MIN(J+1,INY)))THEN
+ ZW1=ZWORKZ(IVM1,MAX(J,2))
+ ZW2=ZWORKZ(IVM1,MIN(J+1,INY))
+ ZDIFY=YUS-ZW1
+ IF(ZW2 /= ZW1)THEN
+ YDA=J+ZDIFY/(ZW2-ZW1)
+ EXIT
+ ELSE
+ YDA=J
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+ ELSEIF(IVM == 2)THEN
+ DO J=2,INY-1
+ ZW1=ZWORKZ(IVM1,MAX(J,2))
+ ZW2=ZWORKZ(IVM1,MIN(J+1,INY))
+ ZW3=ZWORKZ(IVM2,MAX(J,2))
+ ZW4=ZWORKZ(IVM2,MIN(J+1,INY))
+ IF(ZX2 /= ZX1)THEN
+ ZW5=ZW1+ZDIFX/(ZX2-ZX1)*(ZW3-ZW1)
+ ELSE
+ ZW5=ZW1
+ ENDIF
+ IF(J == 2)THEN
+ ZW5M=ZW5
+ ENDIF
+ IF(ZX2 /= ZX1)THEN
+ ZW6=ZW2+ZDIFX/(ZX2-ZX1)*(ZW4-ZW2)
+ ELSE
+ ZW6=ZW2
+ ENDIF
+ IF(YUS < ZW5M)THEN
+ YDA=XSPVAL
+ XDA=XSPVAL
+ if(nverbia >0)then
+ print *,' stui*** YUS < ZW5M ',YUS,ZW5M
+ endif
+ RETURN
+ ELSEIF(YUS >= ZW5 .AND. YUS < ZW6)THEN
+ ZDIFY=YUS-ZW5
+ IF(ZW6 /= ZW5)THEN
+ YDA=J+ZDIFY/(ZW6-ZW5)
+ EXIT
+ ELSE
+ YDA=J
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+ ELSE
+ YDA=XSPVAL
+ if(nverbia >0)then
+ print *,' stui*** YUS en dehors cas prevus ',YUS
+ endif
+ IST=-2
+ RETURN
+ ENDIF
+ccc SANS Interpol en Z
+
+
+ ENDIF
+
+ ELSE
+
+ DO J=1,IJMAX
+ IF(YUS == ZZXY(J))THEN
+ YDA=J
+ GOK=.TRUE.
+ EXIT
+ ELSEIF(YUS >= ZZXY(MAX(J,1)) .AND.
+ 1 YUS < ZZXY(MIN(J+1,IJMAX)))THEN
+ ZDIFY=YUS-ZZXY(MAX(J,1))
+ ZW1=ZZXY(MAX(J,1))
+ ZW2=ZZXY(MIN(J+1,IJMAX))
+ YDA=J+ZDIFY/(ZW2-ZW1)
+ GOK=.TRUE.
+ EXIT
+ ELSE
+c GOK=.FALSE.
+ CYCLE
+c IST=-2
+ ENDIF
+ ENDDO
+
+ ENDIF
+c print *,' +++STUIXY(XUS,YUS,XDA,YDA,IST) ',XUS,YUS,XDA,YDA,IST
+C
+C Done
+C
+ ENDIF
+ if(nverbia >0)then
+ print *,' +++STUIXY(XUS,YUS,XDA,YDA,IST) ',XUS,YUS,XDA,YDA,IST
+ endif
+ RETURN
+ END
+C
+C ---------------------------------------------------------------------
+C
+ SUBROUTINE STUMTA(XDA,YDA,XUS,YUS,XND,YND,DU,DV,TA,IST)
+C
+C User modifiable routine for mapping a tangent angle in data space to
+C normalized device coordinate space.
+C
+C Input parameters:
+C
+C XDA,YDA - Point in data coordinate space
+C XUS,YUS - Point in user coordinate space
+C XND,YND - Point in NDC space
+C DU,DV - Differential vector components in data space
+C
+C Output parameters:
+C
+C TA - Streamline tangent angle in NDC space
+C IST - Status code indicating success or failure
+C
+C --------------------------------------------------------------------
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /STMAP/
+ + IMAP ,LNLG ,INVX ,INVY ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + XGDS ,YGDS ,NXCT ,NYCT ,
+ + ITRT ,FW2W ,FH2H ,
+ + DFMG ,VNML ,RBIG ,IBIG
+C
+ SAVE /STMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C ---------------------------------------------------------------------
+C
+ IF(IMAP == 4)THEN
+ IST=0
+ TA=ATAN2(DV,DU)
+c print *,' +++++++STUMTA XDA,YDA,XUS,YUS,XND,YND,DU,DV,TA ',
+c 1XDA,YDA,XUS,YUS,XND,YND,DU,DV,TA
+ ENDIF
+C
+C Done.
+C
+ RETURN
+C
+ END
+
+
+
+
diff --git a/LIBTOOLS/tools/diachro/src/POS/fleche.f90 b/LIBTOOLS/tools/diachro/src/POS/fleche.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b6cbd61905416833f9d85506cfd3aae372235dea
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/fleche.f90
@@ -0,0 +1,146 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/post/s.fleche.f90, Version:1.2, Date:98/10/02, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ######spl
+ SUBROUTINE FLECHE(PX,PY,PU,PV,KLEN,PHA)
+! #######################################
+!
+!!**** *FLECHE* - Draws a single arrow for emagram wind display
+!!
+!! PURPOSE
+!! -------
+!
+! This routine draws an emagram wind vector by invoking the NCAR
+! "DRWVEC" utility (drawing of a single vector). The wind arrow is
+! drawn in the appropriate direction and location for the emagram
+! environment. KLEN and PHA are input only scaling factors received
+! from the "ECHELLE" routine.
+!
+!
+!!** METHOD
+!! ------
+!! A simple call to DRWVEC, which has stand after scaling by
+!! "ECHELLE" to set KLEN and PHA.
+!!
+!! NOTICE: The DRWVEC and the NCAR graphical utilities are NOT written
+!! ------ in Fortran 90, but in Fortran 77.. This sub-section of TRACE
+!! does not follow the Meso-NH usual rules: communication has
+!! to be made using the /VEC1/ COMMON stack with static memory
+!! allocation. See the ECHELLE routine for details.
+!!
+!! EXTERNAL
+!! --------
+!! FL2INT : Given a coordinate pair in the NCAR user system, returns the
+!! corresponding coordinate pair in the metacode system;
+!! VVSETI : Sets an integer NCAR parameter to select an option in the
+!! NCAR vector environment
+!! DRWVEC : Draws a single vector given by two pairs of metacode
+!! coordinates, CALL DRWVEC (M1,M2,M3,M4,LABEL,NC), where
+!! (M1,M2) coordinate of arrow base on a 2**15x2**15 grid,
+!! (M3,M4) coordinate of arrow head on a 2**15x2**15 grid,
+!! LABEL character label to be put above arrow, and
+!! NC number of character in label. This routine is
+!! given and documented in the VELVECT NCAR sources, but
+!! not really documented elsewhere... Sorry for this!
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! NCAR Graphics Technical documentation, UNIX version 3.2,
+!! Scientific computing division, NCAR/UCAR, Boulder, USA.
+!! Volume 1: Fundamentals, Vers. 1, May 1993
+!! Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+!!
+!! For the vector utilities not documented in the NCAR package
+!! Version 3 idocumentation, a better reference is:
+!! The NCAR GKS-Compatible Graphics System Version 2,
+!! SPPS an NCAR System Plot Package Simulator.
+!! NCAR Technical note 267+1A, April 1986, NCAR/UCAR, Boulder, USA.
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 10/01/95
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments and results
+!
+INTEGER :: KLEN ! Maximum arrow size which can be
+ ! plotted (given in metacode units)
+REAL :: PX, PY ! Arrow tail location, given in NCAR
+ ! user coordinate system.
+REAL :: PU, PV ! Wind components U and V to be plotted,
+ ! given in m/s.
+REAL :: PHA ! Maximum wind modulus which can be
+ ! plotted (given in m/s). Values of KLEN
+ ! and PHA have to be mutually consistent.
+!
+!* 0.2 Local variables
+!
+INTEGER :: IM1, IM2, IM3, IM4 ! Tail and head locations of the
+ ! arrow, given in metacode coordinates
+CHARACTER(LEN=10) :: YLABEL='AAAAAAAAAA' ! Arrow label (i.e.: its scale)
+!
+INTERFACE
+ SUBROUTINE DRWVEC (M1,M2,M3,M4,LABEL,NC)
+ CHARACTER*10 LABEL
+ INTEGER :: M1,M2,M3,M4,NC
+ END SUBROUTINE DRWVEC
+END INTERFACE
+!-------------------------------------------------------------------------------
+!
+!* 1. ARROW DRAWING
+! -------------
+!
+!* 1.1 Converts tail location from user to metacode coordinates
+!* (also called fractional) coordinates
+!
+CALL FL2INT(PX,PY,IM1,IM2)
+!
+!* 1.2 Computes the head location in metacode coordinates
+!
+IM3=IM1+INT(PU*FLOAT(KLEN)/PHA)
+IM4=IM2+INT(PV*FLOAT(KLEN)/PHA)
+!
+!* 1.3 Draws the arrow
+!
+! Setting VPO >0, the tail of the vector arrow is
+! placed at the grid point location
+!
+CALL VVSETI('VPO',1)
+!
+! As the last argument for DRWVEC
+! is 0, no label is actually written
+!
+CALL DRWVEC(IM1,IM2,IM3,IM4,YLABEL,0)
+! CALL PWRITX(PU,PV,6H'KGU'-,6,10,0,0)
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+!
+END SUBROUTINE FLECHE
diff --git a/LIBTOOLS/tools/diachro/src/POS/frame41.f b/LIBTOOLS/tools/diachro/src/POS/frame41.f
new file mode 100644
index 0000000000000000000000000000000000000000..e8d9353ce460bd02d75543d47258f286835b6c3d
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/frame41.f
@@ -0,0 +1,2301 @@
+ SUBROUTINE FRAME
+ COMMON /GFLASH/MODEF,IOPWKS(100),IOACT(100),NUMOP,IWISSI
+C
+C FRAME is designed to effect a break in the picture drawing
+C sequence depending upon whether the workstation type is
+C MO, or whether it is an OUTPUT or OUTIN workstation.
+C
+C An UPDATE WORKSTATION and CLEAR WORKSTATION is done on all
+C metafiles and all workstations of type OUTPUT. For metafiles
+C this inserts an END PICTURE into the metafile.
+C
+C If there are any OUTIN workstations, all of them are updated
+C with an UPDATE WORKSTATION and a pause is done on the OUTIN
+C workstation of most recent creation. After return from the
+C pause, a CLEAR WORKSTATION is done on all OUTIN workstations.
+C
+ INTEGER WKID
+ CHARACTER*80 DATREC,STR,ISTR
+C
+C First, flush the pen-move buffer.
+C
+ CALL PLOTIF (0.,0.,2)
+C
+C If no workstations are open, return.
+C
+ CALL GQOPWK (1,IER,NO,ID)
+ IF (NO .EQ. 0) RETURN
+C
+C Update all workstations.
+C
+ DO 200 I=1,NO
+C
+C Get the workstation ID.
+C
+ CALL GQOPWK (I,IERR,NO,WKID)
+C
+C Get workstation type.
+C
+ CALL GQWKC (WKID,IER,ICON,ITYPE)
+C
+C Get workstation category (0=output; 2=out/in; 4=metafile).
+C
+ CALL GQWKCA (ITYPE,IER,ICAT)
+C
+ IF (ICAT .EQ. 4) THEN
+C
+C Illegal to call FRAME while a FLASH buffer is open.
+C
+ IF (MODEF .EQ. 1) THEN
+ CALL SETER
+ - ('FRAME - ILLEGAL TO CALL FRAME WHILE A FLASH BUFFER IS OPEN',
+ - 16,2)
+ ENDIF
+ CALL GCLRWK(WKID,0)
+ ELSE IF (ICAT.EQ.0 .OR. ICAT.EQ.2) THEN
+ CALL GUWK(WKID,0)
+ IF (ICAT .EQ. 0) THEN
+ CALL GCLRWK(WKID,1)
+ ENDIF
+ ENDIF
+ 200 CONTINUE
+C
+C Pause on the OUTIN workstaton of most recent creation.
+C
+ DO 100 I=NO,1,-1
+ CALL GQOPWK (I,IERR,NO,WKID)
+ CALL GQWKC (WKID,IER,ICON,ITYPE)
+ CALL GQWKCA (ITYPE,IER,ICAT)
+ IF (ICAT.EQ.2) THEN
+ ISTR(1:1) = CHAR(0)
+ CALL GINST(WKID,1,0,ISTR,1,0.,1279.,0.,1023.,1,1,1,DATREC)
+ CALL GSSTM(WKID,1,0,0)
+ CALL GRQST(WKID,1,ISTAT,LOSTR,STR)
+ GO TO 110
+ ENDIF
+ 100 CONTINUE
+ 110 CONTINUE
+C
+C Clear all OUTIN worktations.
+C
+ DO 300 I=1,NO
+ CALL GQOPWK (I,IERR,NO,WKID)
+ CALL GQWKC (WKID,IER,ICON,ITYPE)
+ CALL GQWKCA (ITYPE,IER,ICAT)
+ IF (ICAT.EQ.2) THEN
+ CALL GCLRWK(WKID,1)
+ ENDIF
+ 300 CONTINUE
+ RETURN
+ END
+C------------------------------------------------------------------------
+C
+C ###########################################
+ SUBROUTINE CPMPXY(IMAP,XINP,YINP,XOTP,YOTP)
+C ###########################################
+C
+C
+CC**** *CPMPXY* - Maps compack isocontour points on the Meso-NH coordinate
+CC**** sytem verically or horizontally.
+CC
+CC PURPOSE
+CC -------
+C Maps compack isocontour points on the Meso-NH coordinate
+C sytem vertically or horizontally. This routine is directly called
+C by the NCAR CPRECT and CPCLDR cotour drawing routines.
+C
+CC** METHOD
+CC ------
+CC
+CC CPMPXY routine is used within the NCAR Conpack calls to map the contoured
+CC array matrix onto the stretched model cartographic space.
+CC The plotted data are NOT interpolated onto a regular grid before
+CC plotting, instead a coordinate stretching technique is used. Basically,
+CC the contour calculations are made in a "grid index space" where the
+CC meshsize is uniform and equal to 1 between successive model points (this
+CC corresponds to the x_bar_* and y_bar_* coordinates of the Meso-NH
+CC technical specification book, page 41). In this "grid index space"
+CC contourlines points are located by two floating-point index coordinates
+CC vaying between 1 and the corresponding array dimension. This "grid index"
+CC coordinates are latter converted back to screen coordinates by CPMPXY to
+CC obtain a correct display.
+CC Using this routine assumes that the NCAR internal "IMAP" parameter
+CC is given the value 4 (arbitrary convention).
+CC
+CC
+CC NOTICE: CPMPXY and the NCAR graphical utilities are NOT written
+CC ------ in Fortran 90, but in Fortran 77.. This sub-section of TRACE
+CC does not follow the Meso-NH usual rules: it has to be using
+CC a COMMON stack with static memory allocation of XZZXX and
+CC XZZXY arrays.
+CC
+CC EXTERNAL
+CC --------
+CC None
+CC
+CC EXPLICIT ARGUMENTS
+CC ------------------
+CC
+CC IMAP : Selects the customized mapping, has to be set to 4 (input).
+CC XINP : x-coordinate of the current contour point given as a
+CC fractionnal grid index (input).
+CC YINP : y-coordinate of the current contour point given as a
+CC fractionnal grid index (input).
+CC XOTP : x-coordinate of the current contour point after re-mapping onto
+CC the true display geometry, given in the NCAR "user coordinate"
+CC system (meters, output)
+CC YOTP : y-coordinate of the current contour point after re-mapping onto
+CC the true display geometry, given in the NCAR "user coordinate"
+CC system (meters, output)
+CC
+CC NOTICE: All these dummy arguments are required
+CC ------ by the NCAR CALLS
+CC
+CC IMPLICIT ARGUMENTS
+CC ------------------
+CC
+CC Common TEMV: Vertical cross-section grid information
+CC ZWORKZ: True altitudes of the current data point iwithin the section
+CC (in meters)
+CC ZZDS : Abscissa of the section gridpoint along the oblique horizontal
+CC axis of the section (meters)
+CC INX : Number of datapoint along the section's abscissa
+CC INY : Number of gridlevel along the section's vertical axis
+CC
+CC Common LOGI: Section geometry information flags copied from the
+CC fortran-90 MODN_PARA module to be passed to the
+CC fortran-77 part of TRACE.
+CC LVERT : copy of LVERTI, .TRUE. if horizontal section activated
+CC LHOR : copy of LHORIZ, .TRUE. if vertical section activated.
+CC
+CC Common TEMH: Horizontal section grid information
+CC ZZXX : Meso-NH X coordinate values for the current data points
+CC ZZXY : Meso-NH Y coordinate values for the current data points
+CC IIMAX : X array dimension
+CC IJMAX : Y array dimension
+CC
+CC REFERENCE
+CC ---------
+CC
+CC MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+CC + Book1: Concepts and Fundamentals, to appear in 1994;
+CC + Book2: Technical Reference and Flowcharts, to appear in 1994;
+CC + Book3: Tutorial, November 1994.
+CC
+CC NCAR Graphics Technical documentation, UNIX version 3.2,
+CC Scientific computing division, NCAR/UCAR, Boulder, USA.
+CC Volume 1: Fundamentals, Vers. 1, May 1993
+CC Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+CC
+CC AUTHOR
+CC ------
+CC
+CC J. Duron * Laboratoire d'Aerologie *
+CC
+CC MODIFICATIONS
+CC -------------
+CC Original 01/07/94
+CC Updated PM 24/01/95
+C-------------------------------------------------------------------------------
+C
+C* 0. DECLARATIONS
+C ------------
+C
+C>>>>>>>DRAGOON NOTICE: I ENFORCED "IMPLICIT NONE" IT'S WISE CHECKING...
+C
+ IMPLICIT NONE
+C
+C* 0.1 Dummy arguments
+C
+ INTEGER IMAP
+ REAL XINP,YINP
+ REAL XOTP,YOTP
+C
+C* 0.1 Commons
+C
+ COMMON/TEMV/ZWORKZ,ZZDS,INX,INY
+ COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+ COMMON/TEMH/ZZXX,ZZXY,IIMAX,IJMAX
+#include "big.h"
+C REAL ZWORKZ(600,300),ZZDS(600),ZZXX(600),ZZXY(300)
+c REAL ZWORKZ(1000,400),ZZDS(1000),ZZXX(1000),ZZXY(400)
+ REAL ZWORKZ(N2DVERTX,2500),ZZDS(N2DVERTX)
+ REAL ZZXX(N2DVERTX),ZZXY(N2DVERTX)
+C REAL ZWORKZ(200,200),ZZDS(200),ZZXX(200),ZZXY(200)
+ LOGICAL LVERT,LHOR,LPT,LXABS
+ INTEGER INX,INY,IIMAX,IJMAX
+C
+C* 0.2 Local variables
+C
+c REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZZZXY
+C DIMENSION ZZZXY(1000,400)
+C DIMENSION ZZZXY(200,200)
+C REAL ZZZXY
+ INTEGER LL,JJ,I,J,IX,IY,IXP1,IYP1
+ REAL ZDIFX,ZX1,ZX2,ZY,ZDIFY,ZW1,ZW2,ZW3,ZW4,Z1,Z2,ZR
+
+C
+C------------------------------------------------------------------------------
+C
+C* 1. RE-MAPS THE CONTOUR POINTS ONTO THE STRECHED DISPLAY COORDINATES
+C ----------------------------------------------------------------
+C
+C* 1.1 Stores horizontal section's Y in a 2D workarray
+C
+c IF(ALLOCATED(ZZZXY))THEN
+c DEALLOCATE(ZZZXY)
+c ENDIF
+c print *,' MON CPMPXY A MOI',XINP,YINP
+C PRINT *,' In CPMPXY IMAP=',IMAP
+ IF(IMAP.EQ.4)THEN
+C PRINT *,' In CPMPXY LMAX=',INX
+c IF(LHOR)THEN
+c ALLOCATE(ZZZXY(1000,400))
+c LL=IIMAX
+c JJ=IJMAX
+
+c DO 1 I=1,LL
+c DO 2 J=1,JJ
+c DO 1 J=1,JJ
+c DO 2 I=1,LL
+c ZZZXY(I,J)=ZZXY(J)
+c2 CONTINUE
+c1 CONTINUE
+c ENDIF
+C
+C* 1.2 Computes streched X's
+C
+C Nearest gridpoint is located in fractionnal coordinates,
+C distance to nearest gridpoint is computed, and converted
+C to Meso NH true location (NCAR user coordinates).
+C
+ IX=INT(XINP)
+C IF(FLOAT(IX)+.989.LE.XINP)IX=IX+1
+ ZDIFX=XINP-FLOAT(IX)
+c print *,' XINP IX ZDIFX LHOR+V ',XINP,IX,ZDIFX,LHOR,LVERT
+
+ IF(LVERT)THEN
+ ZX1=ZZDS(MAX(IX,1))
+ ZX2=ZZDS(MIN(IX+1,INX))
+C PRINT *,' cpmpxy XINP IX',XINP,IX,' ZX1 2',ZX1,ZX2
+ ELSE
+ ZX1=ZZXX(MAX(IX,1))
+ ZX2=ZZXX(MIN(IX+1,IIMAX))
+C PRINT *,' cpmpxy XINP IX',XINP,IX,' ZX1 2',ZX1,ZX2
+ ENDIF
+c PRINT *,' cpmpxy XINP IX',XINP,IX,' ZX1 2',ZX1,ZX2
+ XOTP=ZX1+ZDIFX*(ZX2-ZX1)
+
+C
+C* 1.3 Computes streched Y's
+C
+C Same as above, but altitudes are used here, when
+C LVERT=.T. Here the four surrounding corners in
+C fractional space are located. And a 2D linear
+C interpolation is performed to remap onto true
+C altitudes and true distances
+C
+ ZY=YINP
+ IY=INT(ZY)
+C IF(FLOAT(IY)+.989.LE.YINP)IY=IY+1
+ ZDIFY=ZY-FLOAT(IY)
+
+c print *,' INX,INY ',INX,INY
+ IF(LVERT)THEN
+c PRINT *,' cpmpxy YINP IY',YINP,IY
+ IXP1=MIN(INX,IX+1)
+ IYP1=MIN(INY,IY+1)
+ IF(LPT .AND. LXABS)THEN
+C Cas LPXT=.T. et LXABSC=.T.
+C Cas profil horizontal // X . Permutation volontaire des indices I et J
+C car chargement (pour des pbs de place memoire) des temps en I (alors qu'ils
+C sont representes en Y) et des valeurs en J alors qu'elles sont representees
+C en abscisse (Chargement dans PVFCT)
+C Nota : les X sont eux charges normalement dans ZZDS (de 1 a INX)
+C LPT=LPXT
+ ZW1=ZWORKZ(IY,IX)
+ ZW2=ZWORKZ(IYP1,IX)
+ ZW3=ZWORKZ(IY,IXP1)
+ ZW4=ZWORKZ(IYP1,IXP1)
+ ELSE
+ ZW1=ZWORKZ(IX,IY)
+ ZW2=ZWORKZ(IX,IYP1)
+ ZW3=ZWORKZ(IXP1,IY)
+ ZW4=ZWORKZ(IXP1,IYP1)
+ ENDIF
+ Z1=ZW1+ZDIFY*(ZW2-ZW1)
+ Z2=ZW3+ZDIFY*(ZW4-ZW3)
+ ZR=Z1+ZDIFX*(Z2-Z1)
+ ELSE
+ ZW1=ZZXY(MAX(IY,1))
+ ZW2=ZZXY(MIN(IY+1,IJMAX))
+ ZR=ZW1+ZDIFY*(ZW2-ZW1)
+ ENDIF
+ YOTP=ZR
+c PRINT *,' xotp,yotp',xotp,yotp
+ END IF
+
+c IF(ALLOCATED(ZZZXY))THEN
+c DEALLOCATE(ZZZXY)
+c ENDIF
+
+ RETURN
+C
+C----------------------------------------------------------------------------
+C
+C* 2. EXIT
+C ----
+C
+ END
+C----------------------------------------------------------------------------
+C
+C $Id$
+C
+C***********************************************************************
+C P A C K A G E E Z M A P - I N T R O D U C T I O N
+C***********************************************************************
+C
+C This file contains implementation instructions and the code for the
+C package EZMAP. Banners like the one above delimit the major sections
+C of the file. The code itself is separated into three sections: user-
+C level routines, internal routines, and the block data routine which
+C determines the default values of internal parameters. Within each
+C section, routines appear in alphabetical order.
+C
+C***********************************************************************
+C P A C K A G E E Z M A P - I M P L E M E N T A T I O N
+C***********************************************************************
+C
+C The EZMAP package is written in FORTRAN-77 and should be relatively
+C easy to implement. The outline data required may be generated by
+C running the program
+C
+C PROGRAM CONVRT
+C DIMENSION FLIM(4),PNTS(200)
+C REWIND 1
+C REWIND 2
+C 1 READ (1,3,END=2) NPTS,IGID,IDLS,IDRS,(FLIM(I),I=1,4)
+C IF (NPTS.GT.1) READ (1,4,END=2) (PNTS(I),I=1,NPTS)
+C WRITE (2) NPTS,IGID,IDLS,IDRS,(FLIM(I),I=1,4),(PNTS(I),I=1,NPTS)
+C GO TO 1
+C 2 STOP
+C 3 FORMAT (4I4,4F8.3)
+C 4 FORMAT (10F8.3)
+C END
+C
+C with the EZMAP card-image dataset on unit 1. The output file, on unit
+C 2, contains the binary outline data to be used by EZMAP. The EZMAP
+C routine MAPIO (which see) must then be modified to access this file.
+C
+C***********************************************************************
+C T H E C O D E - U S E R - L E V E L R O U T I N E S
+C***********************************************************************
+C
+ SUBROUTINE MAPDRW
+C
+C Declare required common blocks. See MAPBD for descriptions of these
+C common blocks and the variables in them.
+C
+#if defined(NCL511)
+ COMMON /MAPCM4/ GRDR,GRID,GRLA,GRLO,GRPO,OTOL,PDRE,PLA1,PLA2,
+ + PLA3,PLA4,PLB1,PLB2,PLB3,PLB4,PLNO,PLTO,ROTA,
+ + SRCH,XLOW,XROW,YBOW,YTOW,IDOT,IDSH,IDTL,ILCW,
+ + ILTS,JPRJ,ELPF,INTF,LBLF,PRMF
+ DOUBLE PRECISION GRDR,GRID,GRLA,GRLO,GRPO,OTOL,PDRE,PLA1,PLA2,
+ + PLA3,PLA4,PLB1,PLB2,PLB3,PLB4,PLNO,PLTO,ROTA,
+ + SRCH,XLOW,XROW,YBOW,YTOW
+ INTEGER IDOT,IDSH,IDTL,ILCW,ILTS,JPRJ
+ LOGICAL ELPF,INTF,LBLF,PRMF
+ SAVE /MAPCM4/
+#else
+ COMMON /MAPCM4/ INTF,JPRJ,PHIA,PHIO,ROTA,ILTS,PLA1,PLA2,PLA3,PLA4,
+ + PLB1,PLB2,PLB3,PLB4,PLTR,GRID,IDSH,IDOT,LBLF,PRMF,
+ + ELPF,XLOW,XROW,YBOW,YTOW,IDTL,GRDR,SRCH,ILCW,GRLA,
+ + GRLO,GRPO
+ LOGICAL INTF,LBLF,PRMF,ELPF
+ SAVE /MAPCM4/
+#endif
+ COMMON/EPAISCONT/ZLWCONT
+ COMMON/FDC/IFDC
+
+C
+C Initialize the package, draw and label the grid, and draw outlines.
+C
+c print *,' INTF ',INTF
+ IF (INTF) CALL MAPINT
+ CALL MAPGRD
+ CALL MAPLBL
+ CALL GQLWSC(IERR,ZWIDTH)
+ CALL GSLWSC(ZLWCONT)
+C CALL GSLWSC(5.)
+ IF(IFDC .EQ. 1 .OR. IFDC .EQ. 3)THEN
+C IF(IFDC .NE. 0)THEN
+ CALL MPLNDR('Earth..1',3)
+c print *,' MAPDRW AP MPLNDR( IFDC= ',IFDC
+ ENDIF
+C CALL MAPLOT
+ CALL GSLWSC(ZWIDTH)
+C
+ RETURN
+ END
+C ###############################################
+ SUBROUTINE VVUMXY (X,Y,U,V,UVM,XB,YB,XE,YE,IST)
+C ###############################################
+C
+C
+CC**** *VVUMXY* - Maps velocity vectors onto the Meso-NH coordinate system
+CC**** for horizontal cross-sections (so far)
+CC
+CC PURPOSE
+CC -------
+C Maps velocity vectors onto the Meso-NH coordinate system
+C for horizontal cross-sections. This routine is called directly by
+C VVINIT and VVECTR NCAR uitilities to draw wind or flux vectors
+C making allowance for variable mesh sizes. For the time being,
+C only the case of horizontal cross-section is adressed, vertical
+C cross-sections vectors are not yet implemented.
+C
+CC** METHOD
+CC ------
+CC
+CC With the settings used in TRACE (i.e. parameter SET=0, and IMAP=4),
+CC VVUMXY receives arrow locations (X,Y) as grid array indices (values
+CC ranging between 1 and IIMAX or IJMAX), and wind components (U,V) in
+CC Meso-NH physical units (m/s for winds) from VVINIT or VVECTR.
+CC First, VVUMXY converts the locations of the vector starting points to
+CC the Meso-NH x- and y- coordinates by using the Meso-NH gridpoint
+CC locations given in arrays ZZX and ZZY, and these arrow locations are
+CC finally converted to the NCAR normalized device coordinate system by CUFX
+CC or CUFY calls.
+CC Next, the wind components are converted into arrow lengthes expressed
+CC in NCAR nomalized device coordinates using the SXDC and SYDC scale
+CC factors (these later being provided automatically by VVINIT).
+CC Finally VVUMXY returns the vector endpoint coordinates (XE,YE) computed
+CC by adding origin locations and arrow lengthes, both expressed in NCAR
+CC normalized device coordinates (See NCAR User Guide "Fundamentals",
+CC Appendix A, p345 section 1).
+CC
+CC NOTICE:
+CC ------
+CC
+CC - This calculation assumes that the plotted arrows origins are located on
+CC one of the model grids, and that both wind components are colocated. The
+CC necessary calculations are done by TRACE. This VVUMXY routine is probably
+CC not suitable to plot vectors at arbitrary locations between model
+CC gridpoints.
+CC - Many usefull informations on NCAR vector plots are in form of man pages.
+CC See "man vectors-params" for the description of the tunable parameters
+CC of VVINIT and VVECTR, see "man vvumxy" for the custom mapping of arrows
+CC onto the user coordinate space.
+CC - Using this routine assumes that the NCAR internal "IMAP" parameter
+CC is given the value 4 (arbitrary convention).
+CC - VVUMXY and the NCAR graphical utilities are NOT written
+CC in Fortran 90, but in Fortran 77.. This sub-section of TRACE
+CC does not follow the Meso-NH usual rules: it has to be using
+CC COMMON stacks with static memory allocations.
+CC
+CC EXTERNAL
+CC --------
+CC
+CC CUFX : routine to convert a NCAR user coordinate X value into its
+CC NCAR normalized device coordinate equivalent.
+CC CUFY : routine to convert a NCAR user coordinate Y value into its
+CC NCAR normalized device coordinate equivalent.
+CC
+CC EXPLICIT ARGUMENTS
+CC ------------------
+CC
+CC X,Y : (input) position of the vector origin in the grid array index
+CC space (values ranging between 1 and IIMAX or IJMAX, the size
+CC of post-processing section of the Meso-NH arrays),
+CC U,V : (input) vector components from the U,V arrays for this position
+CC UVM : (input, not used) magnitude of the U,V components
+CC XB,YB: (output) starting point of the vector in the NCAR normalized
+CC device coordinate system
+CC XE,YE: (output) ending point of the vector in the NCAR normalized
+CC device coordinate system
+CC IST : (output, not used) status results of the mapping: 0 indicates
+CC success
+CC
+CC NOTICE: All these dummy arguments are required
+CC ------ by the NCAR CALLS
+CC
+CC IMPLICIT ARGUMENTS
+CC ------------------
+CC Common VVMAP: Mapping information provided by the NCAR package
+CC IMAP : Map projection selector, has to be 4 for present TRACE
+CC implementation
+CC SXDC : X Scale factor to convert physical vector component values to
+CC normalized device coordinate values.
+CC SYDC : Y Scale factor to convert physical vector component values to
+CC normalized device coordinate values.
+CC
+CC Common LOGI: Section geometry information flags copied from the
+CC fortran-90 MODN_PARA module to be passed to the
+CC fortran-77 part of TRACE (not used so far).
+CC LVERT : copy of LVERTI, .TRUE. if horizontal section activated
+CC LHOR : copy of LHORIZ, .TRUE. if vertical section activated.
+CC
+CC Common TEMH: Horizontal section grid information
+CC ZZX : Meso-NH X coordinate values for the current data points
+CC ZZY : Meso-NH Y coordinate values for the current data points
+CC IIMAX : X array dimension of the postprocessing Meso-NH array section
+CC IJMAX : Y array dimension of the postprocessing Meso-NH array section
+CC
+CC REFERENCE
+CC ---------
+CC
+CC MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+CC + Book1: Concepts and Fundamentals, to appear in 1994;
+CC + Book2: Technical Reference and Flowcharts, to appear in 1994;
+CC + Book3: Tutorial, November 1994.
+CC
+CC NCAR Graphics Technical documentation, UNIX version 3.2,
+CC Scientific computing division, NCAR/UCAR, Boulder, USA.
+CC Volume 1: Fundamentals, Vers. 1, May 1993
+CC Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+CC
+CC AUTHOR
+CC ------
+CC
+CC J. Duron * Laboratoire d'Aerologie *
+CC
+CC MODIFICATIONS
+CC -------------
+CC Original 01/07/94
+CC Updated PM 26/01/95
+C-------------------------------------------------------------------------------
+C
+C* 0. DECLARATIONS
+C ------------
+C
+C>>>>>>>DRAGOON NOTICE: I ENFORCED "IMPLICIT NONE" IT'S WISE CHECKING...
+C
+ USE MODD_PVT
+C Janvier 2001
+ USE MODD_RESOLVCAR
+ USE MODN_PARA
+C Janvier 2001
+ IMPLICIT NONE
+C
+C* 0.0 Dummy arguments
+C
+ REAL X, Y,U,V,UVM,XB,YB,XE,YE
+ REAL CUFX, CUFY
+ INTEGER IST
+C
+C* 0.1 Commons
+C
+ COMMON /VVMAP/
+ + IMAP ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + SXDC ,SYDC ,NXCT ,NYCT ,
+ + RLEN ,LNLG ,INVX ,INVY ,
+ + ITRT ,IWCT ,FW2W ,FH2H ,
+ + DVMN ,DVMX ,RBIG ,IBIG
+C
+ SAVE /VVMAP/
+ REAL XVPL,XVPR,YVPB,YVPT,WXMN,WXMX,WYMN,WYMX,XLOV,XHIV,YLOV,YHIV,
+ + SXDC,SYDC,RLEN,FW2W,FH2H,DVMN,DVMX,RBIG
+ INTEGER IMAP,NXCT,NYCT,LNLG,INVX,INVY,ITRT,IWCT,IBIG
+C
+ COMMON/LOGI/LVERT,LHOR,LPT,LXABS
+ LOGICAL LVERT,LHOR,LPT,LXABS
+C
+ COMMON/TEMH/ZZX,ZZY,IIMAX,IJMAX
+ COMMON/TEMV/ZWORKZ,ZZDS,INX,INY
+#include "big.h"
+C DIMENSION ZZX(200),ZZY(200)
+c DIMENSION ZZX(1000),ZZY(400)
+ DIMENSION ZZX(N2DVERTX),ZZY(N2DVERTX)
+ REAL ZZX,ZZY
+c REAL ZWORKZ(1000,400),ZZDS(1000)
+ REAL ZWORKZ(N2DVERTX,2500),ZZDS(N2DVERTX)
+C REAL ZWORKZ(200,200),ZZDS(200)
+ INTEGER IIMAX,IJMAX
+ INTEGER INX,INY
+ INTEGER ICOLUVG
+C Janvier 2001
+ INTEGER IER,ICLIP
+ REAL ZBID(4)
+C Janvier 2001
+C
+C* 0.2 Local variables
+C
+ REAL PDTOR,PRTOD,P1XPI,P2XPI,P1D2PI,P5D2PI
+C
+ INTEGER IX,IY
+C
+C
+C* 0.3 Math constants initialization (not used here)
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+ DATA ICOLUVG/1/
+C
+C---------------------------------------------------------------------
+C
+C* 1. VECTOR ARROW LOCATION AND SCALING
+C ---------------------------------
+C
+C* 1.1 Converts vector starting point from section array indices
+C* to normalized device coordinates
+C
+C print *,' MON VVU....A MOI'
+ IF(IMAP.EQ.4)THEN
+C print *, ' X Y',X,Y,' SXDC SYDC',SXDC,SYDC
+C print *, ' X Y',X,Y
+C
+C NOTICE: It is mandatory to use nearest integer function NINT here
+C
+ IX=NINT(X)
+ IY=NINT(Y)
+C
+ IF(LHOR)THEN
+ X=ZZX(IX)
+ Y=ZZY(IY)
+ ELSE
+C Janvier 2001
+ IF(LPV)THEN
+ IF(IX == NPROFILE)THEN
+ X=(ZZDS(1) + ZZDS(NLMAX))/2
+ Y=ZWORKZ(IX,IY)
+ ELSE
+ RETURN
+ ENDIF
+ ELSE
+C Janvier 2001
+ X=ZZDS(IX)
+ Y=ZWORKZ(IX,IY)
+C Janvier 2001
+ ENDIF
+ CALL GQCLIP(IER,ICLIP,ZBID)
+ IF(ICLIP == 0 .AND. (Y > XHMAX .OR. Y < XHMIN))THEN
+ RETURN
+ ENDIF
+C Janvier 2001
+ ENDIF
+C
+ XB=CUFX(X)
+ YB=CUFY(Y)
+C PRINT *,' IX IY ',IX,IY,' ZZX(IX)ZZY(IY) ',
+C 1 ZZX(IX),ZZY(IY)
+
+C PRINT *,'ZZDS(IX),ZWORKZ(IX,IY) ',ZZDS(IX),ZWORKZ(IX,IY)
+C* 1.2 End of vector normalized device coordinate location
+C
+ XE=XB+U*SXDC
+ YE=YB+V*SYDC
+C PRINT *,' XB YB XE YE ',XB,YB,XE,YE
+C PRINT *,' U V SXDC SYDC ',U,V,SXDC,SYDC
+ ENDIF
+C Essai couleur Mars 2000
+ IF(LCOLPVT)THEN
+ CALL GSPLCI(NCOL2DUV(IX,IY))
+ ELSE
+C IF(NCOLUVG .NE. ICOLUVG)THEN
+ CALL GSPLCI(NCOLUVG)
+ ICOLUVG=NCOLUVG
+C ENDIF
+ ENDIF
+ RETURN
+C
+C-----------------------------------------------------------------------------
+C
+C* 2. EXIT
+C ----
+C
+ END
+C
+C $Id$
+C
+ SUBROUTINE GERHND(ERRNR,FCTID,ERRFIL)
+C
+C ERROR HANDLING
+C
+ INTEGER ERRNR,FCTID,ERRFIL
+C
+#if defined(NCL511)
+ include 'gkscom-5.1.1.h'
+#else
+ include 'gkscom.h'
+#endif
+C
+C Special common blocks containing current error number
+C and file identifier.
+C
+ COMMON /GKERR1/ ENUM
+ COMMON /GKERR2/ FNAME
+ INTEGER ENUM
+ CHARACTER*6 FNAME
+C
+C Record number of error message and maximum number of allowable
+C errors before abort.
+C
+C AUGMENTATION VOLONTAIRE DE MAXERR (AVANT = 10)
+ DATA MNERR,MAXERR/0,1000/
+C
+ IF (CUFLAG.EQ.-1 .OR. ERRNR.NE.-109) MNERR = MNERR+1
+ IF (MNERR .GT. MAXERR) THEN
+ CALL GERLOG(-107,FCTID,ERRFIL)
+ STOP
+ ENDIF
+ ENUM = ERRNR
+ FNAME = GNAM(FCTID+1)
+ CALL GERLOG(ERRNR,FCTID,ERRFIL)
+C
+ RETURN
+ END
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C $Id$
+C
+C***********************************************************************
+C L A B E L B A R - I N T R O D U C T I O N
+C***********************************************************************
+C
+C This file contains materials for a package which draws "label bars" -
+C horizontal or vertical rectangles divided into boxes (each of which
+C is either colored or filled with a pattern), and having labels next
+C to it, which serves as a key for a solid-filled plot.
+C
+C***********************************************************************
+C L A B E L B A R - I M P L E M E N T A T I O N
+C***********************************************************************
+C
+C LABELBAR is written in standard FORTRAN 77. No special effort should
+C be required to implement it. It does require various other parts of
+C the NCAR Graphics package to have been implemented; in particular, it
+C requires the package SOFTFILL, the support routine SETER, and various
+C routines from SPPS.
+C
+C***********************************************************************
+C L A B E L B A R - U S E R - L E V E L R O U T I N E S
+C***********************************************************************
+C
+ SUBROUTINE LBLBAR_FORDIACHRO(IHOV,XLEB,XREB,YBEB,YTEB,NBOX,
+ + WSFB,HSFB,LFIN,
+ + IFTP,LLBS,NLBS,LBAB)
+C
+ DIMENSION LFIN(*)
+ CHARACTER*(*) LLBS(*)
+C
+C This routine draws a horizontal or vertical label bar to serve as a
+C key for a solid-filled plot.
+C
+C IHOV is 0 if a horizontal label bar is to be drawn, 1 if a vertical
+C label bar is to be drawn.
+C
+C XLEB is a value between 0 and 1, specifying the position of the left
+C edge of the bar.
+C
+C XREB is a value between 0 and 1, specifying the position of the right
+C edge of the bar.
+C
+C YBEB is a value between 0 and 1, specifying the position of the bottom
+C edge of the bar.
+C
+C YTEB is a value between 0 and 1, specifying the position of the top
+C edge of the bar.
+C
+C ABS(NBOX) is the number of boxes into which the bar is to be divided.
+C If NBOX is positive, the boxes will be outlined after being filled;
+C if NBOX is negative, this will not be done.
+C
+C WSFB and HSFB are the width and height, respectively, of each little
+C solid-filled box, as fractions of the rectangles resulting from the
+C division of the bar into ABS(NBOX) pieces.
+C
+C LFIN is a list of indices, each of which specifies, in some manner,
+C how one of the solid-filled boxes is to be filled. (For example,
+C each may be a color index.)
+C
+C IFTP specifies the type of solid fill to be used. If IFTP is zero,
+C the routine SFSGFA, in the package SOFTFILL, will be called, with
+C an index from LFIN as the value of the argument ICI. (By default,
+C this will result in color fill; the value of the SOFTFILL internal
+C parameter 'TY' may be changed to select some other kind of fill by
+C SFSGFA.) If IFTP is non-zero, the user-replaceable routine LBFILL
+C will be used to fill the boxes; the default version of this routine
+C just does color fill.
+C
+C LLBS is a list of labels for the solid-filled boxes.
+C
+C NLBS is the number of labels in the list LLBS. If NLBS is equal to
+C ABS(NBOX)-1, then label I applies to the line separating box I from
+C box I+1. If NLBS is equal to NBOX, then label I applies to box I. If
+C NLBS is equal to ABS(NBOX)+1, then labels 1 and NLBS apply to the left
+C and right ends (if IHOV is non-zero, the bottom and top ends) of the
+C whole color bar; for values of I not equal to 1 or NLBS, label I
+C applies to the line separating box I-1 from box I.
+C
+C LBAB is a flag having the value 0 if the bar is to be unlabelled, 1
+C if the labels are to be below a horizontal bar or to the right of a
+C vertical bar, 2 if the labels are to be above a horizontal bar or to
+C the left of a vertical bar, 3 if the labels are to be on both sides
+C of the bar.
+C
+C
+C Declare the common block where internal parameters are stored.
+C
+ COMMON /LBCOMN/ ICBL,ICFL,ICLB,WOBL,WOFL,WOLB
+ SAVE /LBCOMN/
+ COMMON/GENF/NBCU
+C
+C Declare the block data routine external to force it to load.
+C
+ EXTERNAL LBBLDA
+C
+C Define local arrays to hold X and Y coordinates of boxes.
+C
+ DIMENSION XCRA(5),YCRA(5)
+C
+C Define local arrays for use as work arrays by the routine SFSGFA.
+C
+ DIMENSION RWRK(6),IWRK(8)
+C
+C Save the current SET parameters and arrange for the use of normalized
+C device coordinates.
+C
+ CALL GETSET (XLVP,XRVP,YBVP,YTVP,XLWD,XRWD,YBWD,YTWD,LNLG)
+ CALL SET ( 0., 1., 0., 1., 0., 1., 0., 1., 1)
+C
+C Compute the width and height of each section of the bar and the
+C coordinates of the edges of the first solid-filled box.
+C
+ IF (IHOV.EQ.0) THEN
+ WSOB=(XREB-XLEB)/REAL(ABS(NBOX))
+ WINC=WSOB
+ HSOB=YTEB-YBEB
+ HINC=0.
+ XLB1=XLEB+.5*(1.-WSFB)*WSOB
+ XRB1=XLB1+WSFB*WSOB
+ IF (LBAB.EQ.1) THEN
+ YBB1=YTEB-HSFB*HSOB
+ YTB1=YTEB
+ ELSE IF (LBAB.EQ.2) THEN
+ YBB1=YBEB
+ YTB1=YBEB+HSFB*HSOB
+ ELSE
+ YBB1=YBEB+.5*(1.-HSFB)*HSOB
+ YTB1=YTEB-.5*(1.-HSFB)*HSOB
+ END IF
+ ELSE
+ WSOB=XREB-XLEB
+ WINC=0.
+ HSOB=(YTEB-YBEB)/REAL(ABS(NBOX))
+ HINC=HSOB
+ IF (LBAB.EQ.1) THEN
+ XLB1=XLEB
+ XRB1=XLEB+WSFB*WSOB
+ ELSE IF (LBAB.EQ.2) THEN
+ XLB1=XREB-WSFB*WSOB
+ XRB1=XREB
+ ELSE
+ XLB1=XLEB+.5*(1.-WSFB)*WSOB
+ XRB1=XREB-.5*(1.-WSFB)*WSOB
+ END IF
+ YBB1=YBEB+.5*(1.-HSFB)*HSOB
+ YTB1=YBB1+HSFB*HSOB
+ END IF
+C
+C Draw the bar by filling all of the individual boxes.
+C
+ CALL GQFACI (IERR,ISFC)
+ IF (IERR.NE.0) THEN
+ CALL SETER ('LBLBAR - ERROR EXIT FROM GQFACI',1,2)
+ STOP
+ END IF
+C
+ IF (ICFL.GE.0) THEN
+ CALL GQPLCI (IERR,ISPC)
+ IF (IERR.NE.0) THEN
+ CALL SETER ('LBLBAR - ERROR EXIT FROM GQPLCI',2,2)
+ STOP
+ END IF
+ CALL GSPLCI (ICFL)
+ END IF
+C
+ IF (WOFL.GT.0.) THEN
+ CALL GQLWSC (IERR,STLW)
+ IF (IERR.NE.0) THEN
+ CALL SETER ('LBLBAR - ERROR EXIT FROM GQLWSC',3,2)
+ STOP
+ END IF
+ CALL GSLWSC (WOFL)
+ END IF
+C
+ DO 101 I=1,ABS(NBOX)
+ XCRA(1)=XLB1+REAL(I-1)*WINC
+ YCRA(1)=YBB1+REAL(I-1)*HINC
+ XCRA(2)=XRB1+REAL(I-1)*WINC
+ YCRA(2)=YCRA(1)
+ XCRA(3)=XCRA(2)
+ YCRA(3)=YTB1+REAL(I-1)*HINC
+ XCRA(4)=XCRA(1)
+ YCRA(4)=YCRA(3)
+ XCRA(5)=XCRA(1)
+ YCRA(5)=YCRA(1)
+ IF (IFTP.EQ.0) THEN
+ CALL SFSGFA (XCRA,YCRA,4,RWRK,6,IWRK,8,LFIN(I))
+ ELSE
+ CALL LBFILL (IFTP,XCRA,YCRA,5,LFIN(I))
+ END IF
+ 101 CONTINUE
+C
+ CALL GSFACI (ISFC)
+ IF (ICFL.GE.0) CALL GSPLCI (ISPC)
+ IF (WOFL.GT.0.) CALL GSLWSC (STLW)
+C
+C If it is to be done, outline the boxes now.
+C
+ IF (NBOX.GT.0) THEN
+C
+ IF (ICBL.GE.0) THEN
+ CALL GQPLCI (IERR,ISPC)
+ IF (IERR.NE.0) THEN
+ CALL SETER ('LBLBAR - ERROR EXIT FROM GQPLCI',4,2)
+ STOP
+ END IF
+ CALL GSPLCI (ICBL)
+ END IF
+C
+ IF (WOBL.GT.0.) THEN
+ CALL GQLWSC (IERR,STLW)
+ IF (IERR.NE.0) THEN
+ CALL SETER ('LBLBAR - ERROR EXIT FROM GQLWSC',5,2)
+ STOP
+ END IF
+ CALL GSLWSC (WOBL)
+ END IF
+C
+ DO 102 I=1,ABS(NBOX)
+ XCRA(1)=XLB1+REAL(I-1)*WINC
+ YCRA(1)=YBB1+REAL(I-1)*HINC
+ XCRA(2)=XRB1+REAL(I-1)*WINC
+ YCRA(2)=YCRA(1)
+ XCRA(3)=XCRA(2)
+ YCRA(3)=YTB1+REAL(I-1)*HINC
+ XCRA(4)=XCRA(1)
+ YCRA(4)=YCRA(3)
+ XCRA(5)=XCRA(1)
+ YCRA(5)=YCRA(1)
+ IF (IHOV.EQ.0) THEN
+ IF (I.EQ.1.OR.WSFB.NE.1.) THEN
+ CALL GPL (5,XCRA,YCRA)
+ ELSE
+ CALL GPL (4,XCRA,YCRA)
+ END IF
+ ELSE
+ IF (I.EQ.1.OR.HSFB.NE.1.) THEN
+ CALL GPL (5,XCRA,YCRA)
+ ELSE
+ CALL GPL (4,XCRA(2),YCRA(2))
+ END IF
+ END IF
+ 102 CONTINUE
+C
+ IF (ICBL.GE.0) CALL GSPLCI (ISPC)
+ IF (WOBL.GT.0.) CALL GSLWSC (STLW)
+
+ END IF
+C
+C If labelling is to be done at all ...
+C
+ IF (LBAB.NE.0) THEN
+C
+C ... save the current setting of the PLOTCHAR "text extent" parameter
+C and reset it to force computation of "text extent" quantities.
+C
+ CALL PCGETI ('TE - TEXT EXTENT FLAG',ITEX)
+ CALL PCSETI ('TE - TEXT EXTENT FLAG',1)
+C
+C Find the dimensions of the largest label in the list of labels.
+C
+ WMAX=0.
+ HMAX=0.
+C
+ DO 104 I=1,NLBS
+ NCLB=LEN(LLBS(I))
+ 103 IF (LLBS(I)(NCLB:NCLB).EQ.' ') THEN
+ NCLB=NCLB-1
+ IF (NCLB.NE.0) GO TO 103
+ END IF
+ IF (NCLB.NE.0) THEN
+ CALL PLCHHQ (.5,.5,LLBS(I)(1:NCLB),.01,360.,0.)
+ CALL PCGETR ('DL - DISTANCE TO LEFT EDGE' ,DSTL)
+ CALL PCGETR ('DR - DISTANCE TO RIGHT EDGE' ,DSTR)
+ CALL PCGETR ('DB - DISTANCE TO TOP EDGE' ,DSTB)
+ CALL PCGETR ('DT - DISTANCE TO BOTTOM EDGE',DSTT)
+ WMAX=MAX(WMAX,DSTL+DSTR+.02)
+ HMAX=MAX(HMAX,DSTB+DSTT+.02)
+ END IF
+ 104 CONTINUE
+C
+C If the maximum height and width are undefined, quit.
+C
+ IF (WMAX.LE..02.OR.HMAX.LE..02) GO TO 107
+C
+C Determine the character width to be used and the resulting offset
+C distance to the bottom or top of the label.
+C
+C print *,' WSOB ',WSOB
+ IF(IHOV /= 0 .AND. NBCU <= 7 .AND. WSOB < .06)WSOB=.06
+C print *,' WSOB MODIFIE ',WSOB
+ IF (IHOV.EQ.0) THEN
+ HOLA=(1.-HSFB)*HSOB
+ IF (LBAB.GE.3) HOLA=HOLA/2.
+ WCHR=.01*MIN(WSOB/WMAX,HOLA/HMAX)
+ DSTB=(DSTB+.01)*(WCHR/.01)
+ DSTT=(DSTT+.01)*(WCHR/.01)
+ ELSE
+ WOLA=(1.-WSFB)*WSOB
+ IF (LBAB.GE.3) WOLA=WOLA/2.
+ WCHR=.01*MIN(WOLA/WMAX,HSOB/HMAX)
+ END IF
+C print *,' WCHR ',WCHR
+C
+C Draw the labels.
+C
+ CALL GQPLCI (IERR,ISCL)
+ IF (IERR.NE.0) THEN
+ CALL SETER ('LBLBAR - ERROR EXIT FROM GQPLCI',6,2)
+ STOP
+ END IF
+ CALL GQTXCI (IERR,ISCT)
+ IF (IERR.NE.0) THEN
+ CALL SETER ('LBLBAR - ERROR EXIT FROM GQTXCI',7,2)
+ STOP
+ END IF
+ IF (ICLB.LT.0) THEN
+ CALL GSPLCI (ISCT)
+ ELSE
+ CALL GSPLCI (ICLB)
+ CALL GSTXCI (ICLB)
+ END IF
+ IF (WOLB.GT.0.) THEN
+ CALL GQLWSC (IERR,STLW)
+ IF (IERR.NE.0) THEN
+ CALL SETER ('LBLBAR - ERROR EXIT FROM GQLWSC',8,2)
+ STOP
+ END IF
+ CALL GSLWSC (WOLB)
+ END IF
+C
+ IF (NLBS.LT.ABS(NBOX)) THEN
+ XLB1=XLB1+WINC
+ YBB1=YBB1+HINC
+C print *,'1 XLB1,YBB1 ',XLB1,YBB1
+ ELSE IF (NLBS.EQ.ABS(NBOX)) THEN
+ XLB1=XLB1+WSFB*WINC/2.
+ YBB1=YBB1+HSFB*HINC/2.
+C print *,'2 XLB1,YBB1 ',XLB1,YBB1
+ END IF
+C
+ DO 106 I=1,NLBS
+ NCLB=LEN(LLBS(I))
+ 105 IF (LLBS(I)(NCLB:NCLB).EQ.' ') THEN
+ NCLB=NCLB-1
+ IF (NCLB.NE.0) GO TO 105
+ END IF
+ IF (NCLB.NE.0) THEN
+ IF (IHOV.EQ.0) THEN
+ IF (LBAB.EQ.1.OR.LBAB.GE.3)
+ + CALL PLCHHQ (XLB1+REAL(I-1)*WSOB,YBB1-DSTT,
+ + LLBS(I)(1:NCLB),WCHR,0.,0.)
+ IF (LBAB.EQ.2.OR.LBAB.GE.3)
+ + CALL PLCHHQ (XLB1+REAL(I-1)*WSOB,YTB1+DSTB,
+ + LLBS(I)(1:NCLB),WCHR,0.,0.)
+ ELSE
+C IHOV /= 0 Barre verticale ; LBAB=1 Valeurs a dte ; LBAB=2 Valeurs a g
+C JDJDJD
+C IF (LBAB.EQ.1.OR.LBAB.GE.3)
+ IF (LBAB.EQ.1)
+ + CALL PLCHHQ (XRB1,YBB1+REAL(I-1)*HSOB,
+ + LLBS(I)(1:NCLB),WCHR,0.,-1.)
+ IF (LBAB.GE.3)
+ + CALL PLCHHQ (XRB1+WCHR,YBB1+REAL(I-1)*HSOB,
+ + LLBS(I)(1:NCLB),WCHR,0.,-1.)
+C JDJDJD
+C IF (LBAB.EQ.2.OR.LBAB.GE.3)
+ IF (LBAB.EQ.2)
+ + CALL PLCHHQ (XLB1,YBB1+REAL(I-1)*HSOB,
+ + LLBS(I)(1:NCLB),WCHR,0.,+1.)
+ IF (LBAB.GE.3)
+ + CALL PLCHHQ (XLB1-WCHR,YBB1+REAL(I-1)*HSOB,
+ + LLBS(I)(1:NCLB),WCHR,0.,+1.)
+ END IF
+ END IF
+ 106 CONTINUE
+C
+ CALL GSPLCI (ISCL)
+ IF (ICLB.GE.0) CALL GSTXCI (ISCT)
+ IF (WOLB.GT.0.) CALL GSLWSC (STLW)
+C
+C Restore the original setting of the PLOTCHAR text extent flag.
+C
+ 107 CALL PCSETI ('TE - TEXT EXTENT FLAG',ITEX)
+C
+ END IF
+C
+C Restore the original SET parameters.
+C
+ CALL SET (XLVP,XRVP,YBVP,YTVP,XLWD,XRWD,YBWD,YTWD,LNLG)
+C
+C Done.
+C
+ RETURN
+C
+ END
+C #################################################
+ SUBROUTINE SFILL(XWRK,YWRK,NWRK,IAREA,IGRP,NGRPS)
+C #################################################
+C
+C
+CC**** *SFILL* - Performs hatching of plot areas were the
+CC true altitude is lower than the topograpy
+CC
+CC PURPOSE
+CC -------
+C When contour plot is drawn, all the locations where the displayed
+C points are below the model topography have to be hatched. SFILL
+C detects these points and perform the hatching.
+C
+CC** METHOD
+CC ------
+CC
+CC In IMAGE, IMAGEv or IMCOU.., as the contour plots are prepared, the
+CC altitude of the displayed section points are checked to locate points
+CC lower than the local topography. When such points are found they are
+CC marked with a specific "area number" used by SFILL as a mask to
+CC decide where hatching has to be performed. See the NCAR manual to
+CC understand how "area numbers" work, this topic is slightly
+CC involved.. (NCAR contouring tutorial, Vol. 2, pages 12-19, page 120,
+CC and pages 130-133).
+CC
+CC To summarize, all the lines composing a plot are grouped by "edge
+CC groups" which may be individually accessed using "group numbers" to
+CC perform specific tasks. For the present purpose only the lines drawn
+CC by CONPACK are important, and they belong to group number 3.
+CC When the contours are computed, CONPACK assigns "area numbers" to the
+CC different sub-regions of the plot: typically screen points out of the
+CC model domain are given a negative area number, areas between
+CC isocontours receive area numbers greater than 2, with increasing area
+CC numbers from the lower contour to the higher one, and TRACE gives an
+CC area number of 2 to regions under the topography.
+CC The hatching is therefore performed by scanning the group and area
+CC numbers to locate the screen points to be hatched, as follows:
+CC - SFILL is called by CONPACK for each contour polygon, with XWRK-YWRK
+CC containing the NWRK points of the current contour, and IAREA-IGRP
+CC containing the corresponding group and area numbers;
+CC - First, the group number is checked to select CONPACK items only,
+CC - Second, the area number is checked to select underground areas,
+CC - If so, the hatching parameters are set (SP=.008, and AN=45 for
+CC slanting hatching) and the SFNORM pattern filling routine is called
+CC to fill the current contour (XWRK-YWRK) with the prescribed pattern.
+CC
+CC NOTICE: SFILL and the NCAR graphical utilities are NOT written
+CC ------ in Fortran 90, but in Fortran 77.. This sub-section of TRACE
+CC does not follow the Meso-NH usual rules: it has to be directly
+CC called by the NCAR CONPACK utility.
+CC
+CC EXTERNAL
+CC --------
+CC None
+CC
+CC EXPLICIT ARGUMENTS
+CC ------------------
+CC
+CC XWRK : x-coordinates (in NCAR fractional system) of the successive
+CC points forming a given contour enclosing a polygonal area.
+CC YWRK : y-coordinates (in NCAR fractional system) of the successive
+CC points forming a given contour enclosing a polygonal area.
+CC NWRK : Number of points in XWRK-YWRK to build the contour.
+CC IAREA: Area identifiers for the polygon defined by the XWRK-YWRK and
+CC for each of the NGRPS groups of edges in this plot.
+CC IGRP : Group identifiers for the polygon defined by the XWRK-YWRK and
+CC for each of the NGRPS groups of edges in this plot.
+CC NGRPS: Maximum number of edge groups defined in this plot.
+CC
+CC NOTICE: All these dummy arguments are required
+CC ------ by the NCAR CALLS
+CC
+CC IMPLICIT ARGUMENTS
+CC ------------------
+CC None
+CC
+CC REFERENCE
+CC ---------
+CC
+CC MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+CC + Book1: Concepts and Fundamentals, to appear in 1994;
+CC + Book2: Technical Reference and Flowcharts, to appear in 1994;
+CC + Book3: Tutorial, November 1994.
+CC
+CC NCAR Graphics Technical documentation, UNIX version 3.2,
+CC Scientific computing division, NCAR/UCAR, Boulder, USA.
+CC Volume 1: Fundamentals, Vers. 1, May 1993
+CC Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+CC
+CC AUTHOR
+CC ------
+CC
+CC J. Duron * Laboratoire d'Aerologie *
+CC
+CC MODIFICATIONS
+CC -------------
+CC Original 01/07/94
+CC Updated PM 24/01/95
+C-------------------------------------------------------------------------------
+C
+C* 0. DECLARATIONS
+C
+C>>>>>>>DRAGOON NOTICE: I ENFORCED "IMPLICIT NONE" IT'S WISE CHECKING...
+C
+ IMPLICIT NONE
+C
+C* 0.1 Dummy arguments
+C
+ REAL XWRK(*), YWRK(*)
+ INTEGER IAREA(*), IGRP(*)
+ INTEGER NGRPS,NWRK
+C
+C* 0.2 Local variables
+C
+ REAL RSCR(10000)
+ INTEGER ISCR(10000)
+ INTEGER IA,I,J
+C
+C------------------------------------------------------------------------------
+C
+C* 1. UNDERGROUND AREAS HATCHING
+C --------------------------
+C
+C* 1.1 Locates CONPACK contour edge lines (group number=3)
+C
+ DO I=1,NGRPS
+C print *,' IGRP IAREA',IGRP(I),IAREA(I),' I',I
+ IF(IGRP(I).EQ.3)IA=IAREA(I)
+ ENDDO
+C
+C* 1.2 Locates areas with number=2 (underground) and hatches
+C
+ IF(IA.eq.2)THEN
+C print *,'NWRK ',NWRK,' XWRK YWRK '
+ DO J=1,NWRK
+C PRINT *,XWRK(J),YWRK(J)
+ ENDDO
+ CALL SFSETR('SP',.008)
+ CALL SFSETI('AN',45)
+ CALL SFSETI('DO',0)
+ CALL SFSETI('CH',0)
+ CALL GSMKSC(1.)
+ CALL SFNORM(XWRK,YWRK,NWRK,RSCR,10000,ISCR,10000)
+ ENDIF
+C
+C-----------------------------------------------------------------------------
+C
+C* 2. EXIT
+C ----
+C
+ RETURN
+ END
+C
+C #################################################
+ SUBROUTINE SFILLH(XWRK,YWRK,NWRK,IAREA,IGRP,NGRPS)
+C #################################################
+C
+C
+CC**** *SFILLH* - Performs hatching of plot areas were the
+CC true altitude is lower than the topograpy
+CC
+CC PURPOSE
+CC -------
+C When contour plot is drawn, all the locations where the displayed
+C points are below the model topography have to be hatched. SFILLH
+C detects these points and perform the hatching.
+C
+CC** METHOD
+CC ------
+CC
+CC In IMAGE, IMAGEv or IMCOU.., as the contour plots are prepared, the
+CC altitude of the displayed section points are checked to locate points
+CC lower than the local topography. When such points are found they are
+CC marked with a specific "area number" used by SFILLH as a mask to
+CC decide where hatching has to be performed. See the NCAR manual to
+CC understand how "area numbers" work, this topic is slightly
+CC involved.. (NCAR contouring tutorial, Vol. 2, pages 12-19, page 120,
+CC and pages 130-133).
+CC
+CC To summarize, all the lines composing a plot are grouped by "edge
+CC groups" which may be individually accessed using "group numbers" to
+CC perform specific tasks. For the present purpose only the lines drawn
+CC by CONPACK are important, and they belong to group number 3.
+CC When the contours are computed, CONPACK assigns "area numbers" to the
+CC different sub-regions of the plot: typically screen points out of the
+CC model domain are given a negative area number, areas between
+CC isocontours receive area numbers greater than 2, with increasing area
+CC numbers from the lower contour to the higher one, and TRACE gives an
+CC area number of 2 to regions under the topography.
+CC The hatching is therefore performed by scanning the group and area
+CC numbers to locate the screen points to be hatched, as follows:
+CC - SFILLH is called by CONPACK for each contour polygon, with XWRK-YWRK
+CC containing the NWRK points of the current contour, and IAREA-IGRP
+CC containing the corresponding group and area numbers;
+CC - First, the group number is checked to select CONPACK items only,
+CC - Second, the area number is checked to select underground areas,
+CC - If so, the hatching parameters are set (SP=.008, and AN=45 for
+CC slanting hatching) and the SFNORM pattern filling routine is called
+CC to fill the current contour (XWRK-YWRK) with the prescribed pattern.
+CC
+CC NOTICE: SFILLH and the NCAR graphical utilities are NOT written
+CC ------ in Fortran 90, but in Fortran 77.. This sub-section of TRACE
+CC does not follow the Meso-NH usual rules: it has to be directly
+CC called by the NCAR CONPACK utility.
+CC
+CC EXTERNAL
+CC --------
+CC None
+CC
+CC EXPLICIT ARGUMENTS
+CC ------------------
+CC
+CC XWRK : x-coordinates (in NCAR fractional system) of the successive
+CC points forming a given contour enclosing a polygonal area.
+CC YWRK : y-coordinates (in NCAR fractional system) of the successive
+CC points forming a given contour enclosing a polygonal area.
+CC NWRK : Number of points in XWRK-YWRK to build the contour.
+CC IAREA: Area identifiers for the polygon defined by the XWRK-YWRK and
+CC for each of the NGRPS groups of edges in this plot.
+CC IGRP : Group identifiers for the polygon defined by the XWRK-YWRK and
+CC for each of the NGRPS groups of edges in this plot.
+CC NGRPS: Maximum number of edge groups defined in this plot.
+CC
+CC NOTICE: All these dummy arguments are required
+CC ------ by the NCAR CALLS
+CC
+CC IMPLICIT ARGUMENTS
+CC ------------------
+CC None
+CC
+CC REFERENCE
+CC ---------
+CC
+CC MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+CC + Book1: Concepts and Fundamentals, to appear in 1994;
+CC + Book2: Technical Reference and Flowcharts, to appear in 1994;
+CC + Book3: Tutorial, November 1994.
+CC
+CC NCAR Graphics Technical documentation, UNIX version 3.2,
+CC Scientific computing division, NCAR/UCAR, Boulder, USA.
+CC Volume 1: Fundamentals, Vers. 1, May 1993
+CC Volume 2: Contouring and mapping tutorial, Vers. 2, May 1993
+CC
+CC AUTHOR
+CC ------
+CC
+CC J. Duron * Laboratoire d'Aerologie *
+CC
+CC MODIFICATIONS
+CC -------------
+CC Original 01/07/94
+CC Updated PM 24/01/95
+C-------------------------------------------------------------------------------
+C
+C* 0. DECLARATIONS
+C
+C>>>>>>>DRAGOON NOTICE: I ENFORCED "IMPLICIT NONE" IT'S WISE CHECKING...
+C
+ IMPLICIT NONE
+C
+C* 0.1 Dummy arguments
+C
+ REAL XWRK(*), YWRK(*)
+ INTEGER IAREA(*), IGRP(*)
+ INTEGER NGRPS,NWRK
+C
+C* 0.2 Commons
+C
+C
+ COMMON/HACHAREA/IHACH(300)
+ INTEGER IHACH
+C* 0.3 Local variables
+C
+ REAL RSCR(50000)
+ INTEGER ISCR(50000)
+ INTEGER IA,I,J,N
+C
+ REAL ZSP(66)
+ INTEGER IND(66),IDO(66),ICH(66),IANG(66)
+ INTEGER INDM
+
+C
+C------------------------------------------------------------------------------
+ DATA ZSP/2*0.,.02,.01,.005,.0025,5*.009,5*.0045,.009,.0045,
+ 1 .02,.01,.005,.0025,5*.009,5*.0045,.009,.0045,
+ 2 .00045,.002,.003,.004,.005,.006,.007,.008,.009,
+ 3 .01,.011,.012,.013,.014,.015,.016,
+ 4 .001,.002,.003,.004,.005,.006,.007,.008,
+ 5 .001,.002,.003,.004,.005,.006,.007,.008/
+C 5 6*.006/
+ DATA IDO/2*0,4*1,11*0,17*1,16*0,16*1/
+C DATA IDO/2*0,4*1,11*0,17*1,16*0,14*1/
+ DATA ICH/66*0/
+C DATA ICH/58*0,-1,-2,-3,-4,-5,-1/
+ DATA IANG/6*0,45,0,90,-45,-90,135,0,90,-45,-90,135,45,16*0,
+ 10,135,2*0,45,0,90,-45,-90,45,0,90,-45,-90,135,45,8*135,8*135/
+C 14*0,45,0,90,-45,-90,45,0,90,-45,-90,135,45,8*135,5*0,135/
+ N=66
+ DO I=1,N
+ IND(I)=I-1
+ ENDDO
+C print *,'NWRK ',NWRK,' XWRK YWRK '
+C
+C* 1. UNDERGROUND AREAS HATCHING
+C --------------------------
+C
+C* 1.1 Locates CONPACK contour edge lines (group number=3)
+C
+ IA=-5
+ DO I=1,NGRPS
+C print *,' IGRP IAREA',IGRP(I),IAREA(I),' I',I
+ IF(IGRP(I).EQ.3)THEN
+ IF(IAREA(I) .GT.0)THEN
+ IA=IHACH(IAREA(I))
+C print *,' IGRP IAREA',IGRP(I),IAREA(I),' I',I
+C print *,' IA ',IA
+ ENDIF
+ ENDIF
+ ENDDO
+C
+C* 1.2 Hatches
+C
+ IF(IA.GT.0)THEN
+
+C print *,'NWRK ',NWRK,' XWRK YWRK '
+ DO J=1,N
+ IF(IA.EQ.IND(J))THEN
+ INDM=J
+C print *,' SFILLH INDM ',INDM
+ ENDIF
+ ENDDO
+ IF(INDM .EQ. 1)THEN
+C CALL GSFACI(0)
+C CALL GFA(NWRK,XWRK,YWRK)
+ ELSE IF(INDM .EQ. 2)THEN
+ CALL GSFACI(1)
+ CALL GFA(NWRK,XWRK,YWRK)
+ ELSE
+ CALL SFSETR('SP',ZSP(INDM))
+ CALL SFSETI('AN',IABS(IANG(INDM)))
+ CALL SFSETI('DO',IDO(INDM))
+ CALL SFSETI('CH',ICH(INDM))
+ IF(INDM .GE. 59)CALL GSMKSC(2.)
+ CALL SFWRLD(XWRK,YWRK,NWRK,RSCR,50000,ISCR,50000)
+ IF(IANG(INDM) .LT. 0)THEN
+ CALL SFSETI('AN',IABS(IANG(INDM))+90)
+ CALL SFNORM(XWRK,YWRK,NWRK,RSCR,50000,ISCR,50000)
+ ENDIF
+ ENDIF
+
+ ENDIF
+ CALL GSMKSC(1.)
+C
+C-----------------------------------------------------------------------------
+C
+C* 2. EXIT
+C ----
+C
+ RETURN
+ END
+C
+C
+C $Id$
+C
+C
+C-----------------------------------------------------------------------
+C
+ SUBROUTINE LBFILL (IFTP,XCRA,YCRA,NCRA,INDX)
+ DIMENSION XCRA(*),YCRA(*)
+ INTEGER ISCR(1000)
+ REAL RSCR(1000)
+ REAL ZSP(66)
+ INTEGER IDO(66),ICH(66),IANG(66)
+C
+ DATA ZSP/2*0.,.02,.01,.005,.0025,5*.009,5*.0045,.009,.0045,
+ 1 .02,.01,.005,.0025,5*.009,5*.0045,.009,.0045,
+ 2 .00045,.002,.003,.004,.005,.006,.007,.008,.009,
+ 3 .01,.011,.012,.013,.014,.015,.016,
+ 4 .001,.002,.003,.004,.005,.006,.007,.008,
+ 5 .001,.002,.003,.004,.005,.006,.007,.008/
+C 5 6*.006/
+ DATA IDO/2*0,4*1,11*0,17*1,16*0,16*1/
+C DATA IDO/2*0,4*1,11*0,17*1,16*0,14*1/
+ DATA ICH/66*0/
+C DATA ICH/58*0,-1,-2,-3,-4,-5,-1/
+ DATA IANG/6*0,45,0,90,-45,-90,135,0,90,-45,-90,135,45,16*0,
+ 10,135,2*0,45,0,90,-45,-90,45,0,90,-45,-90,135,45,8*135,8*135/
+C 14*0,45,0,90,-45,-90,45,0,90,-45,-90,135,45,8*135,5*0,135/
+
+C Couleurs
+ IF(IFTP.EQ.1)THEN
+ CALL GSFACI (INDX)
+ CALL GFA (NCRA-1,XCRA,YCRA)
+C Hachures et grises
+ ELSE
+ IF(INDX.EQ.0)THEN
+ ELSE IF(INDX.EQ.1)THEN
+C IF(INDX.EQ.0 .OR. INDX.EQ.1)THEN
+ CALL GSFACI (INDX)
+ CALL GFA (NCRA-1,XCRA,YCRA)
+ ELSE
+ INDM=INDX+1
+ CALL SFSETR('SP',ZSP(INDM))
+ CALL SFSETI('AN',IABS(IANG(INDM)))
+ CALL SFSETI('DO',IDO(INDM))
+ CALL SFSETI('CH',ICH(INDM))
+ IF(INDM .GE. 59)CALL GSMKSC(2.)
+ CALL SFNORM(XCRA,YCRA,NCRA,RSCR,1000,ISCR,1000)
+ IF(IANG(INDM) .LT. 0)THEN
+ CALL SFSETI('AN',IABS(IANG(INDM))+90)
+ CALL SFNORM(XCRA,YCRA,NCRA,RSCR,1000,ISCR,1000)
+ ENDIF
+ CALL GSMKSC(1.)
+ ENDIF
+ ENDIF
+ RETURN
+ END
+C
+C Janvier 2001 . Routine importee du Ncar ds package personnel pour
+C modif (-> essai de definir une echelle pour les fleches en supprimant
+C l'elimination des fleches > ABS(XVHC) ds le cas ou XVHC est <0
+C
+C $Id$
+C
+ SUBROUTINE VVECTR (U,V,P,IAM,VVUDMV,WRK)
+C Janvier 2001
+ USE MODD_RESOLVCAR
+C Janvier 2001
+
+C
+C Argument dimensions
+C
+ DIMENSION U(IUD1,*), V(IVD1,*), P(IPD1,*)
+C
+ DIMENSION WRK(*),IAM(*)
+C
+ EXTERNAL VVUDMV
+C
+C Input parameters
+C
+C U,V - 2-d arrays holding the component values of a vector field
+C P - A 2-d array containing a scalar data field. The contents
+C of this array may be used to color the vectors
+C IAM - Area mask array
+C VVUDMV - User modifiable masked vector drawing function
+C WRK - work array (currently unused)
+C
+C Output parameters:
+C
+C None
+C
+C PURPOSE VVECTR draws a representation of a two-
+C dimensional velocity field by drawing arrows
+C from each data location. The length of the
+C arrow is proportional to the strength of the
+C field at that location and the direction of
+C the arrow indicates the direction of the flow
+C at that location.
+C
+C ---------------------------------------------------------------------
+C
+C NOTE:
+C Since implicit typing is used for all real and integer variables
+C a consistent length convention has been adopted to help clarify the
+C significance of the variables encountered in the code for this
+C utility. All local variable and subroutine parameter identifiers
+C are limited to 1,2,or 3 characters. Four character names identify
+C members of common blocks. Five and 6 character variable names
+C denote PARAMETER constants or subroutine or function names.
+C
+C Declare the VV common blocks.
+C
+C IPLVLS - Maximum number of color threshold level values
+C IPAGMX - Maximum number of area groups allowed in the area map
+C
+ PARAMETER (IPLVLS = 256, IPAGMX = 64)
+C
+C
+C Integer and real common block variables
+C
+C
+ COMMON /VVCOM/
+ + IUD1 ,IVD1 ,IPD1 ,IXDM ,
+ + IYDN ,VLOM ,VHIM ,ISET ,
+ + VRMG ,VRLN ,VFRC ,IXIN ,
+ + IYIN ,ISVF ,UUSV ,UVSV ,
+ + UPSV ,IMSK ,ICPM ,UVPS ,
+ + UVPL ,UVPR ,UVPB ,UVPT ,
+ + UWDL ,UWDR ,UWDB ,UWDT ,
+ + UXC1 ,UXCM ,UYC1 ,UYCN ,
+ + NLVL ,IPAI ,ICTV ,WDLV ,
+ + UVMN ,UVMX ,PMIN ,PMAX ,
+ + RVMN ,RVMX ,RDMN ,RDMX ,
+ + ISPC ,RVMD ,IPLR ,IVST ,
+ + IVPO ,ILBL ,IDPF ,IMSG ,
+ + ICLR(IPLVLS) ,TVLU(IPLVLS)
+C
+C Arrow size/shape parameters
+C
+ COMMON / VVARO /
+ + HDSZ ,HINF ,HANG ,IAST ,
+ + HSIN ,HCOS ,FAMN ,FAMX ,
+ + UVMG ,FAIR ,FAWR ,FAWF ,
+ + FAXR ,FAXF ,FAYR ,FAYF ,
+ + AROX(8) ,AROY(8) ,FXSZ ,FYSZ ,
+ + FXRF ,FXMN ,FYRF ,FYMN ,
+ + FWRF ,FWMN ,FIRF ,FIMN ,
+ + AXMN ,AXMX ,AYMN ,AYMX ,
+ + IACM ,IAFO ,WBAD ,WBTF ,
+ + WBCF ,WBDF ,WBSC
+C
+C
+C Text related parameters
+C
+ COMMON /VVTXP /
+ + FCWM ,ICSZ ,
+ + FMNS ,FMNX ,FMNY ,IMNP ,IMNC ,
+ + FMXS ,FMXX ,FMXY ,IMXP ,IMXC ,
+ + FZFS ,FZFX ,FZFY ,IZFP ,IZFC ,
+ + FILS ,FILX ,FILY ,IILP ,IILC ,
+ + FLBS ,ILBC
+
+C
+C Character variable declartions
+C
+ CHARACTER*160 CSTR
+ PARAMETER (IPCHSZ=36)
+ CHARACTER*(IPCHSZ) CMNT,CMXT,CZFT,CLBT,CILT
+C
+C Text string parameters
+C
+ COMMON /VVCHAR/ CSTR,CMNT,CMXT,CZFT,CLBT,CILT
+C
+ SAVE /VVCOM/, /VVARO/, /VVTXP/, /VVCHAR/
+C
+C The mapping common block: made available to user mapping routines
+C
+ COMMON /VVMAP/
+ + IMAP ,
+ + XVPL ,XVPR ,YVPB ,YVPT ,
+ + WXMN ,WXMX ,WYMN ,WYMX ,
+ + XLOV ,XHIV ,YLOV ,YHIV ,
+ + SXDC ,SYDC ,NXCT ,NYCT ,
+ + RLEN ,LNLG ,INVX ,INVY ,
+ + ITRT ,IWCT ,FW2W ,FH2H ,
+ + DVMN ,DVMX ,RBIG ,IBIG
+C
+ SAVE /VVMAP/
+C
+C Math constants
+C
+ PARAMETER (PDTOR = 0.017453292519943,
+ + PRTOD = 57.2957795130823,
+ + P1XPI = 3.14159265358979,
+ + P2XPI = 6.28318530717959,
+ + P1D2PI = 1.57079632679489,
+ + P5D2PI = 7.85398163397448)
+C
+C --------------------------------------------------------------------
+C
+C Local variable dimensions
+C
+ PARAMETER (IPLBSZ=10)
+ CHARACTER*(IPLBSZ)LBL
+ REAL IAR(4)
+C
+C Local variables
+C
+C
+C The following status and count variables are used to gather
+C statistics that are not currently available to the user
+C
+C IST - Status flag returned from the mapping routine
+C ISC - Count of vectors rejected by the mapping routine
+C ICT - Count of vector actually plotted
+C MXO - Count of vectors rejected because magnitude > maximum
+C MNO - Count of vectors rejected because magnitude < minimum
+C
+C Variables relating to the vector magnitude label
+C
+C LBL - Character string to hold the vector magnitude label
+C NC - Number of characters in the vector magnitude label
+C IDP - Local decimal flag for the ENCD routine
+C ASH - Scale factor for the vector magnitude label
+C
+C Zero-field processing and label
+C
+C IZF - Zero field flag, set TRUE if no vectors are plotted
+C XF,YF - fractional length of Zero field string
+C IB,IE - beginning and end characters of the string
+C W,H - width and height of the string in fractional coordinates
+C XW,YW - position of the string in window coordinates
+C
+C Vector length adjustment
+C
+C RAT - Temporary ratio variable
+C VA - adjusted length of current vector
+C RA - ratio of adjusted length to current length
+C SMN,SMX - saved value of DVMN and DVMX so they can be restored
+C
+C Other variables
+C
+C IOC - the old (saved) color
+C IOW - the old (saved) linewidth
+C IDA - Do area masking flag
+C VMN - The minimum vector size actually plotted (in frac coords)
+C VMX - The maximum vector size actually plotted (in frac coords)
+C I,J - loop indices for traversing the vector arrays
+C K - loop index for traversing the threshold values
+C UI,VI - local copies of the current vector values
+C XB,XE,YB,XE - the beginning/ending points of the vector in
+C the fractional system
+C X,Y - mapping of the array indices to a coordinate system
+C VLN - length of the current vector in fractional coordinates
+C XGV,YGV - X and Y grid value, the scaled distance between each
+C array grid point
+C VPL,VPR,VPB,VPT,WDL,WDR,WDB,WDT,ILG - Saved SET call values
+C IER,ICL,IAR - Clip query values
+C
+C ---------------------------------------------------------------------
+C
+C Check for valid area map and area group overflow if masking is enabled
+C
+ IF (IMSK.GT.0) THEN
+ IF (IAM(7).GT.IPAGMX) THEN
+ CSTR(1:29)='VVECTR - TOO MANY AREA GROUPS'
+ CALL SETER (CSTR(1:29),1,1)
+ RETURN
+ END IF
+ IF (IAM(7).LE.0) THEN
+ CSTR(1:25)='VVECTR - INVALID AREA MAP'
+ CALL SETER (CSTR(1:29),2,1)
+ RETURN
+ END IF
+ END IF
+C
+C Initialize local variables
+C
+ NC = 0
+ ICT = 0
+ IVC = 0
+ ISC = 0
+ IZC = 0
+ ITH = 0
+ MXO = 0
+ MNO = 0
+ IDA = IMSK
+ VMN = RBIG
+ VMX = 0.0
+ IZF = 1
+ SMN=DVMN
+ SMX=DVMX
+C
+C Save the current color and linewidth, then set the vector
+C linewidth. Color must be set on a per vector basis within the
+C main loop. Label text color is set here if a single color is
+C specified for all labels.
+C
+ CALL GQPLCI(IER,IOC)
+ CALL GQTXCI(IER,IOT)
+ CALL GQFAIS(IER,IOF)
+ CALL GQFACI(IER,IOK)
+ CALL GQLWSC(IER,ROW)
+ CALL GSLWSC(WDLV)
+ IF (ILBC .GE. 0) THEN
+ CALL GSTXCI(ILBC)
+ END IF
+ IF (IAST.NE.0) THEN
+ CALL GSFAIS(1)
+ END IF
+C
+C If there are no drawable vectors skip the main loop
+C
+ IF (UVMX .LE. 0.0) THEN
+ IZC=NXCT*NYCT
+ DVMX=0.0
+ DVMN=0.0
+ VMN=0.0
+ VMX=0.0
+ VFR=0.0
+ DRL=0.0
+ IAV=0
+ GOTO 9800
+ END IF
+C
+C Initialize variables (both local and common block values) that
+C control the mapping between vector magnitude and the realized
+C vector length.
+C
+ CALL VVILNS(DRL,VFR,IAV)
+C
+ IF (DVMX .GT. 2.0*(XVPR - XVPL)) THEN
+ CSTR(1:36)='VVECTR - VECTOR NDC LENGTH TOO GREAT'
+ CALL SETER (CSTR(1:36),3,1)
+ RETURN
+ END IF
+C
+C If using filled arrows initialize the fill arrow data
+C For wind barbs initialize data, set up for calling NGDOTS, and
+C set the fill color the same as the line color
+C
+ IF (IAST.EQ.1) THEN
+ CALL VVINFA
+ ELSE IF (IAST.GE.2) THEN
+ CALL NGGETI('CT',ICI)
+ CALL NGSETI('CT',1)
+ CALL GSFACI(IOC)
+ CALL VVINWB
+ END IF
+C
+C Set the scaling for the optional vector labels
+C
+ IDP = IDPF
+ IF (UVMN.NE.0.0 .AND. (ABS(UVMN).LT.0.1 .OR. ABS(UVMN).GE.1.E5))
+ + IDP = 1
+ IF (UVMX.NE.0.0 .AND. (ABS(UVMX).LT.0.1 .OR. ABS(UVMX).GE.1.E5))
+ + IDP = 1
+ ASH = 1.0
+ IF (IDP .NE. 0) ASH =
+ + 10.**(3-IFIX(ALOG10(AMAX1(ABS(UVMN),ABS(UVMX)))-500.)-500)
+C
+C If thinning is in effect, set up the thinning arrays
+C
+ IV=IXDM*IYDN+1
+ IF (RVMD.GT.0.0) THEN
+ CALL VVTHIN(U,V,P,WRK(1),WRK(IV))
+ END IF
+C
+C Calculate the grid interval represented by adjacent array
+C elements along each axis
+C
+ XGV=(XHIV-XLOV)/REAL(MAX(1,IXDM-1))
+ YGV=(YHIV-YLOV)/REAL(MAX(1,IYDN-1))
+C
+C Draw the vectors. Note the extra processing if there are special
+C values to consider or the independent scalar array is processed.
+C
+ DO 201 J=1,IYDN,IYIN
+ DO 200 I=1,IXDM,IXIN
+C
+ UI = U(I,J)
+ VI = V(I,J)
+C
+C If thinning remove thinned out vectors
+C
+ IF (RVMD.GT.0.0) THEN
+ CALL VVTHND(I,J,WRK(1),IS)
+ IF (IS.EQ.1) GO TO 194
+ END IF
+C
+C Cull out special values
+C
+ IF (ISVF .GT. 0) THEN
+ IF (UI .EQ. UUSV) THEN
+ IF (ISVF .EQ. 1 .OR. ISVF .EQ. 3) GO TO 199
+ IF (VI .EQ. UVSV .AND. ISVF .EQ. 4) GO TO 199
+ ELSE IF (VI .EQ. UVSV) THEN
+ IF (ISVF .EQ. 2 .OR. ISVF .EQ. 3) GO TO 199
+ END IF
+ END IF
+C
+C Calculate the vector magnitude or if the polar flag is set
+C compute the cartesian component values
+C
+ IF (IPLR .LE. 0) THEN
+ UVMG = SQRT(UI*UI+VI*VI)
+ ELSE
+ UVMG = ABS(UI)
+ IF (IPLR .EQ. 1) VI = PDTOR * VI
+ UI = UVMG * COS(VI)
+ VI = UVMG * SIN(VI)
+ END IF
+C
+C Bypass vectors that fall outside the user-specified range.
+C
+ IF (UVMG .LT. UVMN) GO TO 196
+C
+CCCCCCCCCCCCCSuppression pour voir!!!!!!! -> ca marche
+ IF(LVSUPSCA)THEN
+C IF (UVMG .GT. UVMX) GO TO 197
+ ELSE
+ IF (UVMG .GT. UVMX) GO TO 197
+ ENDIF
+CCCCCCCCCCCCCSuppression pour voir!!!!!!!
+C
+C Eliminate zero vectors unless using wind barbs
+C
+ IF (UVMG .EQ. 0.0 .AND. IAST .LT. 2) GO TO 198
+C
+C If using a scalar array, check for special values in the array,
+C then determine the color to use for the vector
+C
+ IF (ABS(ICTV) .GE. 2) THEN
+C
+ IF (ISPC .EQ. 0 .AND. P(I,J) .EQ. UPSV) THEN
+ GO TO 199
+ ELSE IF (ISPC .GT. 0 .AND. P(I,J) .EQ. UPSV) THEN
+ IF (IAST .EQ. 0) THEN
+ CALL GSPLCI(ISPC)
+ ELSE IF (IAST .EQ. 1) THEN
+ IF (IACM .EQ. -1 .OR. IACM .GE. 1) THEN
+ CALL GSPLCI(ISPC)
+ END IF
+ IF (IACM .EQ. 0 .OR. ABS(IACM) .GE. 2) THEN
+ CALL GSFACI(ISPC)
+ END IF
+ ELSE
+ CALL GSPLCI(ISPC)
+ CALL GSFACI(ISPC)
+ END IF
+ GO TO 129
+ END IF
+C
+ DO 128 K=1,NLVL,1
+ IF (P(I,J).LE.TVLU(K) .OR. K.EQ.NLVL) THEN
+ IF (IAST .EQ. 0) THEN
+ CALL GSPLCI(ICLR(K))
+ ELSE IF (IAST .EQ. 1) THEN
+ IF (IACM .EQ. -1 .OR. IACM .GE. 1) THEN
+ CALL GSPLCI(ICLR(K))
+ END IF
+ IF (IACM .EQ. 0 .OR. ABS(IACM) .GE. 2) THEN
+ CALL GSFACI(ICLR(K))
+ END IF
+ ELSE
+ CALL GSPLCI(ICLR(K))
+ CALL GSFACI(ICLR(K))
+ END IF
+ IF (ILBC .EQ. -1) THEN
+ CALL GSTXCI(ICLR(K))
+ END IF
+ GO TO 129
+ END IF
+ 128 CONTINUE
+C
+ 129 CONTINUE
+C
+ ELSE IF (ICTV .NE. 0) THEN
+C
+C If coloring based on vector magnitude, figure out the color
+C
+ DO 130 K=1,NLVL,1
+ IF (UVMG.LE.TVLU(K) .OR. K.EQ.NLVL) THEN
+ IF (IAST .EQ. 0) THEN
+ CALL GSPLCI(ICLR(K))
+ ELSE IF (IAST .EQ. 1) THEN
+ IF (IACM .EQ. -1 .OR. IACM .GE. 1) THEN
+ CALL GSPLCI(ICLR(K))
+ END IF
+ IF (IACM .EQ. 0 .OR. ABS(IACM) .GE. 2) THEN
+ CALL GSFACI(ICLR(K))
+ END IF
+ ELSE
+ CALL GSPLCI(ICLR(K))
+ CALL GSFACI(ICLR(K))
+ END IF
+ IF (ILBC .EQ. -1) THEN
+ CALL GSTXCI(ICLR(K))
+ END IF
+ GO TO 131
+ END IF
+ 130 CONTINUE
+C
+ 131 CONTINUE
+C
+ END IF
+C
+C Map the vector. If the compatiblity flag is set use the
+C compatibility subroutine.
+C
+ IF (ICPM .GT. 0) THEN
+C
+ CALL VVFCPM(I,J,UI,VI,UVMG,XB,YB,XE,YE,IST)
+ IF (IST .NE. 0 .AND. IST .NE. -999) GO TO 195
+C
+ ELSE
+C
+ X=XLOV+REAL(I-1)*XGV
+ Y=YLOV+REAL(J-1)*YGV
+ CALL HLUVVMPXY(X,Y,UI,VI,UVMG,XB,YB,XE,YE,IST)
+ IF (IST .NE. 0 .AND. IST .NE. -999) GO TO 195
+C
+ END IF
+C
+ IF (IAST .GE. 2 .AND. IST .EQ. -999) THEN
+ VLN = DVMX
+ ELSE
+ VLN = SQRT((XE-XB)*(XE-XB)+(YE-YB)*(YE-YB))
+ IF (VLN .EQ. 0.0) GO TO 198
+C
+C Adjust the vector length in proportion to the difference between
+C the minimum and maximum display vector magnitudes
+C
+ IF (IAV.NE.0) THEN
+ VA = VFR+(DVMX - VFR)*(UVMG - UVMN) /(UVMX - UVMN)
+ RA = VA / VLN
+ XE = XB + RA *(XE-XB)
+ YE = YB + RA *(YE-YB)
+ VLN = VA
+ END IF
+ END IF
+C
+C Track the minimum/maximum displayed values
+C
+ IF (UVMG .LT. VMN) VMN=UVMG
+ IF (UVMG .GT. VMX) VMX=UVMG
+C
+C Turn zero field flag off; encode the number if a label is to
+C be drawn
+C
+ IZF = 0
+ IF (ILBL .NE. 0) CALL ENCD(UVMG,ASH,LBL,NC,IDP)
+C
+C Draw the vector
+C
+ IF (IAST .EQ. 0) THEN
+ CALL VVDRAW (XB,YB,XE,YE,VLN,LBL,NC,IAM,VVUDMV,IDA)
+ ELSE IF (IAST .EQ. 1) THEN
+ CALL VVDRFL (XB,YB,XE,YE,VLN,LBL,NC,IAM,VVUDMV,IDA)
+ ELSE
+ CALL VVDRWB (XB,YB,XE,YE,VLN,LBL,NC,IAM,VVUDMV,IDA)
+ END IF
+C
+C Statistical data:
+C
+C Vectors plotted
+C
+ ICT=ICT + 1
+ GOTO 200
+C
+ 194 CONTINUE
+C
+C Vectors culled out by thinning algorithm
+C
+ ITH=ITH+1
+ GO TO 200
+C
+ 195 CONTINUE
+C
+C Vectors rejected by mapping routine
+C
+ ISC=ISC+1
+ GO TO 200
+C
+ 196 CONTINUE
+C
+C Vectors under minimum magnitude
+C
+ MNO=MNO+1
+ GO TO 200
+C
+ 197 CONTINUE
+C
+C Vectors over maximum magnitude
+C
+ MXO=MXO + 1
+ GO TO 200
+C
+C Zero length vectors cannot be drawn even if UVMN is 0.0, but
+C need to be treated as if they were drawn.
+C
+ 198 CONTINUE
+C
+ IF (UVMG .LT. VMN) VMN=UVMG
+ IZC=IZC + 1
+ GO TO 200
+C
+C Special values
+C
+ 199 CONTINUE
+ IVC = IVC+1
+C
+ 200 CONTINUE
+ 201 CONTINUE
+C
+C End of main loop.
+C
+ 9800 CONTINUE
+C
+C Plot statistics
+C
+ IF (IVST .EQ. 1) THEN
+ LUN=I1MACH(2)
+ WRITE(LUN,*) 'VVECTR Statistics'
+ WRITE(LUN,*) ' Vectors plotted:',ICT
+ WRITE(LUN,*) 'Vectors rejected by mapping routine:',ISC
+ WRITE(LUN,*) ' Vectors under minimum magnitude:',MNO
+ WRITE(LUN,*) ' Vectors over maximum magnitude:',MXO
+ WRITE(LUN,*) ' Other zero length vectors:',IZC
+ WRITE(LUN,*) ' Rejected special values:',IVC
+ IF (RVMD.GT.0) THEN
+ WRITE(LUN,*) ' Vectors below minimum distance:',ITH
+ END IF
+ WRITE(LUN,*) ' Minimum plotted vector magnitude:',VMN
+ WRITE(LUN,*) ' Maximum plotted vector magnitude:',VMX
+ IF (ABS(ICTV).GE.2) THEN
+ WRITE(LUN,*) ' Minimum scalar value:',PMIN
+ WRITE(LUN,*) ' Maximum scalar value:',PMAX
+ END IF
+ WRITE(LUN,*) ' '
+ END IF
+C
+C Reset attributes
+C
+ CALL GSPLCI(IOC)
+ CALL GSLWSC(ROW)
+ CALL GSTXCI(IOT)
+ CALL GSFACI(IOK)
+ CALL GSFAIS(IOF)
+C
+C Set the read-only min/max vector sizes to reflect the vectors
+C actually drawn
+C
+ IF (IAV.EQ.0) THEN
+ RDMN=VMN*SXDC
+ ELSE
+ RDMN = VFR+(DVMX - VFR)*(VMN - UVMN) /(UVMX - UVMN)
+ END IF
+ RDMX=VMX*SXDC
+ RVMX=VMX
+ RVMN=VMN
+C
+C If vectors were drawn, write out the vector informational text if
+C called for, else conditionally write the zero field text.
+C The size printed out depends on whether absolute or relative
+C size mode is in effect.
+C
+ IF (IZF .EQ. 0) THEN
+C
+ IF (CMXT(1:1) .NE. ' ') THEN
+ IF (VRMG .GT. 0.0) THEN
+ CALL VVARTX(CMXT,IMXP,FMXX,FMXY,FMXS,IMXC,VRMG,DRL)
+ ELSE IF (VHIM .LT. 0.0) THEN
+ CALL VVARTX(CMXT,IMXP,FMXX,FMXY,FMXS,IMXC,UVMX,DVMX)
+ ELSE
+ CALL VVARTX(CMXT,IMXP,FMXX,FMXY,FMXS,IMXC,VMX,RDMX)
+ ENDIF
+ END IF
+ IF (CMNT(1:1) .NE. ' ') THEN
+ IF (VLOM .LT. 0.0) THEN
+ CALL VVARTX(CMNT,IMNP,FMNX,FMNY,FMNS,IMNC,UVMN,DVMN)
+ ELSE
+ CALL VVARTX(CMNT,IMNP,FMNX,FMNY,FMNS,IMNC,VMN,RDMN)
+ END IF
+ END IF
+C
+ ELSE
+C
+ IF (CZFT(1:1) .NE. ' ') THEN
+C
+C Turn clipping off and SET to an identity transform
+C
+ CALL GQCLIP(IER,ICL,IAR)
+ CALL GSCLIP(0)
+ CALL GETSET(VPL,VPR,VPB,VPT,WDL,WDR,WDB,WDT,ILG)
+ CALL SET(0.0,1.0,0.0,1.0,0.0,1.0,0.0,1.0,1)
+C
+ XF = XVPL + FZFX * FW2W
+ YF = YVPB + FZFY * FH2H
+ CALL VVTXLN(CZFT,IPCHSZ,IB,IE)
+ CALL VVTXIQ(CZFT(IB:IE),FZFS*FW2W,W,H)
+ CALL VVTXPO(IZFP,XF,YF,W,H,XW,YW)
+ IF (IZFC .GE. 0) THEN
+ CALL GSTXCI(IZFC)
+ CALL GSPLCI(IZFC)
+ ELSE
+ CALL GSPLCI(IOT)
+ END IF
+C
+ CALL PLCHHQ(XW,YW,CZFT(IB:IE),FZFS*FW2W,0.0,0.0)
+C
+ CALL GSTXCI(IOT)
+ CALL GSPLCI(IOC)
+C
+C Restore clipping and the set transformation.
+C
+ CALL NGSETI('CT',ICI)
+ CALL GSCLIP(ICL)
+ CALL SET(VPL,VPR,VPB,VPT,WDL,WDR,WDB,WDT,ILG)
+C
+ END IF
+C
+ END IF
+C
+C Restore DVMN and DVMX
+C
+ DVMN=SMN
+ DVMX=SMX
+C
+C Done
+C
+ RETURN
+ END
+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+C
+C $Id$
+C
+ SUBROUTINE EZXY (XDRA,YDRA,NPTS,LABG)
+C
+ USE MODD_RESOLVCAR
+ USE MODD_TYPE_AND_LH
+ USE MODN_NCAR
+
+ REAL XDRA(*),YDRA(*)
+C
+ CHARACTER*(*) LABG
+C
+C
+C The routine EZXY draws one curve through the points (XDRA(I),YDRA(I)),
+C for I = 1, 2, ... NPTS.
+C
+ CALL AGGETI ('SET .',ISET)
+ CALL AGGETI ('FRAM.',IFRA)
+ if(nverbia > 0)then
+ print *,' EZXY ISET IFRA CTYPE LCOLINE ',ISET,IFRA,CTYPE,LCOLINE
+ endif
+C
+ CALL AGEZSU (2,XDRA,YDRA,NPTS,1,NPTS,LABG,IIVX,IIEX,IIVY,IIEY)
+ CALL AGBACK
+C
+ IF(CTYPE == 'SPXY' .AND. LCOLINE)THEN
+ CALL GSLWSC(2.)
+ IF(LPHALO .OR. LPHAO)THEN
+ CALL GSPLCI(4)
+ ELSEIF(NLOOPN == 1)THEN
+ CALL GSPLCI(3)
+ ELSEIF(NLOOPN == 2)THEN
+ CALL GSPLCI(2)
+ ELSE
+ CALL GSPLCI(1)
+ ENDIF
+ ENDIF
+ IF (ISET.GE.0) CALL AGCURV (XDRA,1,YDRA,1,NPTS,1)
+ IF(CTYPE == 'SPXY' .AND. LCOLINE)THEN
+ CALL SFLUSH
+ print *,' LSPO,LOSPLO,LSPLO,LPHALO,LPHAO ',LSPO,LOSPLO,LSPLO,LPHALO,LPHAO
+ CALL GSLWSC(1.)
+ CALL GSPLCI(1)
+ ENDIF
+C
+ IF (IFRA.EQ.1) CALL FRAME
+C
+ RETURN
+C
+ END
diff --git a/LIBTOOLS/tools/diachro/src/POS/gkscom-5.1.1.h b/LIBTOOLS/tools/diachro/src/POS/gkscom-5.1.1.h
new file mode 100644
index 0000000000000000000000000000000000000000..0c10282a44c2ec24c7045744c9594a6713554907
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/gkscom-5.1.1.h
@@ -0,0 +1,70 @@
+C
+C $Id$
+C
+C Copyright (C) 2000
+C University Corporation for Atmospheric Research
+C All Rights Reserved
+C
+C The use of this Software is governed by a License Agreement.
+C
+C Details on all GKS COMMON variables are in the GKS BLOCKDATA.
+ PARAMETER(MXNWK=15,NSEG=100,IWDIM=10000,NUMERS=139)
+ COMMON/GKINTR/ NOPWK , NACWK , WCONID, NUMSEG,
+ + SEGS(NSEG) , CURSEG, SEGLEN(NSEG) , MXSREC,
+ + SEGT(NSEG,2,3), CURTM(2,3) , SEGDEL,
+ + RWKSP(IWDIM) , GKSCLP
+ INTEGER NOPWK , NACWK , WCONID, NUMSEG, SEGS , CURSEG,
+ + SEGLEN, MXSREC, SEGDEL, GKSCLP
+ COMMON/GKOPDT/ OPS , KSLEV , WK , LSWK(22) ,
+ + MOPWK , MACWK , MNT
+ INTEGER OPS , WK
+ COMMON/GKSTAT/ SOPWK(MXNWK) , SACWK(MXNWK) , CPLI , CLN ,
+ + CLWSC , CPLCI , CLNA , CLWSCA, CPLCIA, CPMI ,
+ + CMK , CMKS , CPMCI , CMKA , CMKSA , CPMCIA,
+ + CTXI , CTXFP(2) , CCHXP , CCHSP , CTXCI ,
+ + CTXFPA, CCHXPA, CCHSPA, CTXCIA, CCHH , CCHUP(2),
+ + CTXP , CTXAL(2) , CFAI , CFAIS , CFASI ,
+ + CFACI , CFAISA, CFASIA, CFACIA, CPA(2), CPARF(2),
+ + CNT , LSNT(2) , NTWN(2,4) , NTVP(2,4),
+ + CCLIP , SWKTP(MXNWK) , NOPICT, NWKTP ,
+ + LXWKID(MXNWK) , ECONID, CLLX , CLLY , CURX ,
+ + CURY , CPSCL , CCMDL, COLMOD, CSUPR , CPTLD
+ INTEGER SOPWK , SACWK , CPLI , CLN , CPLCI , CLNA ,
+ + CLWSCA, CPLCIA, CPMI , CMK , CPMCI , CMKA ,
+ + CMKSA , CPMCIA, CTXI , CTXFP , CTXCI , CTXFPA,
+ + CCHXPA, CCHSPA, CTXCIA, CTXP , CTXAL , CFAI ,
+ + CFAIS , CFASI , CFACI , CFAISA, CFASIA, CFACIA,
+ + CNT , LSNT , CCLIP , SWKTP , NOPICT, NWKTP ,
+ + LXWKID, ECONID, CLLX , CLLY , CURX , CURY ,
+ + CPSCL , CCMDL, COLMOD, CSUPR , CPTLD
+ REAL NTWN , NTVP
+ COMMON /GKETBI/IERNMS(NUMERS)
+ INTEGER IERNMS
+ COMMON /GKETBC/ERMSGS(NUMERS)
+ CHARACTER*210 ERMSGS
+ COMMON/GKEROR/ ERS , ERF , CUFLAG, XERMSG(160) , MXERMG
+ INTEGER ERS , ERF , CUFLAG, XERMSG , MXERMG
+ COMMON/GKENUM/ GBUNDL , GINDIV, GGKCL , GGKOP , GWSOP , GWSAC ,
+ + GSGOP , GOUTPT, GINPUT, GOUTIN, GWISS , GMO ,
+ + GMI , GCGM , GWSS , GXWE , GXWC , GDMP ,
+ + GPSMIN , GPSMAX, GPDFP , GPDFL , GPIX , GCPS ,
+ + GCROMIN, GCROMAX
+ INTEGER GBUNDL , GINDIV, GGKCL , GGKOP , GWSOP , GWSAC ,
+ + GSGOP , GOUTPT, GINPUT, GOUTIN, GWISS , GMO ,
+ + GMI , GCGM , GWSS , GXWE , GXWC , GDMP ,
+ + GPSMIN , GPSMAX, GPDFP , GPDFL , GPIX , GCPS ,
+ + GCROMIN, GCROMAX
+ COMMON/GKSNAM/ GNAM(109) , SEGNAM(NSEG) , GFNAME, GSEGRT
+ CHARACTER GNAM*6, SEGNAM*137 , GFNAME*256 ,
+ + GSEGRT*80
+ COMMON/GKSIN1/ FCODE , CONT ,
+ + IL1 , IL2 , ID(128) ,
+ + IC1 , IC2 , IC(128) ,
+ + RL1 , RL2 , RX(128) , RY(128) ,
+ + STRL1 , STRL2 , RERR
+ COMMON/GKSIN2/ STR
+ INTEGER FCODE , CONT , IL1 , IL2 , ID , IC1 ,
+ + IC2 , IC , RL1 , RL2 , STRL1 , STRL2 ,
+ + RERR
+ REAL RX , RY
+ CHARACTER*160 STR
diff --git a/LIBTOOLS/tools/diachro/src/POS/gkscom.h b/LIBTOOLS/tools/diachro/src/POS/gkscom.h
new file mode 100644
index 0000000000000000000000000000000000000000..3f175fb057e7158cb3389600d873bc19c23af9df
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/gkscom.h
@@ -0,0 +1,59 @@
+C Details on all GKS COMMON variables are in the GKS BLOCKDATA.
+ PARAMETER(MXNWK=15,NSEG=100,IWDIM=10000,NUMERS=130)
+ COMMON/GKINTR/ NOPWK , NACWK , WCONID, NUMSEG,
+ + SEGS(NSEG) , CURSEG, SEGLEN(NSEG) , MXSREC,
+ + SEGT(NSEG,2,3), CURTM(2,3) , SEGDEL,
+ + RWKSP(IWDIM) , GKSCLP
+ INTEGER NOPWK , NACWK , WCONID, NUMSEG, SEGS , CURSEG,
+ + SEGLEN, MXSREC, SEGDEL, GKSCLP
+ COMMON/GKOPDT/ OPS , KSLEV , WK , LSWK(17) ,
+ + MOPWK , MACWK , MNT
+ INTEGER OPS , WK
+ COMMON/GKSTAT/ SOPWK(MXNWK) , SACWK(MXNWK) , CPLI , CLN ,
+ + CLWSC , CPLCI , CLNA , CLWSCA, CPLCIA, CPMI ,
+ + CMK , CMKS , CPMCI , CMKA , CMKSA , CPMCIA,
+ + CTXI , CTXFP(2) , CCHXP , CCHSP , CTXCI ,
+ + CTXFPA, CCHXPA, CCHSPA, CTXCIA, CCHH , CCHUP(2),
+ + CTXP , CTXAL(2) , CFAI , CFAIS , CFASI ,
+ + CFACI , CFAISA, CFASIA, CFACIA, CPA(2), CPARF(2),
+ + CNT , LSNT(2) , NTWN(2,4) , NTVP(2,4),
+ + CCLIP , SWKTP(MXNWK) , NOPICT, NWKTP ,
+ + LXWKID(MXNWK) , ECONID, CLLX , CLLY , CURX ,
+ + CURY , CPSCL , CCMDL, COLMOD
+ INTEGER SOPWK , SACWK , CPLI , CLN , CPLCI , CLNA ,
+ + CLWSCA, CPLCIA, CPMI , CMK , CPMCI , CMKA ,
+ + CMKSA , CPMCIA, CTXI , CTXFP , CTXCI , CTXFPA,
+ + CCHXPA, CCHSPA, CTXCIA, CTXP , CTXAL , CFAI ,
+ + CFAIS , CFASI , CFACI , CFAISA, CFASIA, CFACIA,
+ + CNT , LSNT , CCLIP , SWKTP , NOPICT, NWKTP ,
+ + LXWKID, ECONID, CLLX , CLLY , CURX , CURY ,
+ + CPSCL , CCMDL, COLMOD
+ REAL NTWN , NTVP
+ COMMON /GKETBI/IERNMS(NUMERS)
+ INTEGER IERNMS
+ COMMON /GKETBC/ERMSGS(NUMERS)
+ CHARACTER*90 ERMSGS
+ COMMON/GKEROR/ ERS , ERF , CUFLAG, XERMSG(160) , MXERMG
+ INTEGER ERS , ERF , CUFLAG, XERMSG , MXERMG
+ COMMON/GKENUM/ GBUNDL, GINDIV, GGKCL , GGKOP , GWSOP , GWSAC ,
+ + GSGOP , GOUTPT, GINPUT, GOUTIN, GWISS , GMO ,
+ + GMI , GCGM , GWSS , GXWE , GXWC , GDMP ,
+ + GPSMIN, GPSMAX
+ INTEGER GBUNDL, GINDIV, GGKCL , GGKOP , GWSOP , GWSAC ,
+ + GSGOP , GOUTPT, GINPUT, GOUTIN, GWISS , GMO ,
+ + GMI , GCGM , GWSS , GXWE , GXWC , GDMP ,
+ + GPSMIN, GPSMAX
+ COMMON/GKSNAM/ GNAM(109) , SEGNAM(NSEG) , GFNAME, GSEGRT
+ CHARACTER GNAM*6, SEGNAM*57 , GFNAME*256 ,
+ + GSEGRT*80
+ COMMON/GKSIN1/ FCODE , CONT ,
+ + IL1 , IL2 , ID(128) ,
+ + IC1 , IC2 , IC(128) ,
+ + RL1 , RL2 , RX(128) , RY(128) ,
+ + STRL1 , STRL2 , RERR
+ COMMON/GKSIN2/ STR
+ INTEGER FCODE , CONT , IL1 , IL2 , ID , IC1 ,
+ + IC2 , IC , RL1 , RL2 , STRL1 , STRL2 ,
+ + RERR
+ REAL RX , RY
+ CHARACTER*80 STR
diff --git a/LIBTOOLS/tools/diachro/src/POS/gridal.f b/LIBTOOLS/tools/diachro/src/POS/gridal.f
new file mode 100644
index 0000000000000000000000000000000000000000..9254d0f5cb0e0c2722fdcc627efcd05175905886
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/gridal.f
@@ -0,0 +1,800 @@
+C
+C $Id$
+C
+ SUBROUTINE GRIDAL (MJRX,MNRX,MJRY,MNRY,IXLB,IYLB,IGPH,XINT,YINT)
+C
+C Declare the common block containing real and integer parameters.
+C
+ COMMON /GAREIN/ ICAX,ICLB,ICMJ,ICMN,ILTY,IORX,NCFX,NCFY,RCWX,
+ + RCWY,RDCX,RDCY,RMJX,RMJY,RMNX,RMNY,RWAX,RWLB,
+ + RWMJ,RWMN
+ SAVE /GAREIN/
+C
+C Declare the common block containing character parameters.
+C
+ COMMON /GACHAR/ FNLX,FNLY
+ CHARACTER*10 FNLX,FNLY
+ SAVE /GACHAR/
+C
+C Declare the block data "routine" external. This should force it to
+C be loaded.
+C
+ EXTERNAL GABLDT
+C
+C Declare an array in which to receive the "clipping rectangle".
+C
+ DIMENSION CLPR(4)
+C
+C Declare local variables to use in encoding labels.
+C
+ CHARACTER*10 FNLB
+ CHARACTER*24 LABL
+C
+C Declare some local variables double-precision. (They are used to
+C create labels.)
+C
+ DOUBLE PRECISION DLBL,EPSI,OPEP,VEPS,VLBL
+C
+C Initialize the values of EPSI and OPEP so that they will be recomputed
+C by the code itself.
+C
+ SAVE EPSI,OPEP
+C
+ DATA EPSI,OPEP / 0.D0 , 1.D0 /
+C
+C Check for an uncleared prior error.
+C
+ IF (ICFELL('GRIDAL - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
+C
+C If it has not been done yet, compute the constants "epsilon" and
+C "1+epsilon"; the latter is to be used multiplicatively in rounding
+C to get rid of strings of nines in labels.
+C
+ IF (EPSI.EQ.0.D0) THEN
+C
+ NSDR=0
+C
+ 101 NSDR=NSDR+1
+ CALL GAGTRN (NSDR,TMP1,TMP2,TMP3)
+ IF (TMP2.NE.1..AND.TMP2.NE.TMP3.AND.NSDR.LT.100) GO TO 101
+C
+ EPSI=10.D0**(1-NSDR)
+ OPEP=1.D0+EPSI
+C
+ END IF
+C
+C Pick up the current definition of the window and the viewport and
+C the current x/y linear/log flag.
+C
+ CALL GETSET (VPLX,VPRX,VPBY,VPTY,WDLX,WDRX,WDBY,WDTY,LILO)
+ IF (ICFELL('GRIDAL',2).NE.0) RETURN
+C
+C Set minimum and maximum values of X and Y.
+C
+ XMIN=MIN(WDLX,WDRX)
+ XMAX=MAX(WDLX,WDRX)
+C
+ YMIN=MIN(WDBY,WDTY)
+ YMAX=MAX(WDBY,WDTY)
+C
+C Set the linear/log and mirror image flags for the two axes.
+C
+ ILGX=(LILO-1)/2
+C
+ IF (WDLX.LT.WDRX) THEN
+ IMIX=0
+ ELSE
+ IMIX=1
+ END IF
+C
+ ILGY=MOD(LILO-1,2)
+C
+ IF (WDBY.LT.WDTY) THEN
+ IMIY=0
+ ELSE
+ IMIY=1
+ END IF
+C
+C Compute the width and height of the plotter window, in plotter units.
+C
+ CALL GETSI (IP2X,IP2Y)
+ IF (ICFELL('GRIDAL',3).NE.0) RETURN
+ WPLO=2.**IP2X-1.
+ HPLO=2.**IP2Y-1.
+C
+C Compute the number of major and minor divisions of each axis, imposing
+C limits on the input values in order to keep the code from blowing up.
+C
+ IF (ILGX.EQ.0) THEN
+ NMJX=MAX(1,MIN(10000,MJRX))
+ NMNX=MAX(1,MIN(10000,MNRX))
+ ELSE
+ IPTX=MAX(1,MIN(100,MJRX))
+ FPTX=REAL(IPTX)
+ NMJX=INT(1.0001*ABS(ALOG10(WDRX/WDLX))/FPTX)
+ IF (MNRX.LE.10) THEN
+ NMNX=9
+ ELSE
+ NMNX=1
+ END IF
+ END IF
+C
+ IF (ILGY.EQ.0) THEN
+ NMJY=MAX(1,MIN(10000,MJRY))
+ NMNY=MAX(1,MIN(10000,MNRY))
+ ELSE
+ IPTY=MAX(1,MIN(100,MJRY))
+ FPTY=REAL(IPTY)
+ NMJY=INT(1.0001*ABS(ALOG10(WDTY/WDBY))/FPTY)
+ IF (MNRY.LE.10) THEN
+ NMNY=9
+ ELSE
+ NMNY=1
+ END IF
+ END IF
+C
+C Save the current state of the clipping indicator and then turn it off.
+C
+ CALL GQCLIP (IGER,ICLP,CLPR)
+ IF (IGER.NE.0) THEN
+ CALL SETER ('GRIDAL - ERROR EXIT FROM GQCLIP',4,1)
+ RETURN
+ END IF
+ CALL GSCLIP (0)
+C
+C The following loop runs through the types of items to be drawn. ITEM
+C = 1 implies minor ticks, 2 implies major ticks, 3 implies the axes,
+C and 4 implies the labels.
+C
+ DO 104 ITEM=1,4
+C
+C Set the color index and line width for the type of item being drawn.
+C
+ IF (ITEM.EQ.1) THEN
+ IF (ICMN.GE.0) THEN
+ CALL PLOTIF (0.,0.,2)
+ IF (ICFELL('GRIDAL',5).NE.0) RETURN
+ CALL GQPLCI (IGER,ICS1)
+ IF (IGER.NE.0) THEN
+ CALL SETER ('GRIDAL - ERROR EXIT FROM GQPLCI',6,1)
+ RETURN
+ END IF
+ CALL GSPLCI (ICMN)
+ END IF
+ IF (RWMN.GT.0.) THEN
+ CALL PLOTIF (0.,0.,2)
+ IF (ICFELL('GRIDAL',7).NE.0) RETURN
+ CALL GQLWSC (IGER,SLWS)
+ IF (IGER.NE.0) THEN
+ CALL SETER ('GRIDAL - ERROR EXIT FROM GQLWSC',8,1)
+ RETURN
+ END IF
+ CALL GSLWSC (RWMN)
+ END IF
+ ELSE IF (ITEM.EQ.2) THEN
+ IF (ICMJ.GE.0) THEN
+ CALL PLOTIF (0.,0.,2)
+ IF (ICFELL('GRIDAL',9).NE.0) RETURN
+ CALL GQPLCI (IGER,ICS1)
+ IF (IGER.NE.0) THEN
+ CALL SETER ('GRIDAL - ERROR EXIT FROM GQPLCI',10,1)
+ RETURN
+ END IF
+ CALL GSPLCI (ICMJ)
+ END IF
+ IF (RWMJ.GT.0.) THEN
+ CALL PLOTIF (0.,0.,2)
+ IF (ICFELL('GRIDAL',11).NE.0) RETURN
+ CALL GQLWSC (IGER,SLWS)
+ IF (IGER.NE.0) THEN
+ CALL SETER ('GRIDAL - ERROR EXIT FROM GQLWSC',12,1)
+ RETURN
+ END IF
+ CALL GSLWSC (RWMJ)
+ END IF
+ ELSE IF (ITEM.EQ.3) THEN
+ IF (ICAX.GE.0) THEN
+ CALL PLOTIF (0.,0.,2)
+ IF (ICFELL('GRIDAL',13).NE.0) RETURN
+ CALL GQPLCI (IGER,ICS1)
+ IF (IGER.NE.0) THEN
+ CALL SETER ('GRIDAL - ERROR EXIT FROM GQPLCI',14,1)
+ RETURN
+ END IF
+ CALL GSPLCI (ICAX)
+ END IF
+ IF (RWAX.GT.0.) THEN
+ CALL PLOTIF (0.,0.,2)
+ IF (ICFELL('GRIDAL',15).NE.0) RETURN
+ CALL GQLWSC (IGER,SLWS)
+ IF (IGER.NE.0) THEN
+ CALL SETER ('GRIDAL - ERROR EXIT FROM GQLWSC',16,1)
+ RETURN
+ END IF
+ CALL GSLWSC (RWAX)
+ END IF
+ ELSE IF (ITEM.EQ.4) THEN
+ IF (ICLB.GE.0) THEN
+ CALL GQPLCI (IGER,ICS1)
+ IF (IGER.NE.0) THEN
+ CALL SETER ('GRIDAL - ERROR EXIT FROM GQPLCI',17,1)
+ RETURN
+ END IF
+ CALL GSPLCI (ICLB)
+ CALL GQTXCI (IGER,ICS2)
+ IF (IGER.NE.0) THEN
+ CALL SETER ('GRIDAL - ERROR EXIT FROM GQTXCI',18,1)
+ RETURN
+ END IF
+ CALL GSTXCI (ICLB)
+ END IF
+ IF (RWLB.GT.0.) THEN
+ CALL PLOTIF (0.,0.,2)
+ IF (ICFELL('GRIDAL',19).NE.0) RETURN
+ CALL GQLWSC (IGER,SLWS)
+ IF (IGER.NE.0) THEN
+ CALL SETER ('GRIDAL - ERROR EXIT FROM GQLWSC',20,1)
+ RETURN
+ END IF
+ CALL GSLWSC (RWLB)
+ END IF
+ END IF
+C
+C The next loop runs through the four axes. IAXS = 1 implies the left
+C axis, 2 the bottom axis, 3 the right axis, and 4 the top axis.
+C
+ DO 103 IAXS=1,4
+C
+C On the first pass through the loop, set up the required parameters
+C to do the left axis.
+C
+ IF (IAXS.EQ.1) THEN
+C
+C If the left axis isn't being done at all, or if the type of item
+C being drawn now isn't present on the left axis, skip it.
+C
+ IF (IYLB.LT.0) GO TO 103
+ IF (ITEM.EQ.1.AND.NMNY.LE.1) GO TO 103
+ IF (ITEM.EQ.4.AND.IYLB.LE.0) GO TO 103
+C
+C Set the linear/log flag.
+C
+ ILGF=ILGY
+C
+C Set the mirror-image flag to indicate whether the axis is being drawn
+C in the direction from smaller user values to larger user values (0)
+C or in the reverse direction (1).
+C
+ IMIF=1-IMIY
+C
+C Set the parameters determining the number of major and minor divisions
+C of the axis.
+C
+ NMJD=NMJY
+ NMND=NMNY
+ IF (ITEM.NE.1) NMND=1
+C
+C Determine the fractional coordinates of the first point on the axis
+C and the x and y increment required to get from each major tick to
+C the next.
+C
+ IF (MOD(IGPH,4)-1.LE.0) THEN
+ QMJX=VPLX
+ ELSE
+ QMJX=CUFX(MAX(XMIN,MIN(XMAX,XINT)))
+ IF (ICFELL('GRIDAL',21).NE.0) RETURN
+ END IF
+ DMJX=0.
+ QMJY=VPTY
+ DMJY=VPBY-VPTY
+ IF (ITEM.NE.3) THEN
+ IF (ILGF.EQ.0) THEN
+ DMJY=DMJY/REAL(NMJD)
+ ELSE
+ FPTN=FPTY
+ DMJY=DMJY*FPTN/ABS(ALOG10(WDTY/WDBY))
+ IF (IMIF.NE.0) QMJY=VPBY-REAL(NMJD)*DMJY
+ END IF
+ END IF
+C
+C Set the coordinates of the points at which we should not draw major
+C ticks because they would overlap intersecting axes.
+C
+ AMJX=QMJX
+ AMJY=2.
+ BMJX=QMJX
+ BMJY=-1.
+ IF ((MOD(IGPH,4)-1.LT.0.OR.RMJY.GT.0.).AND.IXLB.GE.0) THEN
+ IF (IGPH/4-1.LE.0) THEN
+ AMJY=VPTY
+ BMJY=VPBY
+ ELSE
+ AMJY=CUFY(MAX(YMIN,MIN(YMAX,YINT)))
+ IF (ICFELL('GRIDAL',22).NE.0) RETURN
+ END IF
+ END IF
+C
+C Compute tick-mark offset parameters.
+C
+ IF (MOD(IGPH,4)-1.LT.0) THEN
+ TMJX=VPRX-VPLX
+ TMNX=VPRX-VPLX
+ ELSE
+ IF (RMJY.GT.-1..AND.RMJY.LT.+1.) THEN
+ TMJX=RMJY
+ ELSE
+ TMJX=REAL(INT(RMJY))/WPLO
+ END IF
+ IF (RMNY.GT.-1..AND.RMNY.LT.+1.) THEN
+ TMNX=RMNY
+ ELSE
+ TMNX=REAL(INT(RMNY))/WPLO
+ END IF
+ END IF
+ TMJY=0.
+ TMNY=0.
+C
+C If numeric labels are being done, compute the value of the first one,
+C the increment required to get from one to the next, and all other
+C local variables required to encode and write the labels.
+C
+ IF (ITEM.EQ.4) THEN
+C
+ VLBL=DBLE(WDTY)
+ IF (ILGF.EQ.0) THEN
+ DLBL=DBLE(WDBY-WDTY)/DBLE(NMJD)
+ VEPS=EPSI*DBLE(ABS(WDTY-WDBY))
+ ELSE
+ DLBL=10.D0**IPTY
+ IF (IMIF.NE.0) DLBL=1.D0/DLBL
+ VEPS=0.D0
+ END IF
+C
+ IF (RDCX.EQ.0.) THEN
+ DLBX=-20./WPLO
+ ELSE IF (RDCX.EQ.1.) THEN
+ DLBX=+20./WPLO
+ IF (MOD(IGPH,4)-1.LE.0) DLBX=DLBX+VPRX-VPLX
+ ELSE IF (RDCX.LE.-1..OR.RDCX.GE.+1.) THEN
+ DLBX=REAL(INT(-RDCX))/WPLO
+ ELSE
+ DLBX=-RDCX
+ END IF
+ DLBY=0.
+C
+ FNLB=FNLY
+C
+ RCHW=RCWY
+ IF (RCHW.LE.0..OR.RCHW.GE.1.) THEN
+ ICHW=INT(MAX(0.,RCHW))
+ IF (ICHW.LE.3) ICHW=(8+4*MOD(ICHW,2))*(1+ICHW/2)
+ RCHW=REAL(ICHW)/WPLO
+ END IF
+ ICHW=MAX(4,INT(RCHW*WPLO))
+C
+ IORI=0
+ ICEN=INT(-SIGN(1.,DLBX))
+C
+ NCFR=NCFY
+ IF (NCFR.NE.0) THEN
+ MLBL=1
+ NLBL=NCFR
+ END IF
+C
+ END IF
+C
+C On the second pass through the loop, set up the required parameters
+C to do the bottom axis.
+C
+ ELSE IF (IAXS.EQ.2) THEN
+C
+ IF (IXLB.LT.0) GO TO 103
+ IF (ITEM.EQ.1.AND.NMNX.LE.1) GO TO 103
+ IF (ITEM.EQ.4.AND.IXLB.LE.0) GO TO 103
+C
+ ILGF=ILGX
+C
+ IMIF=IMIX
+C
+ NMJD=NMJX
+ NMND=NMNX
+ IF (ITEM.NE.1) NMND=1
+C
+ QMJX=VPLX
+ DMJX=VPRX-VPLX
+ IF (ITEM.NE.3) THEN
+ IF (ILGF.EQ.0) THEN
+ DMJX=DMJX/REAL(NMJD)
+ ELSE
+ FPTN=FPTX
+ DMJX=DMJX*FPTN/ABS(ALOG10(WDRX/WDLX))
+ IF (IMIF.NE.0) QMJX=VPRX-REAL(NMJD)*DMJX
+ END IF
+ END IF
+ IF (IGPH/4-1.LE.0) THEN
+ QMJY=VPBY
+ ELSE
+ QMJY=CUFY(MAX(YMIN,MIN(YMAX,YINT)))
+ IF (ICFELL('GRIDAL',23).NE.0) RETURN
+ END IF
+ DMJY=0.
+C
+ AMJX=-1.
+ AMJY=QMJY
+ BMJX=2.
+ BMJY=QMJY
+ IF ((IGPH/4-1.LT.0.OR.RMJX.GT.0.).AND.IYLB.GE.0) THEN
+ IF (MOD(IGPH,4)-1.LE.0) THEN
+ AMJX=VPLX
+ BMJX=VPRX
+ ELSE
+ AMJX=CUFX(MAX(XMIN,MIN(XMAX,XINT)))
+ IF (ICFELL('GRIDAL',24).NE.0) RETURN
+ END IF
+ END IF
+C
+ TMJX=0.
+ TMNX=0.
+ IF (IGPH/4-1.LT.0) THEN
+ TMJY=VPTY-VPBY
+ TMNY=VPTY-VPBY
+ ELSE
+ IF (RMJX.GT.-1..AND.RMJX.LT.+1.) THEN
+ TMJY=RMJX
+ ELSE
+ TMJY=REAL(INT(RMJX))/WPLO
+ END IF
+ IF (RMNX.GT.-1..AND.RMNX.LT.+1.) THEN
+ TMNY=RMNX
+ ELSE
+ TMNY=REAL(INT(RMNX))/WPLO
+ END IF
+ END IF
+C
+ IF (ITEM.EQ.4) THEN
+C
+ VLBL=DBLE(WDLX)
+ IF (ILGF.EQ.0) THEN
+ DLBL=DBLE(WDRX-WDLX)/DBLE(NMJD)
+ VEPS=EPSI*DBLE(ABS(WDRX-WDLX))
+ ELSE
+ DLBL=10.D0**IPTX
+ IF (IMIF.NE.0) DLBL=1.D0/DLBL
+ VEPS=0.D0
+ END IF
+C
+ DLBX=0.
+ IF (RDCY.EQ.0.) THEN
+ DLBY=-20./HPLO
+ ELSE IF (RDCY.EQ.1.) THEN
+ DLBY=+20./HPLO
+ IF (IGPH/4-1.LE.0) DLBY=DLBY+VPTY-VPBY
+ ELSE IF (RDCY.LE.-1..OR.RDCY.GE.+1.) THEN
+ DLBY=REAL(INT(-RDCY))/HPLO
+ ELSE
+ DLBY=-RDCY
+ END IF
+C
+ FNLB=FNLX
+C
+ RCHW=RCWX
+ IF (RCHW.LE.0..OR.RCHW.GE.1.) THEN
+ ICHW=INT(MAX(0.,RCHW))
+ IF (ICHW.LE.3) ICHW=(8+4*MOD(ICHW,2))*(1+ICHW/2)
+ RCHW=REAL(ICHW)/WPLO
+ END IF
+ ICHW=MAX(4,INT(RCHW*WPLO))
+C
+ IF (IORX.EQ.0) THEN
+ IORI=0
+ ICEN=0
+ DLBY=DLBY+SIGN(RCHW,DLBY)
+ ELSE
+ IORI=90
+ ICEN=INT(-SIGN(1.,DLBY))
+ END IF
+C
+ NCFR=NCFX
+ IF (NCFR.NE.0) THEN
+ MLBL=1
+ NLBL=NCFR
+ END IF
+C
+ END IF
+C
+C On the third pass through the loop, set up the required parameters
+C to do the right axis.
+C
+ ELSE IF (IAXS.EQ.3) THEN
+C
+ IF (IYLB.LT.0) GO TO 103
+ IF (ITEM.EQ.1.AND.NMNY.LE.1) GO TO 103
+ IF (ITEM.EQ.4) GO TO 103
+ IF ((ITEM.EQ.1.OR.ITEM.EQ.2).AND.
+ + MOD(IGPH,4)-1.NE.0) GO TO 103
+C
+ ILGF=ILGY
+C
+ IMIF=IMIY
+C
+ NMJD=NMJY
+ NMND=NMNY
+ IF (ITEM.NE.1) NMND=1
+C
+ IF (MOD(IGPH,4)-1.LE.0) THEN
+ QMJX=VPRX
+ ELSE
+ QMJX=CUFX(MAX(XMIN,MIN(XMAX,XINT)))
+ IF (ICFELL('GRIDAL',25).NE.0) RETURN
+ END IF
+ DMJX=0.
+ QMJY=VPBY
+ DMJY=VPTY-VPBY
+ IF (ITEM.NE.3) THEN
+ IF (ILGF.EQ.0) THEN
+ DMJY=DMJY/REAL(NMJD)
+ ELSE
+ FPTN=FPTY
+ DMJY=DMJY*FPTN/ABS(ALOG10(WDTY/WDBY))
+ IF (IMIF.NE.0) QMJY=VPTY-REAL(NMJD)*DMJY
+ END IF
+ END IF
+C
+ AMJX=QMJX
+ AMJY=-1.
+ BMJX=QMJX
+ BMJY=2.
+ IF (RMJY.GT.0..AND.IXLB.GE.0) THEN
+ IF (IGPH/4-1.LE.0) THEN
+ AMJY=VPBY
+ BMJY=VPTY
+ ELSE
+ AMJY=CUFY(MAX(YMIN,MIN(YMAX,YINT)))
+ IF (ICFELL('GRIDAL',26).NE.0) RETURN
+ END IF
+ END IF
+C
+ IF (RMJY.GT.-1..AND.RMJY.LT.+1.) THEN
+ TMJX=-RMJY
+ ELSE
+ TMJX=-REAL(INT(RMJY))/WPLO
+ END IF
+ IF (RMNY.GT.-1..AND.RMNY.LT.+1.) THEN
+ TMNX=-RMNY
+ ELSE
+ TMNX=-REAL(INT(RMNY))/WPLO
+ END IF
+ TMJY=0.
+ TMNY=0.
+C
+C On the fourth pass through the loop, set up the required parameters
+C to do the top axis.
+C
+ ELSE IF (IAXS.EQ.4) THEN
+C
+ IF (IXLB.LT.0) GO TO 103
+ IF (ITEM.EQ.1.AND.NMNX.LE.1) GO TO 103
+ IF ((ITEM.EQ.1.OR.ITEM.EQ.2).AND.IGPH/4-1.NE.0) GO TO 103
+ IF (ITEM.EQ.4) GO TO 103
+C
+ ILGF=ILGX
+C
+ IMIF=1-IMIX
+C
+ NMJD=NMJX
+ NMND=NMNX
+ IF (ITEM.NE.1) NMND=1
+C
+ QMJX=VPRX
+ DMJX=VPLX-VPRX
+ IF (ITEM.NE.3) THEN
+ IF (ILGF.EQ.0) THEN
+ DMJX=DMJX/REAL(NMJD)
+ ELSE
+ FPTN=FPTX
+ DMJX=DMJX*FPTN/ABS(ALOG10(WDRX/WDLX))
+ IF (IMIF.NE.0) QMJX=VPLX-REAL(NMJD)*DMJX
+ END IF
+ END IF
+ IF (IGPH/4-1.LE.0) THEN
+ QMJY=VPTY
+ ELSE
+ QMJY=CUFY(MAX(YMIN,MIN(YMAX,YINT)))
+ IF (ICFELL('GRIDAL',27).NE.0) RETURN
+ END IF
+ DMJY=0.
+C
+ AMJX=2.
+ AMJY=QMJY
+ BMJX=-1.
+ BMJY=QMJY
+ IF (RMJX.GT.0..AND.IYLB.GE.0) THEN
+ IF (MOD(IGPH,4)-1.LE.0) THEN
+ AMJX=VPRX
+ BMJX=VPLX
+ ELSE
+ AMJX=CUFX(MAX(XMIN,MIN(XMAX,XINT)))
+ IF (ICFELL('GRIDAL',28).NE.0) RETURN
+ END IF
+ END IF
+C
+ TMJX=0.
+ TMNX=0.
+ IF (RMJX.GT.-1..AND.RMJX.LT.+1.) THEN
+ TMJY=-RMJX
+ ELSE
+ TMJY=-REAL(INT(RMJX))/WPLO
+ END IF
+ IF (RMNX.GT.-1..AND.RMNX.LT.+1.) THEN
+ TMNY=-RMNX
+ ELSE
+ TMNY=-REAL(INT(RMNX))/WPLO
+ END IF
+C
+ END IF
+C
+C See if the item being drawn requires looping through the tick mark
+C positions along the axis.
+C
+ IF (ITEM.NE.3) THEN
+C
+C Initialize the counter which controls whether we draw major ticks or
+C minor ticks and the flag which determines in which direction we draw
+C the ticks.
+C
+ IMND=0
+ IFLP=0
+C
+C Loop through the positions at which tick marks and/or labels need to
+C be drawn.
+C
+ DO 102 IMRK=1,NMJD*NMND+1
+ IF (IMND.EQ.0) THEN
+ PMJX=QMJX
+ PMJY=QMJY
+ QMJX=QMJX+DMJX
+ QMJY=QMJY+DMJY
+ IF (ITEM.EQ.2) THEN
+ IF (ABS(PMJX-AMJX+PMJY-AMJY).GT..0001.AND.
+ + ABS(PMJX-BMJX+PMJY-BMJY).GT..0001) THEN
+ IFLP=1-IFLP
+ IF (IFLP.EQ.0) THEN
+ CALL PLOTIF (PMJX, PMJY ,0)
+ IF (ICFELL('GRIDAL',29).NE.0) RETURN
+ CALL PLOTIF (PMJX+TMJX,PMJY+TMJY,1)
+ IF (ICFELL('GRIDAL',30).NE.0) RETURN
+ ELSE
+ CALL PLOTIF (PMJX+TMJX,PMJY+TMJY,0)
+ IF (ICFELL('GRIDAL',31).NE.0) RETURN
+ CALL PLOTIF (PMJX, PMJY ,1)
+ IF (ICFELL('GRIDAL',32).NE.0) RETURN
+ END IF
+ END IF
+ END IF
+ IF (ITEM.EQ.4) THEN
+ IF (FNLB(2:2).NE.'I'.AND.FNLB(2:2).NE.'i') THEN
+ VNCD=REAL(VLBL*OPEP)
+ IF (ABS(VLBL).LT.VEPS) VNCD=0.
+ LABL=' '
+ WRITE (LABL,FNLB) VNCD
+ ELSE
+ ILBL=NINT(VLBL)
+ WRITE (LABL,FNLB) ILBL
+ END IF
+ IF (NCFR.EQ.0) CALL GALBEX (LABL,MLBL,NLBL)
+ IF (ILTY.EQ.0) THEN
+ XDUM=CFUX(PMJX+DLBX)
+ IF (ICFELL('GRIDAL',33).NE.0) RETURN
+ YDUM=CFUY(PMJY+DLBY)
+ IF (ICFELL('GRIDAL',34).NE.0) RETURN
+c print *,' +++GRIDAL AV WTSTR MLBL NLBL LABL(MLBL:N
+c + NLBL) FNLB',
+c + MLBL,NLBL,LABL(MLBL:NLBL),FNLB
+ CALL PLCHHQ (XDUM,YDUM,LABL(MLBL:NLBL),
+ + FLOAT(ICHW),REAL(IORI),REAL(ICEN))
+c CALL WTSTR (XDUM,YDUM,LABL(MLBL:NLBL),
+c + ICHW,IORI,ICEN)
+ IF (ICFELL('GRIDAL',35).NE.0) RETURN
+ ELSE
+ XDUM=CFUX(PMJX+DLBX)
+ IF (ICFELL('GRIDAL',36).NE.0) RETURN
+ YDUM=CFUY(PMJY+DLBY)
+ IF (ICFELL('GRIDAL',37).NE.0) RETURN
+c print *,' +++GRIDAL AV PLCHHQMLBL NLBL LABL(MLBL:
+c + NLBL) FNLB',
+c + MLBL,NLBL,LABL(MLBL:NLBL),FNLB
+ CALL PLCHHQ (XDUM,YDUM,LABL(MLBL:NLBL),
+ + RCHW,REAL(IORI),REAL(ICEN))
+ IF (ICFELL('GRIDAL',38).NE.0) RETURN
+ END IF
+ IF (ILGF.EQ.0) THEN
+ VLBL=VLBL+DLBL
+ ELSE
+ VLBL=VLBL*DLBL
+ END IF
+ END IF
+ ELSE
+ IF (ILGF.EQ.0) THEN
+ PMNX=PMJX+(QMJX-PMJX)*REAL(IMND)/REAL(NMND)
+ PMNY=PMJY+(QMJY-PMJY)*REAL(IMND)/REAL(NMND)
+ ELSE
+ IF (IMIF.EQ.0) THEN
+ PMNX=PMJX+(QMJX-PMJX)*ALOG10(REAL(IMND+1))/FPTN
+ PMNY=PMJY+(QMJY-PMJY)*ALOG10(REAL(IMND+1))/FPTN
+ ELSE
+ PMNX=QMJX+(PMJX-QMJX)*ALOG10(REAL(NMND-IMND+1))
+ + /FPTN
+ PMNY=QMJY+(PMJY-QMJY)*ALOG10(REAL(NMND-IMND+1))
+ + /FPTN
+ END IF
+ END IF
+ IFLP=1-IFLP
+ IF (IFLP.EQ.0) THEN
+ CALL PLOTIF (PMNX, PMNY ,0)
+ IF (ICFELL('GRIDAL',39).NE.0) RETURN
+ CALL PLOTIF (PMNX+TMNX,PMNY+TMNY,1)
+ IF (ICFELL('GRIDAL',40).NE.0) RETURN
+ ELSE
+ CALL PLOTIF (PMNX+TMNX,PMNY+TMNY,0)
+ IF (ICFELL('GRIDAL',41).NE.0) RETURN
+ CALL PLOTIF (PMNX, PMNY ,1)
+ IF (ICFELL('GRIDAL',42).NE.0) RETURN
+ END IF
+ END IF
+ IMND=MOD(IMND+1,NMND)
+ 102 CONTINUE
+ ELSE
+C
+C Draw the axis.
+C
+ CALL PLOTIF (QMJX,QMJY,0)
+ IF (ICFELL('GRIDAL',43).NE.0) RETURN
+ CALL PLOTIF (QMJX+DMJX,QMJY+DMJY,1)
+ IF (ICFELL('GRIDAL',44).NE.0) RETURN
+C
+ END IF
+C
+ 103 CONTINUE
+C
+C Reset the polyline and text color indices.
+C
+ IF ((ITEM.EQ.1.AND.ICMN.GE.0).OR.
+ + (ITEM.EQ.2.AND.ICMJ.GE.0).OR.
+ + (ITEM.EQ.3.AND.ICAX.GE.0).OR.
+ + (ITEM.EQ.4.AND.ICLB.GE.0)) THEN
+ CALL PLOTIF (0.,0.,2)
+ IF (ICFELL('GRIDAL',45).NE.0) RETURN
+ CALL GSPLCI (ICS1)
+ END IF
+C
+ IF (ITEM.EQ.4.AND.ICLB.GE.0) THEN
+ CALL GSTXCI (ICS2)
+ END IF
+C
+C Reset the line width scale factor.
+C
+ IF ((ITEM.EQ.1.AND.RWMN.GT.0.).OR.
+ + (ITEM.EQ.2.AND.RWMJ.GT.0.).OR.
+ + (ITEM.EQ.3.AND.RWAX.GT.0.).OR.
+ + (ITEM.EQ.4.AND.RWLB.GT.0.)) THEN
+ CALL PLOTIF (0.,0.,2)
+ IF (ICFELL('GRIDAL',46).NE.0) RETURN
+ CALL GSLWSC (SLWS)
+ END IF
+C
+ 104 CONTINUE
+C
+C Flush the SPPS pen-move buffer.
+C
+ CALL PLOTIF (0.,0.,2)
+ IF (ICFELL('GRIDAL',47).NE.0) RETURN
+C
+C Restore the original state of the clipping indicator.
+C
+ CALL GSCLIP (ICLP)
+C
+C Done.
+C
+ RETURN
+C
+ END
diff --git a/LIBTOOLS/tools/diachro/src/POS/os.f90 b/LIBTOOLS/tools/diachro/src/POS/os.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3e5026fc07845fc29e3e82878e3315c58546c72a
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/os.f90
@@ -0,0 +1,85 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/post/s.os.f90, Version:1.2, Date:98/10/02, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ######spl
+ FUNCTION OS(PT,PP)
+! ##################
+!
+!!**** *OS* - Computes the equivalent potential temperature
+!!
+!! PURPOSE
+!! -------
+! Computes the equivalent potential temperature
+! at a given temperature and pressure, used in the
+! emagram plotting utility of TRACE.
+!
+!!** METHOD
+!! ------
+!! Explicit analytical formula.
+!!
+!! EXTERNAL
+!! --------
+!! WSOUS: computes the saturation mixing ratio at a given
+!! temperature and pressure
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Among many others, see for instance:
+!! Bluestein H. B., 1992, "Synoptic-Dynamic Meteorology in mid-latitudes"
+!! Volume 1, Priciples of Kinematics and Dynamics, Section 4.3, p. 195,
+!! Oxford University Press.
+!!
+!!
+!! AUTHOR
+!! ------
+!! - Initial version Peridot TRACE Program, P.Bougeault *Meteo-France*,
+!! modified by R. Benoit (mc2, april 91) for the PYREX Oracle data base.
+!! - Present version J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 10/01/95
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+!
+REAL,INTENT(IN) :: PT, PP
+REAL :: OS
+
+!
+!* 0.2 Declaration of external function interface
+!
+INTERFACE
+ FUNCTION WSOUS(PT,PP)
+ REAL,INTENT(IN) :: PT, PP
+ REAL :: WSOUS
+ END FUNCTION WSOUS
+END INTERFACE
+!-------------------------------------------------------------------------------
+!
+!* 1. CALCULATION OF OS
+! -----------------
+!
+! OS and PT (KELVIN), PP (MILLIBARS)
+!
+OS = PT*((1000./PP)**.286)/(EXP(-2.6518986*WSOUS(PT,PP)/PT))
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+END FUNCTION OS
diff --git a/LIBTOOLS/tools/diachro/src/POS/tracexy.f90 b/LIBTOOLS/tools/diachro/src/POS/tracexy.f90
new file mode 100644
index 0000000000000000000000000000000000000000..aa1d686288fa76a9939b2bd7326516a8ab680c9d
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/tracexy.f90
@@ -0,0 +1,133 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/post/s.tracexy.f90, Version:1.2, Date:98/10/02, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ######spl
+ SUBROUTINE TRACEXY
+! ##################
+!
+!!**** *TRACEXY* - Overlays a gridpoint location stencil over a
+!! horizontal cross-section plot.
+!!
+!! PURPOSE
+!! -------
+! When LXY=.T. shows the gridpoint location on horizontal
+! cross-section plots.
+!
+!!** METHOD
+!! ------
+!! Draws polylines between gridpoints corresponding to the NMGRID value.
+!!
+!! EXTERNAL
+!! --------
+!! GSLN : NCAR routine to set a line type.
+!! GPL : NCAR routine to draw a polyline.
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_NMGRID : declares global variable NMGRID
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!! Module MODD_OUT : Defines a log. unit for printing
+!! NIMAXT, NJMAXT: Size of the displayed window within a
+!! MESO-NH field arrays
+!!
+!! Module MODD_COORD : declares gridpoint coordinates (TRACE use)
+!! XXX,XXY : x, y coordinate values for all the MESO-NH grids
+!!
+!! Module MODD_DIM1 : Contains dimensions
+!! NIMAX,NJMAX : x, and y array dimensions
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_NMGRID
+USE MODD_OUT
+USE MODD_COORD
+USE MODD_DIM1
+
+IMPLICIT NONE
+!
+!* 0.1 Variables locales
+
+INTEGER :: JJLOOP, JILOOP
+
+REAL,DIMENSION(2) :: ZX, ZY
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. GRIDPOINT STENCIL DRAWING
+! -------------------------
+!
+CALL GSLN(3)
+!
+!* 1.1 Draws a "w" grid stencil
+!
+DO JILOOP=1,NIMAXT
+ ZX(1)=XXX(NIINF+JILOOP-1,4)
+ ZX(2)=XXX(NIINF+JILOOP-1,4)
+ ZY(1)=XXY(NJINF,4)
+ ZY(2)=XXY(NJSUP,4)
+ CALL GPL(2,ZX,ZY)
+ENDDO
+!
+DO JJLOOP=1,NJMAXT
+ ZX(1)=XXX(NIINF,4)
+ ZX(2)=XXX(NISUP,4)
+ ZY(1)=XXY(NJINF+JJLOOP-1,4)
+ ZY(2)=XXY(NJINF+JJLOOP-1,4)
+ CALL GPL(2,ZX,ZY)
+ENDDO
+!
+!* 1.2 Draws the NMGRID grid stencil
+!
+IF(NMGRID.EQ.4)CALL GSLN(3)
+IF(NMGRID.EQ.2)CALL GSLN(2)
+IF(NMGRID.EQ.3)CALL GSLN(4)
+IF(NMGRID.EQ.1)CALL GSLN(5)
+!
+DO JILOOP=1,NIMAXT
+ ZX(1)=XXX(NIINF+JILOOP-1,NMGRID)
+ ZX(2)=XXX(NIINF+JILOOP-1,NMGRID)
+ ZY(1)=XXY(NJINF,NMGRID)
+ ZY(2)=XXY(NJSUP,NMGRID)
+ CALL GPL(2,ZX,ZY)
+ENDDO
+!
+DO JJLOOP=1,NJMAXT
+ ZX(1)=XXX(NIINF,NMGRID)
+ ZX(2)=XXX(NISUP,NMGRID)
+ ZY(1)=XXY(NJINF+JJLOOP-1,NMGRID)
+ ZY(2)=XXY(NJINF+JJLOOP-1,NMGRID)
+ CALL GPL(2,ZX,ZY)
+ENDDO
+!
+!* 2. EXIT
+! ----
+!
+CALL GSLN(1)
+!
+RETURN
+END SUBROUTINE TRACEXY
diff --git a/LIBTOOLS/tools/diachro/src/POS/tsa.f90 b/LIBTOOLS/tools/diachro/src/POS/tsa.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d972354ed18f74e2d208ba731b542a37eb188b95
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/tsa.f90
@@ -0,0 +1,103 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/post/s.tsa.f90, Version:1.2, Date:98/10/02, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ######spl
+ FUNCTION TSA(POS,PP)
+! ####################
+!
+!!**** *TSA* - Computation of the wet-bulb potential temperature
+!!
+!!
+!! PURPOSE
+!! -------
+! Computation of the wet-bulb potential temperature from given
+! equivalent potential temperature and pressure used in the
+! emagram routine of TRACE
+!
+!!** METHOD
+!! ------
+!! Iterative formula
+!!
+!! EXTERNAL
+!! --------
+!! WSOUS: computes the saturation miwing ration at given temperature
+!! and moisture
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Among many others, see for instance:
+!! Bluestein H. B., 1992, "Synoptic-Dynamic Meteorology in mid-latitudes"
+!! Volume 1, Priciples of Kinematics and Dynamics, Section 4.3, p. 195,
+!! Oxford University Press.
+!!
+!! AUTHOR
+!! ------
+!! - Initial version Peridot TRACE Program, P.Bougeault *Meteo-France*,
+!! modified by R. Benoit (mc2, april 91) for the PYREX Oracle data base.
+!! - Present version J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 04/07/94
+!! Updated PM 10/01/95
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declaration of arguments and result
+!
+REAL,INTENT(IN) :: POS, PP
+REAL :: TSA
+
+!
+!* 0.2 Declaration of local variables
+!
+!
+INTEGER :: I
+REAL :: ZA, ZTQ, ZD, ZX
+!
+!* 0.3 Declaration of external function interface
+!
+INTERFACE
+ FUNCTION WSOUS(PT,PP)
+ REAL,INTENT(IN) :: PT, PP
+ REAL :: WSOUS
+ END FUNCTION WSOUS
+END INTERFACE
+!-------------------------------------------------------------------------------
+!
+!* 1. CALCULATION OF TSA
+! ------------------
+!
+! TSA and OS (KELVIN), PP (MILLIBARS)
+! SIGN(ZA,ZB) REPLACES THE ALGEBRAIC SIGN OF ZA WITH THE SIGN OF ZB
+!
+ZA = POS
+ZTQ = 253.16
+ZD = 120.
+! If the temperature difference ZX is small, exit this loop
+DO I = 1,12
+ ZD=ZD/2.
+ ZX=ZA*EXP(-2.6518986*WSOUS(ZTQ,PP)/ZTQ)-ZTQ*((1000./PP)**.286)
+ IF(ABS(ZX).LT.0.01)EXIT
+ ZTQ = ZTQ + SIGN(ZD,ZX)
+ENDDO
+TSA = ZTQ
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END FUNCTION TSA
diff --git a/LIBTOOLS/tools/diachro/src/POS/valmnmx.f90 b/LIBTOOLS/tools/diachro/src/POS/valmnmx.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b8d42e89c7ad20c50b93442511509f4333d42070
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/valmnmx.f90
@@ -0,0 +1,146 @@
+! ######spl
+ SUBROUTINE VALMNMX(PMIN,PMAX)
+! #############################
+!
+!!**** *VALMNMX* - Dans le cadre des profils, determination automatique
+! des bornes min et max.
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! None
+!!
+!! AUTHOR
+!! ------
+!!
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 14/03/95
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+!
+
+REAL :: PMIN,PMAX
+!
+!* 0.2 local variables
+!
+REAL :: ZMN,ZMX,Z
+REAL :: ZVAL, ZABSVAL,ZJJB, ZJJT
+REAL,DIMENSION(38) :: ZDIXPM
+INTEGER :: J, JJ, ISIGNVAL, IJJM
+!
+!-------------------------------------------------------------------------------
+ZDIXPM(1)=1.E-1;ZDIXPM(2)=1.E-2;ZDIXPM(3)=1.E-3;ZDIXPM(4)=1.E-4;ZDIXPM(5)=1.E-5
+ZDIXPM(6)=1.E-6;ZDIXPM(7)=1.E-7;ZDIXPM(8)=1.E-8;ZDIXPM(9)=1.E-9
+ZDIXPM(10)=1.E-10;ZDIXPM(11)=1.E-11;ZDIXPM(12)=1.E-12;ZDIXPM(13)=1.E-13
+ZDIXPM(14)=1.E-14;ZDIXPM(15)=1.E-15;ZDIXPM(16)=1.E-16
+ZDIXPM(17)=1.E-17;ZDIXPM(18)=1.E-18;ZDIXPM(19)=1.E-19
+ZDIXPM(20)=1.E-20;ZDIXPM(21)=1.E-21;ZDIXPM(22)=1.E-22
+ZDIXPM(23)=1.E-23;ZDIXPM(24)=1.E-24;ZDIXPM(25)=1.E-25
+ZDIXPM(26)=1.E-26;ZDIXPM(27)=1.E-27;ZDIXPM(28)=1.E-28
+ZDIXPM(29)=1.E-29;ZDIXPM(30)=1.E-30;ZDIXPM(31)=1.E-31
+ZDIXPM(32)=1.E-32;ZDIXPM(33)=1.E-33;ZDIXPM(34)=1.E-34
+ZDIXPM(35)=1.E-35;ZDIXPM(36)=1.E-36;ZDIXPM(37)=1.E-37
+ZDIXPM(38)=1.E-38
+
+! Juillet 99 pour correction sur station du resultat de la fonction ANINT
+! pour les valeurs > a 2**31-1
+Z=HUGE(1)
+
+DO J=1,2
+ IF(J == 1)ZVAL=PMIN
+ IF(J == 2)ZVAL=PMAX
+ ISIGNVAL=SIGN(1.,ZVAL)
+ ZABSVAL=ABS(ZVAL)
+! Rectification en Juin 99 pour tenir compte de la capacite des entiers
+! sur station
+! Juillet 99 pour correction sur station du resultat de la fonction ANINT
+! pour les valeurs > a 2**31-1
+ IF(ZABSVAL >= Z )THEN
+ SELECT CASE(ISIGNVAL)
+ CASE(1)
+ IF(J == 1)ZMN=AINT(ZABSVAL-1.)
+ IF(J == 2)ZMX=AINT(ZABSVAL+1.)
+ CASE(-1)
+ IF(J == 1)ZMN=AINT(ZABSVAL+1.)
+ IF(J == 2)ZMX=AINT(ZABSVAL-1.)
+ END SELECT
+ ELSE IF(ZABSVAL >= 1. .AND. ZABSVAL < Z)THEN
+! IF(ZABSVAL >= 1.)THEN
+ SELECT CASE(ISIGNVAL)
+ CASE(1)
+ IF(J == 1)ZMN=ANINT(ZABSVAL-1.)
+ IF(J == 2)ZMX=ANINT(ZABSVAL+1.)
+ CASE(-1)
+ IF(J == 1)ZMN=ANINT(ZABSVAL+1.)
+ IF(J == 2)ZMX=ANINT(ZABSVAL-1.)
+ END SELECT
+ ELSE IF(ZABSVAL >=1.E-37 .AND. ZABSVAL <1.)THEN
+ SELECT CASE(ISIGNVAL)
+ CASE(1)
+ IF(ZABSVAL >= ZDIXPM(1) .AND. ZABSVAL < 1.)THEN
+ DO JJ=1,9
+ ZJJT=(JJ+1)*.1
+ ZJJB=JJ*.1
+ IF(ZABSVAL >= ZJJB .AND. ZABSVAL < ZJJT)EXIT
+ ENDDO
+ IF(J == 1)ZMN=ZJJB
+ IF(J == 2)ZMX=ZJJT
+ ELSE
+ DO JJ=1,37
+ IF(ZABSVAL >= ZDIXPM(JJ+1) .AND. ZABSVAL < ZDIXPM(JJ))EXIT
+ ENDDO
+ IJJM=JJ
+ IF(J == 1)ZMN=ZDIXPM(IJJM+1)
+ IF(J == 2)ZMX=ZDIXPM(IJJM)
+ ENDIF
+ CASE(-1)
+ IF(ZABSVAL >= ZDIXPM(1) .AND. ZABSVAL < 1.)THEN
+ DO JJ=1,9
+ ZJJT=(JJ+1)*.1
+ ZJJB=JJ*.1
+ IF(ZABSVAL >= ZJJB .AND. ZABSVAL < ZJJT)EXIT
+ ENDDO
+ IF(J == 1)ZMN=ZJJT
+ IF(J == 2)ZMX=ZJJB
+ ELSE
+ DO JJ=1,37
+ IF(ZABSVAL >= ZDIXPM(JJ+1) .AND. ZABSVAL < ZDIXPM(JJ))EXIT
+ ENDDO
+ IJJM=JJ
+ IF(J == 1)ZMN=ZDIXPM(IJJM)
+ IF(J == 2)ZMX=ZDIXPM(IJJM+1)
+ ENDIF
+ END SELECT
+ ELSE
+ IF(J == 1)ZMN=0.
+ IF(J == 2)ZMX=0.
+ END IF
+IF(J == 1)ZMN=ZMN*ISIGNVAL
+IF(J == 1)PMIN=ZMN
+IF(J == 2)ZMX=ZMX*ISIGNVAL
+IF(J == 2)PMAX=ZMX
+ENDDO
+RETURN
+END SUBROUTINE VALMNMX
+
diff --git a/LIBTOOLS/tools/diachro/src/POS/valngrid.f90 b/LIBTOOLS/tools/diachro/src/POS/valngrid.f90
new file mode 100644
index 0000000000000000000000000000000000000000..96db920dc180254e33d2e160b35bdd9cbaeb961a
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/valngrid.f90
@@ -0,0 +1,141 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/post/s.valngrid.f90, Version:1.2, Date:98/10/02, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ######spl
+ SUBROUTINE VALNGRID(HCAR)
+! #########################
+!
+!!**** *VALNGRID* - Selects the NGRID value (alias KGRID or IGRID
+!! or NMGRID)
+!!
+!! PURPOSE
+!! -------
+! Given only the name of a variable, returns the corresponding
+! NGRID value, and calculates the true altitude array for this
+! grid location.
+!
+!!** METHOD
+!! ------
+!!
+!! The name is given as a character string, the NGRID value is found
+!! by searching the LFIFM record for this string.
+!! Next, the relevant altitude array is built by a call to COMPCOORD.
+!!
+!! EXTERNAL
+!! --------
+!! COMPCOORD : computes the true sea-level altitude corresponding to the
+!! current NGRID selection.
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_NMGRID : declares global variable NMGRID
+!! NMGRID : Current MESO-NH grid indicator
+!!
+!! Module MODD_OUT : Defines a log. unit for printing
+!! CNAMFILE : filename prefix of the FM files to be processed
+!! NLUOUT : Logical unit number for printed output
+!!
+!! Module MODD_DIM1 : Contains dimensions
+!! NIMAX,NJMAX,NKMAX : x, y, and z array dimensions
+!!
+!! Module MODD_PARAMETERS : Contains array border depths
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!! Module MODD_LUNIT1 : Declares names and log. unit of files
+!! CLUOUT : Name of output_listing file
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! MESO-NH User's Manual, TRACE Post Processing sections, Version 1.0:
+!! + Book1: Concepts and Fundamentals, to appear in 1994;
+!! + Book2: Technical Reference and Flowcharts, to appear in 1994;
+!! + Book3: Tutorial, November 1994.
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 01/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_NMGRID
+USE MODD_DIM1
+USE MODD_LUNIT1
+USE MODD_PARAMETERS
+USE MODD_OUT
+USE MODI_FMREAD
+
+IMPLICIT NONE
+!
+!* 0.1 Declarations and dummy arguments
+!
+CHARACTER(LEN=*) :: HCAR ! name of the requested variable, as a string
+!
+!* 0.2 Local variables
+!
+INTEGER :: I3D ! size of 3D arrays
+INTEGER :: IIU, IJU, IKU ! array sises
+
+INTEGER :: ILENG, IGRID,ILENCH,IRESP ! File
+CHARACTER (LEN=16) :: YRECFM ! management
+CHARACTER (LEN=100) :: YCOMMENT ! variables
+!
+CHARACTER(LEN=10) :: YCAR ! work array
+
+REAL, DIMENSION(:,:,:),ALLOCATABLE,SAVE :: ZS3D ! 3D array used to read data
+ ! in initial file
+!
+!* 0.3 String justified left to avoid trouble
+!
+!WRITE(NLUOUT,*)' HCAR ',HCAR
+YCAR=ADJUSTL(HCAR)
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. SETS ARRAY SIZES AND ALLOCATIONS
+! --------------------------------
+!
+IIU=NIMAX+2*JPHEXT
+IJU=NJMAX+2*JPHEXT
+IKU=NKMAX+2*JPVEXT
+
+IF(.NOT.ALLOCATED(ZS3D))THEN
+ ALLOCATE(ZS3D(IIU,IJU,IKU))
+END IF
+
+I3D=IIU*IJU*IKU
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. SEARCHES THE LFIFM FILE FOR THE STRING
+! AND COMPUTES APPROPRIATE TRUE-ALTITUDES
+! -------------------------------- --------
+!
+YRECFM = YCAR
+CALL FMREAD(CNAMFILE,YRECFM,CLUOUT,I3D,ZS3D,IGRID,ILENCH,YCOMMENT,IRESP)
+IF(IRESP.EQ.-47)THEN
+ NMGRID=1
+ELSE
+ NMGRID=IGRID
+END IF
+CALL COMPCOORD(NMGRID)
+DEALLOCATE(ZS3D)
+!
+!-------------------------------------------------------------------------------!
+!* 3. EXIT
+! ----
+RETURN
+!
+END SUBROUTINE VALNGRID
diff --git a/LIBTOOLS/tools/diachro/src/POS/wsous.f90 b/LIBTOOLS/tools/diachro/src/POS/wsous.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8b2a059ad3f70ac1e0c98a11f2b65c4fa1df581f
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/wsous.f90
@@ -0,0 +1,91 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/post/s.wsous.f90, Version:1.2, Date:98/10/02, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ######spl
+ FUNCTION WSOUS(PT,PP)
+! #####################
+!
+!!**** *WSOUS* - Computes the saturation mixing ratio
+!!
+!!
+!! PURPOSE
+!! -------
+! Computes the saturation mixing ratio for a given temperature
+! used in the emagram routine of TRACE
+!
+!!** METHOD
+!! ------
+!! Explicit analytical formula
+!!
+!! EXTERNAL
+!! --------
+!! ESAT : computes the saturation water vapor pressure at a
+!! given temperature
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Among many others, see for instance:
+!! Bluestein H. B., 1992, "Synoptic-Dynamic Meteorology in mid-latitudes"
+!! Volume 1, Priciples of Kinematics and Dynamics, Section 4.3, p. 195,
+!! Oxford University Press.
+!!
+!!
+!! AUTHOR
+!! ------
+!! - Initial version Peridot TRACE Program, P.Bougeault *Meteo-France*,
+!! modified by R. Benoit (mc2, april 91) for the PYREX Oracle data base.
+!! - Present version J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 10/01/95
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declaration of arguments and result
+!
+REAL,INTENT(IN) :: PT, PP
+REAL :: WSOUS
+!
+!* 0.2 Declaration of local variables
+!
+REAL :: ZX
+!
+!* 0.3 Declaration of external function interfaces
+!
+INTERFACE
+ FUNCTION ESAT(PT)
+ REAL,INTENT(IN) :: PT
+ REAL :: ESAT
+ END FUNCTION ESAT
+END INTERFACE
+!-------------------------------------------------------------------------------
+!
+!* 1. CALCULATION OF WSOUS
+! --------------------
+!
+! W (GRAMS WATER VAPOR/KILOGRAM DRY AIR), PP (MILLIBARS)
+!
+ZX = ESAT(PT)
+WSOUS = 622.*ZX/(PP-ZX)
+IF(PT.GE.999.)WSOUS = 0.
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+!
+RETURN
+END FUNCTION WSOUS
diff --git a/LIBTOOLS/tools/diachro/src/POS/wtstr.f b/LIBTOOLS/tools/diachro/src/POS/wtstr.f
new file mode 100644
index 0000000000000000000000000000000000000000..3d652d0d149431237aee06a2fa551fed048af767
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/POS/wtstr.f
@@ -0,0 +1,174 @@
+C
+C $Id$
+C
+ SUBROUTINE WTSTR (PX,PY,CH,IS,IO,IC)
+C
+C WTSTR is called to draw a character string in a specified position.
+C
+C PX and PY specify, in user coordinates, the position of a point
+C relative to which a character string is to be positioned.
+C
+C CH is the character string to be written.
+C
+C IS is the desired size of the characters to be used, stated as a
+C character width in the plotter coordinate system. The values 0, 1,
+C 2, and 3 mean 8, 12, 16, and 24, respectively.
+C
+C IO is the desired orientation angle, in degrees counterclockwise from
+C a horizontal vector pointing to the right.
+C
+C IC specifies the desired type of centering. A negative value puts
+C (PX,PY) in the center of the left end of the character string, a zero
+C puts (PX,PY) in the center of the whole string, and a positive value
+C puts (PX,PY) in the center of the right end of the character string.
+C
+ CHARACTER*(*) CH
+C
+C Define arrays in which to save the current viewport and window.
+C
+ DIMENSION VP(4),WD(4)
+C
+C Check for an uncleared prior error.
+C
+ IF (ICFELL('WTSTR - UNCLEARED PRIOR ERROR',1).NE.0) RETURN
+C
+C Flush the pen-move buffer.
+C
+ CALL PLOTIF (0.,0.,2)
+ IF (ICFELL('WTSTR',2).NE.0) RETURN
+C
+C Compute the coordinates of (PX,PY) in the fractional coordinate
+C system (normalized device coordinates).
+C
+ XN=CUFX(PX)
+ IF (ICFELL('WTSTR',3).NE.0) RETURN
+ YN=CUFY(PY)
+ IF (ICFELL('WTSTR',4).NE.0) RETURN
+c print *,' XN,YN ',XN,YN
+C
+C Save the current window and, if necessary, redefine it so that we can
+C use normalized device coordinates.
+C
+ CALL GQCNTN (IE,NT)
+ IF (IE.NE.0) THEN
+ CALL SETER ('WTSTR - ERROR EXIT FROM GQCNTN',5,1)
+ RETURN
+ END IF
+ IF (NT.NE.0) THEN
+ CALL GQNT (NT,IE,WD,VP)
+c print *,' **wtrst WD PX PY ',WD,PX,PY
+ IF (IE.NE.0) THEN
+ CALL SETER ('WTSTR - ERROR EXIT FROM GQNT',6,1)
+ RETURN
+ END IF
+ CALL GSWN (NT,VP(1),VP(2),VP(3),VP(4))
+ END IF
+C
+C Save current character height, text path, character up vector, and
+C text alignment.
+C
+ CALL GQCHH (IE,OS)
+ IF (IE.NE.0) THEN
+ CALL SETER ('WTSTR - ERROR EXIT FROM GQCHH',7,1)
+ RETURN
+ END IF
+ CALL GQTXP (IE,IP)
+ IF (IE.NE.0) THEN
+ CALL SETER ('WTSTR - ERROR EXIT FROM GQTXP',8,1)
+ RETURN
+ END IF
+ CALL GQCHUP (IE,UX,UY)
+ IF (IE.NE.0) THEN
+ CALL SETER ('WTSTR - ERROR EXIT FROM GQCHUP',9,1)
+ RETURN
+ END IF
+ CALL GQTXAL (IE,IX,IY)
+ IF (IE.NE.0) THEN
+ CALL SETER ('WTSTR - ERROR EXIT FROM GQTXAL',10,1)
+ RETURN
+ END IF
+C
+C Define the character height. (The final scale factor is derived from
+C the default font.)
+C
+ CALL GETUSV ('YF',MY)
+ IF (ICFELL('WTSTR',11).NE.0) RETURN
+ YS=FLOAT(2**MY)
+ IF (IS.GE.0.AND.IS.LE.3) THEN
+ CS=FLOAT(8+4*IS+4*(IS/3))/YS
+ ELSE
+ CS=AMIN1(FLOAT(IS),YS)/YS
+ ENDIF
+C
+C CS=CS*1.0
+C
+ CALL GSCHH(CS)
+C
+C Define the text path.
+C
+ CALL GSTXP (0)
+C
+C Define the character up vector.
+C
+ JO=MOD(IO,360)
+ IF (JO.EQ.0) THEN
+ CALL GSCHUP (0.,1.)
+ ELSE IF (JO.EQ.90) THEN
+ CALL GSCHUP (-1.,0.)
+ ELSE IF (JO.EQ.180) THEN
+ CALL GSCHUP (0.,-1.)
+ ELSE IF (JO.EQ.270) THEN
+ CALL GSCHUP (1.,0.)
+ ELSE IF (JO.GT.0.AND.JO.LT.180) THEN
+ CALL GSCHUP (-1.,1./TAN(FLOAT(JO)*3.1415926/180.))
+ ELSE
+ CALL GSCHUP (1.,-1./TAN(FLOAT(JO)*3.1415926/180.))
+ ENDIF
+C
+C Define the text alignment.
+C
+ CALL GSTXAL (MAX(-1,MIN(+1,IC))+2,3)
+C
+C Plot the characters.
+C
+ IF(LEN_TRIM(CH) < LEN(CH))THEN
+ CH=ADJUSTL(CH)
+ ENDIF
+c print *,' **wts... AV GTX XN,YN,CH ',XN,YN,CH
+ CALL GTX (XN,YN,CH)
+c print *,' **wts... AP GTX '
+C
+C Restore the original text attributes.
+C
+ CALL GSCHH (OS)
+ CALL GSTXP (IP)
+ CALL GSCHUP (UX,UY)
+ CALL GSTXAL (IX,IY)
+C
+C Restore the window definition.
+C
+ IF (NT.NE.0) THEN
+ CALL GSWN (NT,WD(1),WD(2),WD(3),WD(4))
+ END IF
+C
+C Update the pen position.
+C
+c print *,' **wtrstortie '
+ IF(PX < WD(1) .OR. PX > WD(2) .OR. PY < WD(3) .OR.
+ 1PY > WD(4))THEN
+c print *,' **wtrst WD,PX,PY ',WD,PX,PY
+ IF(PX < WD(1))PX=WD(1)
+ IF(PX > WD(2))PX=WD(2)
+ IF(PY < WD(3))PY=WD(3)
+ IF(PY > WD(4))PY=WD(4)
+ ENDIF
+ CALL FRSTPT (PX,PY)
+c print *,' **wtrstortie b'
+ IF (ICFELL('WTSTR',12).NE.0) RETURN
+C
+C Done.
+C
+c print *,' **wtrstortie av return '
+ RETURN
+C
+ END
diff --git a/LIBTOOLS/tools/diachro/src/TOOL/change_a_grid.f90 b/LIBTOOLS/tools/diachro/src/TOOL/change_a_grid.f90
new file mode 100644
index 0000000000000000000000000000000000000000..0338c65730e0f8327521491df29ed97d9a096c6d
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/TOOL/change_a_grid.f90
@@ -0,0 +1,146 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+! ######spl
+MODULE MODI_CHANGE_A_GRID
+!#################################
+!
+INTERFACE
+ SUBROUTINE CHANGE_A_GRID(PFIELD,KGRID,PFIELDA,KLUOUT)
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PFIELD ! values of the field
+INTEGER, INTENT(INOUT) :: KGRID ! Mesonh grid indicator
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PFIELDA ! values of the field on the A-grid
+INTEGER, INTENT(IN), OPTIONAL :: KLUOUT ! unit number of listing
+!
+END SUBROUTINE CHANGE_A_GRID
+END INTERFACE
+END MODULE MODI_CHANGE_A_GRID
+! ######spl
+ SUBROUTINE CHANGE_A_GRID(PFIELD,KGRID,PFIELDA,KLUOUT)
+! #####################
+!
+!!**** *CHANGE_A_GRID* - change flux point variables to mass points
+!!
+!!
+!! PURPOSE
+!! -------
+!!
+!!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! Functions MXF, MYF, MZF
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_LUNIT : contains logical unit names for all models
+!! CLUOUT0 : name of output-listing
+!! Module MODD_FIELD1 : contains prognostics variables
+!! XUT
+!! XVT
+!! XWT
+!! Module MODD_GRID1
+!! XZZ
+!! Module MODD_DIAG_FIELD1
+!! XUAT
+!! XVAT
+!! XWAT
+!! XZA
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book 2
+!!
+!! AUTHOR
+!! ------
+!!
+!! V.Ducrocq Meteo-France
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 21/03/97
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF, ONLY : NVERB
+!
+USE MODI_SHUMAN
+!
+IMPLICIT NONE
+!
+!* 0.1 Declaration of arguments
+! ------------------------
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PFIELD ! values of the field
+INTEGER, INTENT(INOUT) :: KGRID ! Mesonh grid indicator
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PFIELDA ! values of the field on the A-grid
+INTEGER, INTENT(IN), OPTIONAL :: KLUOUT ! unit number of listing
+!
+!
+!* 0.2 Declaration of local variables
+! ------------------------------
+!
+INTEGER :: IIU,IJU,IKU ! End of arrays
+!-------------------------------------------------------------------------------
+!
+!* 1. GENERAL CASE
+! ------------
+IKU= SIZE(PFIELD,3)
+IIU= SIZE(PFIELD,1)
+IJU= SIZE(PFIELD,2)
+!
+SELECT CASE(KGRID)
+ CASE(1)
+ IF(PRESENT(KLUOUT)) THEN
+ WRITE(KLUOUT,*) ' CHANGE_A_GRID: case 1'
+ ELSE
+ PRINT*,' CHANGE_A_GRID: case 1'
+ ENDIF
+ PFIELDA(:,:,:) = PFIELD(:,:,:)
+ CASE(2)
+ IF(PRESENT(KLUOUT)) THEN
+ WRITE(KLUOUT,*) ' CHANGE_A_GRID: case 2'
+ ELSE
+ PRINT*,' CHANGE_A_GRID: case 2'
+ ENDIF
+ PFIELDA(:,:,:) = MXF(PFIELD(:,:,:))
+ PFIELDA(IIU,:,:)=2.*PFIELD(IIU,:,:)-PFIELD(IIU-1,:,:)
+ KGRID=1
+ CASE(3)
+ IF(PRESENT(KLUOUT)) THEN
+ WRITE(KLUOUT,*) ' CHANGE_A_GRID: case 3'
+ ELSE
+ PRINT*,' CHANGE_A_GRID: case 3'
+ ENDIF
+ PFIELDA(:,:,:) = MYF(PFIELD(:,:,:))
+ PFIELDA(:,IJU,:)=2*PFIELD(:,IJU,:)-PFIELD(:,IJU-1,:)
+ KGRID=1
+ CASE(4)
+ IF(PRESENT(KLUOUT)) THEN
+ WRITE(KLUOUT,*) ' CHANGE_A_GRID: case 4'
+ ELSE
+ PRINT*,' CHANGE_A_GRID: case 4'
+ ENDIF
+ PFIELDA(:,:,:) = MZF(PFIELD(:,:,:))
+ PFIELDA(:,:,IKU)=2*PFIELD(:,:,IKU)-PFIELD(:,:,IKU-1)
+ KGRID=1
+END SELECT
+!
+!-------------------------------------------------------------------------------
+!
+IF (NVERB>=10 .AND. PRESENT(KLUOUT)) &
+ WRITE(KLUOUT,*) 'routine CHANGE_A_GRID completed'
+!
+END SUBROUTINE CHANGE_A_GRID
diff --git a/LIBTOOLS/tools/diachro/src/TOOL/computedir.f90 b/LIBTOOLS/tools/diachro/src/TOOL/computedir.f90
new file mode 100644
index 0000000000000000000000000000000000000000..65a075465f1687bf37c59af6714aeee150176d1b
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/TOOL/computedir.f90
@@ -0,0 +1,197 @@
+! ######spl
+ MODULE MODI_COMPUTEDIR
+! #########################
+!
+INTERFACE
+!
+SUBROUTINE COMPUTEDIR(KITER,KJTER,KIUB1,KIUB2,KISKIP,PDIRU,PDIRV,PLO)
+!
+INTEGER :: KITER, KJTER, KIUB1, KIUB2, KISKIP
+REAL,DIMENSION(:,:) :: PDIRU, PDIRV
+REAL,DIMENSION(:,:),OPTIONAL ::PLO
+!
+END SUBROUTINE COMPUTEDIR
+!
+END INTERFACE
+!
+END MODULE MODI_COMPUTEDIR
+!
+! #################
+ SUBROUTINE COMPUTEDIR(KITER,KJTER,KIUB1,KIUB2,KISKIP,PDIRU,PDIRV,PLO)
+! #################
+!
+!!**** *COMPUTEDIR* -
+!!
+!!
+!! PURPOSE
+!! -------
+! Trace PH (tableaux 1D scalaires y compris MUMVM et DIRUMVM)
+! dans traceh_fordiachro
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/11/01
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODE_GRIDPROJ
+USE MODD_RESOLVCAR, ONLY: LCV, NVERBIA
+USE MODD_GRID, ONLY: XBETA, XRPK, XLON0
+USE MODD_COORD, ONLY: XDSX, XDSY
+USE MODD_GRID1, ONLY: XXHAT, XYHAT
+USE MODD_GRID, ONLY: XLATORI, XLONORI
+USE MODN_NCAR, ONLY: XSPVAL
+!
+IMPLICIT NONE
+!
+!
+COMMON/TEMH/XZZX,XZZY,NIIMAX,NIJMAX
+#include "big.h"
+INTEGER :: NIIMAX,NIJMAX
+REAL,DIMENSION(N2DVERTX) :: XZZX
+REAL,DIMENSION(400) :: XZZY
+!
+!
+!* 0.1 Dummy arguments
+!
+INTEGER :: KITER, KJTER, KIUB1, KIUB2, KISKIP
+REAL,DIMENSION(:,:) :: PDIRU, PDIRV
+REAL,DIMENSION(:,:),OPTIONAL ::PLO
+!
+!* 0.1 Local variables
+!
+!
+INTEGER :: JILOOP, JJLOOP
+!
+REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: ZX, ZYY,ZLAT,ZLON,ZLO
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZZY
+REAL :: ZRPK, ZBETA, ZLON0
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 1.
+! ----------------------------
+!
+if(nverbia > 0)then
+print *,' **entree computedir KIUB1,KIUB2,KITER,KJTER,KISKIP ',KIUB1,KIUB2,KITER,KJTER,KISKIP
+print *,' **entree computedir size(PDIRU) ',size(PDIRU,1),size(PDIRU,2)
+print *,' **entree computedir PDIRU PDIRV ',PDIRU,PDIRV
+endif
+!
+ALLOCATE(ZLO(KITER,KJTER))
+IF (PRESENT (PLO) ) THEN
+ if(nverbia > 0)then
+ print *,' **computedir : utilisation du lat lon passe en argument'
+ endif
+ ZLO=PLO
+ELSE
+ ! calcule ZLO en fonction de XXHAT et XYHAT
+!! Supprime en nov 2001 Appel routine COMPUTEDIR
+ ALLOCATE(ZX(KITER,1),ZZY(KJTER))
+ IF(LCV)THEN
+ ZX(:,1)=XDSX(1:KIUB1:KISKIP,1)
+ ELSE
+ ZX(:,1)=XZZX(1:KIUB1:KISKIP)
+ ZZY=XZZY(1:KIUB2:KISKIP)
+ ENDIF
+ ALLOCATE(ZYY(KITER,1),ZLAT(KITER,1),ZLON(KITER,1))
+ DO JJLOOP=1,KJTER
+ DO JILOOP=1,KITER
+ IF(LCV)THEN
+ ZYY(JILOOP,1)=XDSY(JILOOP,1)
+ ELSE
+ ZYY(JILOOP,1)=ZZY(JJLOOP)
+ ENDIF
+ ENDDO
+ CALL SM_LATLON_A(XLATORI,XLONORI,ZX,ZYY,ZLAT,ZLON)
+ ZLO(:,JJLOOP)=ZLON(:,1)
+ ENDDO
+!if(nverbia > 0)then
+!print *,' **computedir ZX,ZZY,ZYY ',ZX,ZZY,ZYY
+!endif
+ENDIF
+! fin de if (PRESENT (PLO) )
+!
+if(nverbia > 0)then
+print*,'** computedir LO ',KITER,KJTER,ZLO
+endif
+
+where(PDIRU /= xspval .AND. PDIRV /= xspval)
+ PDIRU=ATAN2(PDIRV,PDIRU)*180./ACOS(-1.)
+endwhere
+!if(nverbia > 0)then
+!print *,' **computedir PDIRU EN DEG. ',PDIRU
+!endif
+if(nverbia > 0)then
+ print *,' PDIRU 1,1 KITER/2,1 1,KJTER/2 KITER/2,KJTER/2 KITER,KJTER 22,29 '
+ print *,PDIRU(1,1), PDIRU(KITER/2,1), PDIRU(1,KJTER/2), PDIRU(KITER/2,KJTER/2), &
+ PDIRU(KITER,KJTER),PDIRU(22,29)
+endif
+!
+ZRPK=XRPK
+ZBETA=XBETA
+ZLON0=XLON0
+where(PDIRU /= xspval .AND. PDIRV /= xspval)
+ PDIRU=PDIRU - (ZRPK*(ZLO-ZLON0)-ZBETA) + 90.
+endwhere
+!
+!if(nverbia > 0)then
+!print *,' **computedir PDIRU suite ',PDIRU
+!print *,' **computedir ZRPK,ZBETA,ZLON0 ',ZRPK,ZBETA,ZLON0
+!endif
+!
+WHERE(PDIRU < 0.)PDIRU=PDIRU+360.
+WHERE(PDIRU > 360. .AND. PDIRU /= XSPVAL)PDIRU=PDIRU-360.
+if(nverbia > 0)then
+ print *,' PDIRU 1,1 KITER/2,1 1,KJTER/2 KITER/2,KJTER/2 KITER,KJTER '
+ print *,PDIRU(1,1), PDIRU(KITER/2,1), PDIRU(1,KJTER/2), PDIRU(KITER/2,KJTER/2), &
+ PDIRU(KITER,KJTER)
+endif
+!
+where(PDIRU /= xspval .AND. PDIRV /= xspval)
+ PDIRV=360.-PDIRU
+elsewhere
+ PDIRV=XSPVAL
+endwhere
+!if(nverbia > 0)then
+!print *,' **computedir PDIRV EN DEG. ',PDIRV
+!endif
+if(nverbia > 0)then
+ print *,' PDIRV 1,1 KITER/2,1 1,KJTER/2 KITER/2,KJTER/2 KITER,KJTER '
+ print *,PDIRV(1,1), PDIRV(KITER/2,1), PDIRV(1,KJTER/2), PDIRV(KITER/2,KJTER/2), &
+ PDIRV(KITER,KJTER)
+endif
+!! Supprime en nov 2001 Appel routine COMPUTEDIR
+IF (PRESENT (PLO) ) THEN
+ DEALLOCATE(ZLO)
+ELSE
+ DEALLOCATE(ZX,ZZY,ZYY,ZLAT,ZLON,ZLO)
+ENDIF
+!
+!------------------------------------------------------------------------------
+!
+!* 2. EXIT
+! ----
+RETURN
+!
+END SUBROUTINE COMPUTEDIR
diff --git a/LIBTOOLS/tools/diachro/src/TOOL/creatlink.f90 b/LIBTOOLS/tools/diachro/src/TOOL/creatlink.f90
new file mode 100644
index 0000000000000000000000000000000000000000..181e50ab4bc6d5279e28577ae1d412685bc1b318
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/TOOL/creatlink.f90
@@ -0,0 +1,194 @@
+! #################################
+ MODULE MODI_CREATLINK
+! #################################
+INTERFACE CREATLINK
+ SUBROUTINE CREATLINK (HVARDIR,HFILENAME,HFLAGCREAT,KVERB)
+!
+CHARACTER(LEN=*) , INTENT(in) :: HVARDIR
+CHARACTER(LEN=*) , INTENT(inout) :: HFILENAME ! FILENAME (1:28) sera reinit
+CHARACTER(LEN=*), INTENT(in) :: HFLAGCREAT
+INTEGER, INTENT(in) :: KVERB
+!
+END SUBROUTINE
+END INTERFACE
+END MODULE MODI_CREATLINK
+! ################
+ SUBROUTINE CREATLINK (HVARDIR,HFILENAME,HFLAGCREAT,KVERB)
+! ################
+!
+!!**** *CREATLINK* -
+!!
+!!
+!! PURPOSE
+!! -------
+! Si necessaire, cree un lien symbolique entre le fichier
+! VARDIR/FILENAME et le directory courant ./FILENAME
+! necessaire pour diachro qui ne traite que les fichiers presents
+! dans le directory courant
+!
+!!** METHOD
+!!
+! GETENV pour recuperer la valeur de la variable VARDIR qui
+! contient le nom du directory
+! fabrique les commandes UNIX "ln -s dir/file fileloc" avec fileloc=file(1:28)
+! rmlink fileloc dir/file"
+! execution de la premiere commande par CALL SYSTEM
+! execution de la seconde commande si HFLAGCREAT=CLEAN
+!! AUTHORS
+!! -------
+!! N. Asencio * CNRM*
+!!
+!! Copyright 2003, Meteo-France and Laboratoire d'Aerologie
+!! All Rights Reserved
+!!
+!! MODIFICATIONS
+!! -------------
+! N. Asencio sept. 2003 tronque le nom du fichier local à 28 car.
+! (limite max des routines FM)
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+#ifdef NAGf95
+USE F90_UNIX ! for FLUSH
+USE F90_UNIX_PROC ! for SYSTEM
+#endif
+!
+IMPLICIT NONE
+!
+!* 0.1 Arguments
+!
+CHARACTER(LEN=*) , INTENT(in) :: HVARDIR
+CHARACTER(LEN=*) , INTENT(inout) :: HFILENAME ! FILENAME (1:28) sera reinit
+CHARACTER(LEN=*), INTENT(in) :: HFLAGCREAT
+INTEGER, INTENT(in) :: KVERB
+!
+!* 0.2 Local variables
+!
+INTEGER :: II
+CHARACTER (LEN=28) :: yficloc
+CHARACTER(LEN=200) :: ydirloc
+CHARACTER(LEN=350) :: ycommandlfi
+! longueur commande = 'ln -s ' + dirloc +'/'+FILENAME + '.lfi .'
+CHARACTER(LEN=350) :: ycommand
+! stckage des commandes rm pour l appel avec clean
+CHARACTER(LEN=350), dimension (200) , SAVE :: ycleancommand=''
+INTEGER, SAVE :: icomptclean=0
+!
+!-------------------------------------------------------------------------------
+!
+! nom sous le directory local au plus de 28 caracteres
+! voir les limites des routines FM de Mesonh
+yficloc=ADJUSTL(HFILENAME)
+!
+!
+!* 1. CLEAN THE LINK
+! --------------
+!
+IF ( HFLAGCREAT(1:5) == 'CLEAN') THEN
+ !
+ IF ( HVARDIR == '' .AND. HFILENAME == '' ) THEN
+ ! supprime tous les liens
+ DO II=1,icomptclean
+ IF ( ycleancommand(II) /= '') then
+ print *,' execution de ',TRIM(ycleancommand(II))
+ CALL SYSTEM (ycleancommand(II))
+ END IF
+ END DO
+ ELSE
+ print *,' creatlink option supprime un seul lien ', &
+ TRIM(HVARDIR),' ',TRIM(HFILENAME)
+ ! supprime un seul lien
+ DO II=1,icomptclean
+ ! recherche du lien a supprimer, execution de la commande et reinit
+ ycommand=ycleancommand(II)
+ if ( ycommand(1:29) == 'rmlink ./'//TRIM(yficloc) ) then
+ print *,' execution de ',TRIM(ycleancommand(II))
+ CALL SYSTEM (ycleancommand(II))
+ ycleancommand(II)=''
+ else
+ IF (KVERB >= 5) THEN
+ print *,'ycommand(1:29)= ', ycommand(1:29)
+ print *,'rmlink ./'//TRIM(yficloc)
+ ENDIF
+ endif
+ END DO
+ !
+ ENDIF
+!
+!* 2. CREATE THE LINK
+! ---------------
+!
+ELSE
+!
+ icomptclean=icomptclean+1
+ !
+ ! recupere la valeur de la variable d environnement $VARDIR
+ ydirloc= ' '
+ CALL GETENV(HVARDIR,ydirloc)
+ print *,TRIM(HVARDIR),'=',TRIM(ydirloc)
+ !
+ IF (ydirloc(1:1) /= ' ' .AND. ydirloc(1:1) /= '.' ) THEN
+ ! fichier sous un directory different du directory courant
+ IF (HVARDIR == 'DIRLFI') THEN
+ ! ajoute .lfi au nom de fichier ( dans ce cas le nom verifie la
+ ! contrainte de 28 car. )
+ ! prepare la creation
+ ycommandlfi=ADJUSTR(HFILENAME)//'.lfi'
+ ycommand=ADJUSTR(ydirloc)//'/'//ADJUSTL(ycommandlfi)
+ ycommand=TRIM(ycommand)//' .'
+ ycommand='ln -s '//ADJUSTL(ycommand)
+ ! prepare le nettoyage
+ ycleancommand(icomptclean)='rmlink ./'//ADJUSTL(ycommandlfi)
+ ycleancommand(icomptclean)=TRIM(ycleancommand(icomptclean))//' '//ADJUSTL(ADJUSTR(ydirloc))
+ ycleancommand(icomptclean)=TRIM(ycleancommand(icomptclean))//'/'//ADJUSTL(ycommandlfi)
+ IF (KVERB >= 5) THEN
+ print *,'cleancommand=' ,TRIM(ycleancommand(icomptclean))
+ ENDIF
+ ELSE
+ ! prepare la creation en tronquant a 28 car. le nom local
+ ycommand=ADJUSTR(HFILENAME)//' '//ADJUSTL(yficloc)
+ ycommand=ADJUSTR(ydirloc)//'/'//ADJUSTL(ycommand)
+ ycommand='ln -s '//ADJUSTL(ycommand)
+ ! prepare le nettoyage
+ !ycleancommand(icomptclean)='rmlink ./'//ADJUSTL(ADJUSTR(yficloc))//&
+ ! ' '//ADJUSTL( TRIM(ydirloc)//'/'//ADJUSTL(ADJUSTR(HFILENAME)) )
+ ycleancommand(icomptclean)='rmlink ./'//ADJUSTL(ADJUSTR(yficloc))
+ ycommandlfi=TRIM(ydirloc)//'/'//ADJUSTL(ADJUSTR(HFILENAME))
+ ycleancommand(icomptclean)=TRIM(ycleancommand(icomptclean))//' '&
+ //ADJUSTL(ycommandlfi)
+ print *,'cleancommand=' ,TRIM(ycleancommand(icomptclean))
+ ENDIF
+ print *,' creation du lien :',TRIM(ycommand)
+ CALL SYSTEM(ycommand)
+ ELSE
+ ! fichier deja sous le directory courant:
+ !si longueur du nom est >28 car. creation du lien avec un nom tronque
+ !
+ IF ( LEN_TRIM(HFILENAME) > 28) THEN
+ ! prepare la creation en tronquant a 28 car. le nom local
+ ydirloc='.'
+ ycommand=ADJUSTR(HFILENAME)//' '//ADJUSTL(yficloc)
+ ycommand=ADJUSTR(ydirloc)//'/'//ADJUSTL(ycommand)
+ ycommand='ln -s '//ADJUSTL(ycommand)
+ ! prepare le nettoyage
+ ycleancommand(icomptclean)=TRIM(ydirloc)//'/'//ADJUSTL(ADJUSTR(HFILENAME))
+ ycleancommand(icomptclean)=ADJUSTR(yficloc)//' '//ADJUSTL(ycleancommand(icomptclean))
+ ycleancommand(icomptclean)='rmlink ./'//ADJUSTL(ycleancommand(icomptclean))
+ print *,' creation du lien :',TRIM(ycommand)
+ CALL SYSTEM(ycommand)
+ ELSE
+ print *,' pas de creation de lien pour ' ,TRIM(HFILENAME)
+ ENDIF
+
+ ENDIF
+ IF ( LEN_TRIM(HFILENAME) > 28) THEN
+ ! reinitialisation du nom passe en argument
+ HFILENAME=' '
+ HFILENAME(1:28)=yficloc
+ print *,' creatlink: reinit du nom du fichier: ', TRIM(HFILENAME)
+ ENDIF
+!
+ENDIF
+!
+END SUBROUTINE CREATLINK
diff --git a/LIBTOOLS/tools/diachro/src/TOOL/low2up.f90 b/LIBTOOLS/tools/diachro/src/TOOL/low2up.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ff05659b0883c8606a722b4f28faa10b1d2e9360
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/TOOL/low2up.f90
@@ -0,0 +1,81 @@
+! ######spl
+ MODULE MODI_LOW2UP
+! #####################
+!
+INTERFACE
+!
+SUBROUTINE LOW2UP(HCARIN)
+CHARACTER(LEN=*), INTENT(INOUT) :: HCARIN
+END SUBROUTINE LOW2UP
+!
+END INTERFACE
+!
+END MODULE MODI_LOW2UP
+! ######spl
+ SUBROUTINE LOW2UP(HCARIN)
+! ############################
+!
+!!**** *LOW2UP* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+CHARACTER(LEN=*), INTENT(INOUT) :: HCARIN
+!
+!* 0.1 Local variables
+! ---------------
+!
+CHARACTER(LEN=1),DIMENSION(26),SAVE :: YLO=(/'a','b','c','d','e','f','g', &
+ 'h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y','z'/)
+CHARACTER(LEN=1),DIMENSION(26),SAVE :: YUP=(/'A','B','C','D','E','F','G', &
+ 'H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/)
+INTEGER :: ILENC
+INTEGER :: J, JA
+!------------------------------------------------------------------------------
+!
+ILENC = LEN(HCARIN)
+!print *,' HCARIN ',LEN(HCARIN)
+!print *,HCARIN
+DO J=1,ILENC
+ DO JA=1,26
+ IF(HCARIN(J:J) == YLO(JA))HCARIN(J:J)=YUP(JA)
+ ENDDO
+ENDDO
+!
+END SUBROUTINE LOW2UP
diff --git a/LIBTOOLS/tools/diachro/src/TOOL/pinter.f90 b/LIBTOOLS/tools/diachro/src/TOOL/pinter.f90
new file mode 100644
index 0000000000000000000000000000000000000000..31ebe7e3a2402c566fd905f261c22365ed56686c
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/TOOL/pinter.f90
@@ -0,0 +1,160 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:./s.interp3d.f90, Version:1.1, Date:03/06/05, Last modified:01/10/10
+!-----------------------------------------------------------------
+! ######spl
+MODULE MODI_PINTER
+!#################################
+!
+INTERFACE
+ SUBROUTINE PINTER(PFIELD,KGRID,PSVAL,PPLEV,PFIELDAP,PPABSHO)
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PFIELD ! values of the field
+INTEGER, INTENT(IN) :: KGRID ! Mesonh grid indicator
+REAL, INTENT(IN) :: PSVAL ! value for missing data
+REAL, DIMENSION(:), INTENT(IN) :: PPLEV ! list of vertical levels(hPa)
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PFIELDAP ! values of the field on the pressure levels
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSHO ! abs. pressure when hor. interpolation
+END SUBROUTINE PINTER
+END INTERFACE
+END MODULE MODI_PINTER
+! ######spl
+ SUBROUTINE PINTER(PFIELD,KGRID,PSVAL,PPLEV,PFIELDAP,PPABSHO)
+! #####################
+!
+!!**** *PINTER* - interpole 3D fields on pressure levels
+!!
+!!
+!! PURPOSE
+!! -------
+!!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!! Functions MXF, MYF, MZF
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_FIELD1 : contains prognostics variables
+!! XPASBM
+!! Module MODD_GRID1
+!! XZZ
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!!
+!! V.Ducrocq Meteo-France
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 21/03/97
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+USE MODD_DIM1
+!
+USE MODI_SHUMAN ! interface modules
+!
+IMPLICIT NONE
+!
+!* 0.1 Declaration of arguments
+! ------------------------
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PFIELD ! values of the field
+INTEGER, INTENT(IN) :: KGRID ! Mesonh grid indicator
+REAL, INTENT(IN) :: PSVAL ! value for missing data
+REAL, DIMENSION(:), INTENT(IN) :: PPLEV ! list of vertical levels(hPa)
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PFIELDAP ! values of the field on the pressure levels
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PPABSHO ! abs. pressure (when hor. interpolation IGRID=0)
+!
+!* 0.2 Declaration of local variables
+! ------------------------------
+!
+INTEGER :: JKP,JKLOOP,JJLOOP,JILOOP,IJ,II ! loop indices
+INTEGER :: IIE,IJE,IPU ! End of usefull area
+INTEGER :: IIB,IJB,IKB ! Begining of usefull area
+REAL, DIMENSION(:,:,:),ALLOCATABLE :: ZPTH ! pressure for grid points corresponding to KGRID type
+REAL :: ZREF,ZXP,ZXM,ZDIXEPS ! pressure values and epsilon value
+!-------------------------------------------------------------------------------
+!
+!* 1.
+! ------------
+IPU=SIZE(PFIELDAP,3)
+IKB=1 +JPVEXT
+ZDIXEPS=10.*EPSILON(1.)
+!
+ALLOCATE(ZPTH(SIZE(PPABSHO,1),SIZE(PPABSHO,2),SIZE(PPABSHO,3)))
+IIB=JPHEXT+1
+IIE=NIMAX+JPHEXT
+IJB=JPHEXT+1
+IJE=NJMAX+JPHEXT
+SELECT CASE (KGRID)
+CASE(0)
+ ZPTH(:,:,:)=PPABSHO(:,:,:)
+ IIB=1
+ IIE=SIZE(PPABSHO,1)
+ IJB=1
+ IJE=SIZE(PPABSHO,2)
+CASE(1)
+ ZPTH=PPABSHO
+CASE(2)
+ ZPTH(:,:,:)=MXM(PPABSHO(:,:,:))
+ ZPTH(1,:,:)=2.*ZPTH(2,:,:) - ZPTH(3,:,:)
+CASE(3)
+ ZPTH(:,:,:)=MYM(PPABSHO(:,:,:))
+ ZPTH(:,1,:)=2.*ZPTH(:,2,:) - ZPTH(:,3,:)
+ CASE(4)
+ ZPTH(:,:,:)=MZM(PPABSHO(:,:,:))
+ ZPTH(:,:,1)=2.*ZPTH(:,:,2) - ZPTH(:,:,3)
+ END SELECT
+!
+!
+DO JKP= 1, IPU
+ ZREF=ALOG10(PPLEV(JKP)*100.)
+ DO JILOOP = IIB,IIE
+ DO JJLOOP = IJB,IJE
+ IJ=JJLOOP-IJB+1
+ II=JILOOP-IIB+1
+ PFIELDAP(II,IJ,JKP)=PSVAL
+ DO JKLOOP = 1,NKMAX+2*JPVEXT
+ IF (ZPTH(JILOOP,JJLOOP,JKLOOP)==PSVAL) CYCLE
+ ZXM=ALOG10(ZPTH(JILOOP,JJLOOP,JKLOOP))
+ ZXP=ALOG10(ZPTH(JILOOP,JJLOOP,MIN(NKMAX+2*JPVEXT,JKLOOP+1)))
+ IF ((ZXP-ZREF)*(ZREF-ZXM) .GE.0.) THEN
+ IF (JKLOOP+1 == IKB) THEN
+ CYCLE
+ ELSE
+ GO TO 4
+ ENDIF
+ ELSE IF (ZXP.GE.ZXM-ZDIXEPS.AND.ZXP.LE.ZXM+ZDIXEPS.AND. &
+ ZREF.GE.ZXM-ZDIXEPS.AND.ZREF.LE.ZXM+ZDIXEPS) THEN
+ IF(JKLOOP+1 == IKB)THEN
+ CYCLE
+ ELSE
+ GO TO 4
+ ENDIF
+ END IF
+ END DO
+ GO TO 3
+4 CONTINUE
+!
+! We interpolate
+ PFIELDAP(II,IJ,JKP)= (PFIELD(II,IJ,JKLOOP)* (ZXP-ZREF)+ &
+ PFIELD(II,IJ,MIN(NKMAX+2*JPVEXT,JKLOOP+1))* (ZREF-ZXM)) &
+ / MIN(-1.E-08,(ZXP-ZXM))
+ GO TO 3
+3 CONTINUE
+ END DO
+ END DO
+END DO
+!
+END SUBROUTINE PINTER
diff --git a/LIBTOOLS/tools/diachro/src/TOOL/poub.f90 b/LIBTOOLS/tools/diachro/src/TOOL/poub.f90
new file mode 100644
index 0000000000000000000000000000000000000000..548c4e7d76f115313de7cb3bb71893b40815f028
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/TOOL/poub.f90
@@ -0,0 +1,36 @@
+subroutine lockasgn
+print *,' *******lockasgn '
+return
+end
+subroutine lockrel
+print *,' *******lockrel '
+return
+end
+subroutine lockoff
+print *,' *******lockoff '
+return
+end
+subroutine lockon
+print *,' *******lockon '
+return
+end
+subroutine wheneq
+print *,' *******wheneq '
+return
+end
+subroutine remark2
+print *,' *******remark2'
+return
+end
+subroutine abort
+print *,' *******abort '
+return
+end
+subroutine lfirac
+print *,' *******lfirac '
+return
+end
+subroutine flush
+print *,' *******flush '
+return
+end
diff --git a/LIBTOOLS/tools/diachro/src/TOOL/up2low.f90 b/LIBTOOLS/tools/diachro/src/TOOL/up2low.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bff465dbb3dc12b52ae66f8b3f7658b63aad99f7
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/TOOL/up2low.f90
@@ -0,0 +1,81 @@
+! ######spl
+ MODULE MODI_UP2LOW
+! #####################
+!
+INTERFACE
+!
+SUBROUTINE UP2LOW(HCARIN)
+CHARACTER(LEN=*), INTENT(INOUT) :: HCARIN
+END SUBROUTINE UP2LOW
+!
+END INTERFACE
+!
+END MODULE MODI_UP2LOW
+! ######spl
+ SUBROUTINE UP2LOW(HCARIN)
+! ############################
+!
+!!**** *UP2LOW* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/06/94
+!! Updated PM 02/12/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+CHARACTER(LEN=*), INTENT(INOUT) :: HCARIN
+!
+!* 0.1 Local variables
+! ---------------
+!
+CHARACTER(LEN=1),DIMENSION(26),SAVE :: YLO=(/'a','b','c','d','e','f','g', &
+ 'h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y','z'/)
+CHARACTER(LEN=1),DIMENSION(26),SAVE :: YUP=(/'A','B','C','D','E','F','G', &
+ 'H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/)
+INTEGER :: ILENC
+INTEGER :: J, JA
+!------------------------------------------------------------------------------
+!
+ILENC = LEN(HCARIN)
+!print *,' HCARIN ',LEN(HCARIN)
+!print *,HCARIN
+DO J=1,ILENC
+ DO JA=1,26
+ IF(HCARIN(J:J) == YUP(JA))HCARIN(J:J)=YLO(JA)
+ ENDDO
+ENDDO
+!
+END SUBROUTINE UP2LOW
diff --git a/LIBTOOLS/tools/diachro/src/TOOL/verif_group.f90 b/LIBTOOLS/tools/diachro/src/TOOL/verif_group.f90
new file mode 100644
index 0000000000000000000000000000000000000000..37cc8e8481d1a2af8a32c255c9d3281c694fb239
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/TOOL/verif_group.f90
@@ -0,0 +1,714 @@
+! ######spl
+ MODULE MODI_VERIF_GROUP
+! #######################
+!
+INTERFACE
+!
+SUBROUTINE VERIF_GROUP(HFILEDIA,HLUOUTDIA,HGROUP)
+CHARACTER(LEN=*) :: HFILEDIA, HLUOUTDIA, HGROUP
+END SUBROUTINE VERIF_GROUP
+!
+END INTERFACE
+END MODULE MODI_VERIF_GROUP
+! ######spl
+ SUBROUTINE VERIF_GROUP(HFILEDIA,HLUOUTDIA,HGROUP)
+! #################################################
+!
+!!**** *VERIF_GROUP* -
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!!
+!! N.A.
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/01/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_DIACHRO
+USE MODD_TYPE_AND_LH
+USE MODD_RESOLVCAR
+USE MODD_SEVERAL_RECORDS
+USE MODN_NCAR
+USE MODD_ALLOC_FORDIACHRO
+USE MODI_REALLOC_AND_LOAD_RECORDS
+USE MODI_FMREAD
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HFILEDIA, HLUOUTDIA,HGROUP
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+CHARACTER(LEN=16) :: YRECFM
+CHARACTER(LEN=8) :: YNAM1, YNAM2, YNAM1M, YNAM2M
+! Aout 99 Longueur YCOMMENT passee de 20 a 100
+CHARACTER(LEN=100) :: YCOMMENT
+CHARACTER*1 :: Y1
+CHARACTER*2 :: Y2
+CHARACTER*3 :: Y3
+CHARACTER*4 :: Y4
+CHARACTER(LEN=16),DIMENSION(:),ALLOCATABLE:: YGROUP
+INTEGER :: ILENG, ILENCH, IGRID, J, JJ, JM, ILENDIM
+INTEGER :: JM1, JM2, INCR1, INCR2
+INTEGER :: IRESPDIA
+INTEGER :: IMINUS, ILENGP, INBC2, INBC1
+INTEGER,SAVE :: IGROUP=0
+INTEGER,DIMENSION(:),ALLOCATABLE :: ITABCHAR
+LOGICAL :: GPART
+!------------------------------------------------------------------------------
+!
+
+GPART=.FALSE.
+NBCNUM=0
+NINCRNAM=1
+CGPNAM(1:LEN(CGPNAM))=' '
+CGPNAM1(1:LEN(CGPNAM1))=' '
+CGPNAM2(1:LEN(CGPNAM2))=' '
+YNAM1(1:LEN(YNAM1))=' '
+YNAM2(1:LEN(YNAM2))=' '
+YNAM1M(1:LEN(YNAM1M))=' '
+YNAM2M(1:LEN(YNAM2M))=' '
+print *,' VERIF_GROUP HGROUP ',HGROUP
+
+ILENDIM=1
+YRECFM='MENU_BUDGET.DIM'
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENDIM,ILENG,&
+IGRID,ILENCH,YCOMMENT,IRESPDIA)
+
+IF(ALLOCATED(ITABCHAR))DEALLOCATE(ITABCHAR)
+ALLOCATE(ITABCHAR(ILENG))
+YRECFM='MENU_BUDGET'
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+IGRID,ILENCH,YCOMMENT,IRESPDIA)
+IGROUP=ILENG/16
+IF(ALLOCATED(YGROUP))DEALLOCATE(YGROUP)
+ALLOCATE(YGROUP(IGROUP))
+print *,' ILENG ILENCH IGROUP ',ILENG,ILENCH,IGROUP
+
+DO JJ=1,IGROUP
+ DO J = 1,16
+ YGROUP(JJ)(J:J)=CHAR(ITABCHAR(16*(JJ-1)+J))
+ ENDDO
+ENDDO
+DEALLOCATE(ITABCHAR)
+YRECFM=ADJUSTL(ADJUSTR(HGROUP)//'.TYPE')
+ILENG=LEN(CTYPE)
+ALLOCATE(ITABCHAR(ILENG))
+CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+IGRID,ILENCH,YCOMMENT,IRESPDIA)
+!******************************************************************************
+
+IF(IRESPDIA == 0)THEN
+!************* A DEFINIR **********************
+ LGROUP=.TRUE.
+ RETURN
+!******************************************************************************
+
+ELSE IF(IRESPDIA == -47)THEN
+
+ LGROUP=.FALSE.
+
+! On decortique HGROUP
+
+ ILENGP=LEN_TRIM(HGROUP)
+
+!---------------------------------------------------
+ IF(HGROUP(1:ILENGP) == 'PABSM' .OR. HGROUP(1:ILENGP) == 'PABST' .OR. &
+ HGROUP(1:ILENGP) == 'THM' .OR. HGROUP(1:ILENGP) == 'THT' .OR. &
+ HGROUP(1:ILENGP) == 'POVOM' .OR. HGROUP(1:ILENGP) == 'POVOT' .OR. &
+ HGROUP(1:ILENGP) == 'SVM3' .OR. HGROUP(1:ILENGP) == 'SVM003' .OR. &
+ HGROUP(1:ILENGP) == 'SVT3' .OR. HGROUP(1:ILENGP) == 'SVT003' .OR. &
+ HGROUP(1:ILENGP) == 'LGZM' .OR. HGROUP(1:ILENGP) == 'LGZT' )THEN
+! print *,' VERIF_GROUP PAS OK 1',HGROUP
+ LPBREAD=.TRUE.
+ RETURN
+ ENDIF
+!---------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ IF(ILENGP > 1)THEN
+ IF(ILENGP <= 4 ) THEN
+ IF( HGROUP(ILENGP:ILENGP) == '0' .OR. HGROUP(ILENGP:ILENGP) == '1' .OR. &
+ HGROUP(ILENGP:ILENGP) == '2' .OR. HGROUP(ILENGP:ILENGP) == '4' .OR. &
+ HGROUP(ILENGP:ILENGP) == '5' .OR. HGROUP(ILENGP:ILENGP) == '6' .OR. &
+ HGROUP(ILENGP:ILENGP) == '7' .OR. HGROUP(ILENGP:ILENGP) == '8' .OR. &
+ HGROUP(ILENGP:ILENGP) == '9') THEN
+ IF (HGROUP(1:2) == 'UM' .OR. HGROUP(1:2) == 'VM' .OR.&
+ HGROUP(1:2) == 'WM' .OR. HGROUP(1:2) == 'UT' .OR.&
+ HGROUP(1:2) == 'VT' .OR. HGROUP(1:2) == 'WT') THEN
+ LPBREAD=.TRUE.
+ ! print *,' VERIF_GROUP PAS OK 2',HGROUP
+ RETURN
+ ENDIF
+ ENDIF
+ ENDIF
+ ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Recherche d'un signe - a partir de la fin
+
+ DO J=0,4
+ IMINUS=INDEX(HGROUP(MAX(ILENGP-J,1):ILENGP),'-')
+ IF(IMINUS /= 0)THEN
+ JM=J
+ EXIT
+ ENDIF
+ ENDDO
+
+! Presence d'un signe moins
+
+ IF(IMINUS /= 0)THEN
+
+! Cas expression groupe sous la forme AA__0001-0099 (Donc LFIC1=.TRUE.) ou
+! sous la forme AA_b-c-
+
+ IMINUS=ILENGP-JM+IMINUS-1
+
+ IF(IMINUS == ILENGP)THEN !00000000000000000000000000000000000000
+! Pas d'intervalle mais presence d'un ou plusieurs signes -
+
+ GPART=.TRUE.
+
+ ELSE !0000000000000000000000000000000000000
+
+! Intervalle poossible
+
+ JM1=0; JM2=0; INCR1=0; INCR2=0
+ J=IMINUS-1 ; JJ=IMINUS+1
+ IF((HGROUP(J:J) == '0' .OR. HGROUP(J:J) == '1' .OR. HGROUP(J:J) == '2' &
+ .OR. HGROUP(J:J) == '3' .OR. HGROUP(J:J) == '4' .OR. HGROUP(J:J) == '5' &
+ .OR. HGROUP(J:J) == '6' .OR. HGROUP(J:J) == '7' .OR. HGROUP(J:J) == '8' &
+ .OR. HGROUP(J:J) == '9') .AND. &
+ (HGROUP(JJ:JJ) == '0' .OR. HGROUP(JJ:JJ) =='1' .OR. HGROUP(JJ:JJ) == '2' &
+ .OR. HGROUP(JJ:JJ)=='3' .OR. HGROUP(JJ:JJ)=='4' .OR. HGROUP(JJ:JJ) == '5' &
+ .OR. HGROUP(JJ:JJ)=='6' .OR. HGROUP(JJ:JJ)=='7' .OR. HGROUP(JJ:JJ) == '8' &
+ .OR. HGROUP(JJ:JJ) == '9'))THEN
+
+ INBC2=ILENGP-IMINUS
+ READ(HGROUP(IMINUS+1:ILENGP),*)NAM2
+ JM=0
+ DO J=2,IMINUS-1
+ IF(HGROUP(J:J) == '0' .OR. HGROUP(J:J) == '1' .OR. HGROUP(J:J) == '2' &
+ .OR. HGROUP(J:J) == '3' .OR. HGROUP(J:J) == '4' .OR. HGROUP(J:J) == '5' &
+ .OR. HGROUP(J:J) == '6' .OR. HGROUP(J:J) == '7' .OR. HGROUP(J:J) == '8' &
+ .OR. HGROUP(J:J) == '9')THEN
+ JM=J
+ EXIT
+ ENDIF
+ ENDDO
+
+ INBC1=IMINUS-JM
+! On memorise les infos pour realloc_several_records
+ READ(HGROUP(JM:IMINUS-1),*)NAM1
+ IF(INBC1-INBC2 == 0)NBCNUM=INBC1
+ CGPNAM=HGROUP(1:JM-1)
+ CGPNAM=ADJUSTL(CGPNAM)
+ CGPNAM1=HGROUP(1:IMINUS-1)
+ CGPNAM1=ADJUSTL(CGPNAM1)
+ CGPNAM2=ADJUSTL(ADJUSTR(CGPNAM)//HGROUP(IMINUS+1:ILENGP))
+ IF(LTYPE)RETURN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,CGPNAM1)
+ IF(LPBREAD)THEN
+ print *,' VRAISEMBLABLEMENT PB AVEC LE NOM DU GROUPE : ', &
+ HGROUP(1:ILENGP)
+ RETURN
+ ENDIF
+
+ DO J=NAM1,NAM2
+
+ SELECT CASE(NBCNUM)
+ CASE(:1)
+ IF(J < 10)THEN
+ WRITE(Y1,'(I1)')J
+ YNAM1=ADJUSTL(ADJUSTR(CGPNAM)//Y1)
+ ELSE IF(J < 100)THEN
+ WRITE(Y2,'(I2)')J
+ YNAM1=ADJUSTL(ADJUSTR(CGPNAM)//Y2)
+ ELSE IF(J < 1000)THEN
+ WRITE(Y3,'(I3)')J
+ YNAM1=ADJUSTL(ADJUSTR(CGPNAM)//Y3)
+ ELSE
+ WRITE(Y4,'(I4)')J
+ YNAM1=ADJUSTL(ADJUSTR(CGPNAM)//Y4)
+ ENDIF
+ CASE(2)
+ WRITE(Y2,'(I2.2)')J
+ YNAM1=ADJUSTL(ADJUSTR(CGPNAM)//Y2)
+ CASE(3)
+ WRITE(Y3,'(I3.3)')J
+ YNAM1=ADJUSTL(ADJUSTR(CGPNAM)//Y3)
+ CASE(4)
+ WRITE(Y4,'(I4.4)')J
+ YNAM1=ADJUSTL(ADJUSTR(CGPNAM)//Y4)
+ END SELECT
+
+ YRECFM=ADJUSTL(ADJUSTR(YNAM1)//'.TYPE')
+ YNAM1=ADJUSTL(YNAM1)
+ ILENG=LEN(CTYPE)
+ DEALLOCATE(ITABCHAR)
+ ALLOCATE(ITABCHAR(ILENG))
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IF(IRESPDIA == 0)THEN
+ IF(JM1 == 0)THEN
+ JM1=J
+ ELSE
+ INCR1=J-JM1
+ EXIT
+ ENDIF
+ ENDIF
+
+ ENDDO
+
+ DO J=NAM2,NAM1,-1
+
+ SELECT CASE(NBCNUM)
+ CASE(:1)
+ IF(J < 10)THEN
+ WRITE(Y1,'(I1)')J
+ YNAM2=ADJUSTL(ADJUSTR(CGPNAM)//Y1)
+ ELSE IF(J < 100)THEN
+ WRITE(Y2,'(I2)')J
+ YNAM2=ADJUSTL(ADJUSTR(CGPNAM)//Y2)
+ ELSE IF(J < 1000)THEN
+ WRITE(Y3,'(I3)')J
+ YNAM2=ADJUSTL(ADJUSTR(CGPNAM)//Y3)
+ ELSE
+ WRITE(Y4,'(I4)')J
+ YNAM2=ADJUSTL(ADJUSTR(CGPNAM)//Y4)
+ ENDIF
+ CASE(2)
+ WRITE(Y2,'(I2.2)')J
+ YNAM2=ADJUSTL(ADJUSTR(CGPNAM)//Y2)
+ CASE(3)
+ WRITE(Y3,'(I3.3)')J
+ YNAM2=ADJUSTL(ADJUSTR(CGPNAM)//Y3)
+ CASE(4)
+ WRITE(Y4,'(I4.4)')J
+ YNAM2=ADJUSTL(ADJUSTR(CGPNAM)//Y4)
+ END SELECT
+
+ YRECFM=ADJUSTL(ADJUSTR(YNAM2)//'.TYPE')
+ YNAM2=ADJUSTL(YNAM2)
+ ILENG=LEN(CTYPE)
+ DEALLOCATE(ITABCHAR)
+ ALLOCATE(ITABCHAR(ILENG))
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IF(IRESPDIA == 0)THEN
+ IF(JM2 == 0)THEN
+ JM2=J
+ ELSE
+ INCR2=JM2-J
+ EXIT
+ ENDIF
+ ENDIF
+
+ ENDDO
+
+ IF(INCR1 /= 0 .AND. INCR1 == INCR2)THEN
+ NINCRNAM=INCR1
+ ELSE IF(INCR1 /= 0 .AND. INCR1 /= INCR2)THEN
+ LPBREAD=.TRUE.
+ print *,' Increment Numero Nom Groupe non constant : CAS NON PREVU '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+
+ CALL REALLOC_AND_LOAD_RECORDS(HFILEDIA,HLUOUTDIA)
+ RETURN
+
+ ELSE
+
+ GPART=.TRUE.
+
+ ENDIF
+
+ ENDIF !0000000000000000000000000000000000000
+
+ ELSE
+! Cas expression groupe sous la forme AA__ (Donc LFIC1=.TRUE. ou .FALSE.)
+
+ GPART=.TRUE.
+ ENDIF
+
+ IF(GPART)THEN
+! On essaie de rajouter 1, puis 2 puis 3 chiffres
+ JM1=0; JM2=0; INCR1=0; INCR2=0
+ DO J=1,9999
+ IF(J <10)THEN
+ WRITE(Y1,'(I1)')J
+ YNAM1=ADJUSTL(ADJUSTR(HGROUP)//Y1)
+ ELSE IF(J <=99)THEN
+ WRITE(Y2,'(I2)')J
+ YNAM1=ADJUSTL(ADJUSTR(HGROUP)//Y2)
+ ELSE IF(J <= 999)THEN
+ WRITE(Y3,'(I3)')J
+ YNAM1=ADJUSTL(ADJUSTR(HGROUP)//Y3)
+ ELSE
+ WRITE(Y4,'(I4)')J
+ YNAM1=ADJUSTL(ADJUSTR(HGROUP)//Y4)
+ ENDIF
+ YRECFM=ADJUSTL(ADJUSTR(YNAM1)//'.TYPE')
+ YNAM1=ADJUSTL(YNAM1)
+ ILENG=LEN(CTYPE)
+ DEALLOCATE(ITABCHAR)
+ ALLOCATE(ITABCHAR(ILENG))
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IF(IRESPDIA == 0)THEN
+ IF(JM1 == 0)THEN
+ JM1=J
+ YNAM1M=YNAM1
+ ELSE
+ INCR1=J-JM1
+ YNAM1=YNAM1M
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+ IF(JM1 /= 0)THEN !+++++++++++++++++++++++++++++++++++++
+ DO J=9999,1,-1
+ IF(J <10)THEN
+ WRITE(Y1,'(I1)')J
+ YNAM2=ADJUSTL(ADJUSTR(HGROUP)//Y1)
+ ELSE IF(J <=99)THEN
+ WRITE(Y2,'(I2)')J
+ YNAM2=ADJUSTL(ADJUSTR(HGROUP)//Y2)
+ ELSE IF(J <= 999)THEN
+ WRITE(Y3,'(I3)')J
+ YNAM2=ADJUSTL(ADJUSTR(HGROUP)//Y3)
+ ELSE
+ WRITE(Y4,'(I4)')J
+ YNAM2=ADJUSTL(ADJUSTR(HGROUP)//Y4)
+ ENDIF
+ YRECFM=ADJUSTL(ADJUSTR(YNAM2)//'.TYPE')
+ YNAM2=ADJUSTL(YNAM2)
+ ILENG=LEN(CTYPE)
+ DEALLOCATE(ITABCHAR)
+ ALLOCATE(ITABCHAR(ILENG))
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IF(IRESPDIA == 0)THEN
+ IF(JM2 == 0)THEN
+ JM2=J
+ YNAM2M=YNAM2
+ ELSE
+ INCR2=JM2-J
+ YNAM2=YNAM2M
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF !+++++++++++++++++++++++++++++++++++++
+
+ IF(INCR1 /= 0 .AND. INCR1 == INCR2)THEN
+ NINCRNAM=INCR1
+ ELSE IF(INCR1 /= 0 .AND. INCR1 /= INCR2)THEN
+ LPBREAD=.TRUE.
+ print *,' Increment Numero Nom Groupe non constant : CAS NON PREVU '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+
+ IF(JM1 /= 0 .AND. JM2 /=0)THEN
+! On memorise les infos pour realloc_several_records
+ CGPNAM=HGROUP(1:LEN_TRIM(HGROUP))
+ CGPNAM=ADJUSTL(CGPNAM)
+ CGPNAM1=YNAM1
+ CGPNAM1=ADJUSTL(CGPNAM1)
+ CGPNAM2=YNAM2
+ NAM1=JM1; NAM2=JM2
+ IF(LTYPE)RETURN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,CGPNAM1)
+ CALL REALLOC_AND_LOAD_RECORDS(HFILEDIA,HLUOUTDIA)
+ RETURN
+
+ ELSE
+
+! On essaie de rajouter une zone numerique sur 4 positions
+ JM1=0; JM2=0; INCR1=0; INCR2=0
+ DO J=1,9999
+ WRITE(Y4,'(I4.4)')J
+ YNAM1=ADJUSTL(ADJUSTR(HGROUP)//Y4)
+ YRECFM=ADJUSTL(ADJUSTR(YNAM1)//'.TYPE')
+ YNAM1=ADJUSTL(YNAM1)
+ ILENG=LEN(CTYPE)
+ DEALLOCATE(ITABCHAR)
+ ALLOCATE(ITABCHAR(ILENG))
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IF(IRESPDIA == 0)THEN
+ IF(JM1 == 0)THEN
+ JM1=J
+ YNAM1M=YNAM1
+ ELSE
+ INCR1=J-JM1
+ YNAM1=YNAM1M
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+ IF(JM1 /= 0)THEN !+++++++++++++++++++++++++++++++++++++
+ DO J=9999,1,-1
+ WRITE(Y4,'(I4.4)')J
+ YNAM2=ADJUSTL(ADJUSTR(HGROUP)//Y4)
+ YRECFM=ADJUSTL(ADJUSTR(YNAM2)//'.TYPE')
+ YNAM2=ADJUSTL(YNAM2)
+ ILENG=LEN(CTYPE)
+ DEALLOCATE(ITABCHAR)
+ ALLOCATE(ITABCHAR(ILENG))
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IF(IRESPDIA == 0)THEN
+ IF(JM2 == 0)THEN
+ JM2=J
+ YNAM2M=YNAM2
+ ELSE
+ INCR2=JM2-J
+ YNAM2=YNAM2M
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF(INCR1 /= 0 .AND. INCR1 == INCR2)THEN
+ NINCRNAM=INCR1
+ ELSE IF(INCR1 /= 0 .AND. INCR1 /= INCR2)THEN
+ LPBREAD=.TRUE.
+ print *,' Increment Numero Nom Groupe non constant : CAS NON PREVU '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+
+ IF(JM1 /= 0 .AND. JM2 /=0)THEN
+! On memorise les infos pour realloc_several_records
+ CGPNAM=HGROUP(1:LEN_TRIM(HGROUP))
+ CGPNAM=ADJUSTL(CGPNAM)
+ CGPNAM1=YNAM1
+ CGPNAM1=ADJUSTL(CGPNAM1)
+ CGPNAM2=YNAM2
+! print *,' 4 positions CGPNAM,CGPNAM1,CGPNAM2 ',CGPNAM,CGPNAM1,CGPNAM2
+ NAM1=JM1; NAM2=JM2
+ NBCNUM=4
+ IF(LTYPE)RETURN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,CGPNAM1)
+ CALL REALLOC_AND_LOAD_RECORDS(HFILEDIA,HLUOUTDIA)
+ RETURN
+
+ ELSE
+
+! On essaie de rajouter une zone numerique sur 3 positions
+ JM1=0; JM2=0; INCR1=0; INCR2=0
+ DO J=1,999
+ WRITE(Y3,'(I3.3)')J
+ YNAM1=ADJUSTL(ADJUSTR(HGROUP)//Y3)
+ YRECFM=ADJUSTL(ADJUSTR(YNAM1)//'.TYPE')
+ YNAM1=ADJUSTL(YNAM1)
+ ILENG=LEN(CTYPE)
+ DEALLOCATE(ITABCHAR)
+ ALLOCATE(ITABCHAR(ILENG))
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IF(IRESPDIA == 0)THEN
+ IF(JM1 == 0)THEN
+ JM1=J
+ YNAM1M=YNAM1
+ ELSE
+ INCR1=J-JM1
+ YNAM1=YNAM1M
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+ IF(JM1 /= 0)THEN !+++++++++++++++++++++++++++++++++++++
+ DO J=999,1,-1
+ WRITE(Y3,'(I3.3)')J
+ YNAM2=ADJUSTL(ADJUSTR(HGROUP)//Y3)
+ YRECFM=ADJUSTL(ADJUSTR(YNAM2)//'.TYPE')
+ YNAM2=ADJUSTL(YNAM2)
+ ILENG=LEN(CTYPE)
+ DEALLOCATE(ITABCHAR)
+ ALLOCATE(ITABCHAR(ILENG))
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IF(IRESPDIA == 0)THEN
+ IF(JM2 == 0)THEN
+ JM2=J
+ YNAM2M=YNAM2
+ ELSE
+ INCR2=JM2-J
+ YNAM2=YNAM2M
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF(INCR1 /= 0 .AND. INCR1 == INCR2)THEN
+ NINCRNAM=INCR1
+ ELSE IF(INCR1 /= 0 .AND. INCR1 /= INCR2)THEN
+ LPBREAD=.TRUE.
+ print *,' Increment Numero Nom Groupe non constant : CAS NON PREVU '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+
+ IF(JM1 /= 0 .AND. JM2 /=0)THEN
+! On memorise les infos pour realloc_several_records
+ CGPNAM=HGROUP(1:LEN_TRIM(HGROUP))
+ CGPNAM=ADJUSTL(CGPNAM)
+ CGPNAM1=YNAM1
+ CGPNAM1=ADJUSTL(CGPNAM1)
+ CGPNAM2=YNAM2
+ NAM1=JM1; NAM2=JM2
+ NBCNUM=3
+! print *,' 3 positions CGPNAM,CGPNAM1,CGPNAM2 ',CGPNAM,CGPNAM1,CGPNAM2
+ IF(LTYPE)RETURN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,CGPNAM1)
+ CALL REALLOC_AND_LOAD_RECORDS(HFILEDIA,HLUOUTDIA)
+ RETURN
+
+ ELSE
+
+! On essaie de rajouter une zone numerique sur 2 positions
+ JM1=0; JM2=0; INCR1=0; INCR2=0
+ DO J=1,99
+ WRITE(Y2,'(I2.2)')J
+ YNAM1=ADJUSTL(ADJUSTR(HGROUP)//Y2)
+ YRECFM=ADJUSTL(ADJUSTR(YNAM1)//'.TYPE')
+ YNAM1=ADJUSTL(YNAM1)
+ ILENG=LEN(CTYPE)
+ DEALLOCATE(ITABCHAR)
+ ALLOCATE(ITABCHAR(ILENG))
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IF(IRESPDIA == 0)THEN
+ IF(JM1 == 0)THEN
+ JM1=J
+ YNAM1M=YNAM1
+ ELSE
+ INCR1=J-JM1
+ YNAM1=YNAM1M
+ EXIT
+ ENDIF
+ ENDIF
+ ENDDO
+ IF(JM1 /= 0)THEN !+++++++++++++++++++++++++++++++++++++
+ DO J=99,1,-1
+ WRITE(Y2,'(I2.2)')J
+ YNAM2=ADJUSTL(ADJUSTR(HGROUP)//Y2)
+ YRECFM=ADJUSTL(ADJUSTR(YNAM2)//'.TYPE')
+ YNAM2=ADJUSTL(YNAM2)
+ ILENG=LEN(CTYPE)
+ DEALLOCATE(ITABCHAR)
+ ALLOCATE(ITABCHAR(ILENG))
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IF(IRESPDIA == 0)THEN
+ JM2=J
+ EXIT
+ ENDIF
+ ENDDO
+ ENDIF
+
+ IF(INCR1 /= 0 .AND. INCR1 == INCR2)THEN
+ NINCRNAM=INCR1
+ ELSE IF(INCR1 /= 0 .AND. INCR1 /= INCR2)THEN
+ LPBREAD=.TRUE.
+ print *,' Increment Numero Nom Groupe non constant : CAS NON PREVU '
+ IF(ALLOCATED(XVAR))THEN
+ CALL ALLOC_FORDIACHRO(1,1,1,1,1,1,3)
+ ENDIF
+ RETURN
+ ENDIF
+
+ IF(JM1 /= 0 .AND. JM2 /=0)THEN
+! On memorise les infos pour realloc_several_records
+ CGPNAM=HGROUP(1:LEN_TRIM(HGROUP))
+ CGPNAM=ADJUSTL(CGPNAM)
+ CGPNAM1=YNAM1
+ CGPNAM1=ADJUSTL(CGPNAM1)
+ CGPNAM2=YNAM2
+ NAM1=JM1; NAM2=JM2
+ NBCNUM=2
+! print *,' 2 positions CGPNAM,CGPNAM1,CGPNAM2 ',CGPNAM,CGPNAM1,CGPNAM2
+ IF(LTYPE)RETURN
+ CALL READ_DIACHRO(HFILEDIA,HLUOUTDIA,CGPNAM1)
+ CALL REALLOC_AND_LOAD_RECORDS(HFILEDIA,HLUOUTDIA)
+ RETURN
+
+ ELSE
+
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+
+ ENDIF
+
+! ELSE
+
+ ENDIF
+
+ LPBREAD=.TRUE.
+!************ Le tester dans le pg appelant **************
+ IF(INDEX(HGROUP(1:ILENGP),'NPROFILE') /= 0)THEN
+ RETURN
+ ELSE
+ print *,' PB AVEC LE NOM DU GROUPE ou DU PARAMETRE : ',HGROUP(1:ILENGP)
+ print *,' VERIFIEZ ET RENTREZ A NOUVEAU VOTRE DIRECTIVE '
+ RETURN
+ ENDIF
+
+
+ENDIF
+
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE VERIF_GROUP
diff --git a/LIBTOOLS/tools/diachro/src/TOOL/writedir.f90 b/LIBTOOLS/tools/diachro/src/TOOL/writedir.f90
new file mode 100644
index 0000000000000000000000000000000000000000..34487fc7dd12a41fc10bf0f19a5bd70724aceb7b
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/TOOL/writedir.f90
@@ -0,0 +1,114 @@
+!###########################
+MODULE MODI_WRITEDIR
+!###########################
+!
+INTERFACE WRITEDIR
+!
+SUBROUTINE WRITEDIRX(KLU,PVAL)
+INTEGER, INTENT(IN) :: KLU
+REAL, INTENT(IN) :: PVAL
+END SUBROUTINE WRITEDIRX
+!
+SUBROUTINE WRITEDIRN(KLU,KVAL)
+INTEGER, INTENT(IN) :: KLU
+INTEGER, INTENT(IN) :: KVAL
+END SUBROUTINE WRITEDIRN
+!
+SUBROUTINE WRITEDIRAN(KLU,KVAL)
+INTEGER, INTENT(IN) :: KLU
+INTEGER,DIMENSION(:), INTENT(IN) :: KVAL
+END SUBROUTINE WRITEDIRAN
+!
+SUBROUTINE WRITEDIRC(KLU,HVAL)
+INTEGER, INTENT(IN) :: KLU
+CHARACTER(LEN=*), INTENT(IN) :: HVAL
+END SUBROUTINE WRITEDIRC
+!
+END INTERFACE
+END MODULE MODI_WRITEDIR
+!
+! ###########################
+ SUBROUTINE WRITEDIRX(KLU,PVAL)
+! ###########################
+!
+IMPLICIT NONE
+INTEGER, INTENT(IN) :: KLU
+REAL, INTENT(IN) :: PVAL
+!
+CHARACTER(LEN=80) :: YCAR80 ! String for directive written
+CHARACTER(LEN=7) :: YFORMOUT ! String for format of directive written
+!
+YCAR80(1:LEN(YCAR80))=' '
+WRITE(YCAR80,*)PVAL
+YCAR80=ADJUSTL(YCAR80)
+YFORMOUT='(A )'
+WRITE(YFORMOUT(3:4),'(I2.2)') MAX(LEN_TRIM(YCAR80),3)
+WRITE(UNIT=KLU,FMT=YFORMOUT)YCAR80(1:LEN_TRIM(YCAR80))
+END SUBROUTINE WRITEDIRX
+!
+! ###########################
+ SUBROUTINE WRITEDIRN(KLU,KVAL)
+! ###########################
+!
+IMPLICIT NONE
+INTEGER, INTENT(IN) :: KLU
+INTEGER, INTENT(IN) :: KVAL
+!
+CHARACTER(LEN=80) :: YCAR80 ! String for directive written
+CHARACTER(LEN=7) :: YFORMOUT ! String for format of directive written
+!
+YCAR80(1:LEN(YCAR80))=' '
+WRITE(YCAR80,*)KVAL
+YCAR80=ADJUSTL(YCAR80)
+YFORMOUT='(A )'
+WRITE(YFORMOUT(3:4),'(I2.2)') MAX(LEN_TRIM(YCAR80),3)
+WRITE(UNIT=KLU,FMT=YFORMOUT)YCAR80(1:LEN_TRIM(YCAR80))
+!
+END SUBROUTINE WRITEDIRN
+!
+! ###########################
+ SUBROUTINE WRITEDIRAN(KLU,KVAL)
+! ###########################
+!
+IMPLICIT NONE
+INTEGER, INTENT(IN) :: KLU
+INTEGER,DIMENSION(:), INTENT(IN) :: KVAL
+!
+CHARACTER(LEN=80) :: YCAR80 ! String for directive written
+!CHARACTER(LEN=7) :: YFORMOUT ! String for format of directive written
+!INTEGER :: ISIZE
+CHARACTER(LEN=15) :: YFORMSIZE ! String for format of directive written
+
+!
+WRITE(YFORMSIZE,'("(",I2,"(I4))" )') SIZE(KVAL)
+!ISIZE=SIZE(KVAL)
+!YFORMSIZE='( (I3,X))'
+!WRITE(YFORMSIZE(2:3),'(I2)') ISIZE
+YCAR80(1:LEN(YCAR80))=' '
+WRITE(YCAR80,FMT=YFORMSIZE) KVAL
+YCAR80=ADJUSTL(YCAR80)
+!YFORMOUT='(A )'
+!WRITE(YFORMOUT(3:4),'(I2.2)') MAX(LEN_TRIM(YCAR80),3)
+WRITE(UNIT=KLU,FMT='(A)')YCAR80(1:LEN_TRIM(YCAR80))
+!
+END SUBROUTINE WRITEDIRAN
+! ###########################
+ SUBROUTINE WRITEDIRC(KLU,HVAL)
+! ###########################
+!
+IMPLICIT NONE
+INTEGER, INTENT(IN) :: KLU
+CHARACTER(LEN=*), INTENT(IN) :: HVAL
+!
+CHARACTER(LEN=80) :: YCAR80 ! String for directive written
+CHARACTER(LEN=7) :: YFORMOUT ! String for format of directive written
+!
+YCAR80(1:LEN(YCAR80))=' '
+WRITE(YCAR80,'(A80)')HVAL
+YCAR80=ADJUSTL(YCAR80)
+YFORMOUT='(A )'
+WRITE(YFORMOUT(3:4),'(I2.2)') MAX(LEN_TRIM(YCAR80),3)
+WRITE(UNIT=KLU,FMT=YFORMOUT)YCAR80(1:LEN_TRIM(YCAR80))
+!
+END SUBROUTINE WRITEDIRC
+
diff --git a/LIBTOOLS/tools/diachro/src/TOOL/zinter.f90 b/LIBTOOLS/tools/diachro/src/TOOL/zinter.f90
new file mode 100644
index 0000000000000000000000000000000000000000..606bf22ac1cec3641e32acae974ab008b047539e
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/TOOL/zinter.f90
@@ -0,0 +1,266 @@
+! ##################
+ MODULE MODI_ZINTER
+! ##################
+!
+INTERFACE ZINTER
+ SUBROUTINE ZINTER(PVMNH,PZGMNH,PVZL,PLZL,KKB,PUNDEF,KNIVMOD)
+!
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PVMNH
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PZGMNH
+REAL,DIMENSION(:,:,:),INTENT(OUT):: PVZL
+REAL,DIMENSION(:),INTENT(IN) :: PLZL
+REAL,INTENT(IN) :: PUNDEF
+!
+INTEGER,INTENT(IN) :: KKB
+INTEGER,DIMENSION(:,:),INTENT(OUT),OPTIONAL:: KNIVMOD
+!
+END SUBROUTINE ZINTER
+!
+ SUBROUTINE SINTER(PVMNH,PZGMNH,PVZL,PLZL,KKB,PUNDEF,KNIVMOD)
+!
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PVMNH
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PZGMNH
+REAL,DIMENSION(:,:,:),INTENT(OUT):: PVZL
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PLZL
+REAL,INTENT(IN) :: PUNDEF
+!
+INTEGER,INTENT(IN) :: KKB
+INTEGER,DIMENSION(:,:),INTENT(OUT),OPTIONAL:: KNIVMOD
+!
+END SUBROUTINE SINTER
+!
+END INTERFACE ZINTER
+END MODULE MODI_ZINTER
+! ##################
+ MODULE MODI_SINTER
+! ##################
+!
+INTERFACE SINTER
+ SUBROUTINE SINTER(PVMNH,PZGMNH,PVZL,PLZL,KKB,PUNDEF,KNIVMOD)
+!
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PVMNH
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PZGMNH
+REAL,DIMENSION(:,:,:),INTENT(OUT):: PVZL
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PLZL
+REAL,INTENT(IN) :: PUNDEF
+!
+INTEGER,INTENT(IN) :: KKB
+INTEGER,DIMENSION(:,:),INTENT(OUT),OPTIONAL:: KNIVMOD
+!
+END SUBROUTINE SINTER
+END INTERFACE SINTER
+END MODULE MODI_SINTER
+!
+!------------------------------------------------------------------------------
+!
+! ####################################################
+ SUBROUTINE SINTER(PVMNH,PZGMNH,PVZL,PLZL,KKB,PUNDEF,KNIVMOD)
+! ####################################################
+!
+!
+!!**** *ZINTER * - routine to linearly interpolate
+!!
+!! PURPOSE
+!! -------
+! This routine interpolates an input field on Gal-Chen grid, linearly in
+! another Z-grid (regular or not).
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Research manual 2 ECMWF forecast model, 1988, Ref M1.6/3
+!! "adiabatic part", Appendix 6 postprocessing
+!! Section 3. Vertical interpolation, p. A6.5-6
+!! Section 3.4 Extrapolation, pp. A6.6-7
+!!
+!! AUTHOR
+!! ------
+!! P. Mascart * LA *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 22/04/96
+!! Modification 11/02/99 Chaboureau - some simplifications
+!!-----------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declaration of arguments
+!
+INTEGER,INTENT(IN) :: KKB ! 1st level above ground
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PVMNH
+!! PVMNH = tableau du champ donne au points masse Meso-NH
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PZGMNH
+!! PZGMNH = altitude geopotentiel au point masse Meso-NH
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PLZL ! list of the new vertical levels
+REAL,DIMENSION(:,:,:),INTENT(OUT):: PVZL ! interpolated output field
+REAL,INTENT(IN) :: PUNDEF ! undefined value
+INTEGER,DIMENSION(:,:),INTENT(OUT),OPTIONAL:: KNIVMOD
+!! first model level above PLZL(:,:,1)
+!
+!* 0.2 Declaration of local variables
+!
+INTEGER :: ILT,ILN ! number of points in the 1st and 2nd dimensions
+INTEGER :: IKU ! number of input vertical levels
+INTEGER :: INP ! number of new vertical levels (1: base ; INP: top)
+
+REAL :: ZSLOPE
+INTEGER :: JI,JJ,JKZL,JK
+INTEGER :: IKD
+!
+!------------------------------------------------------------------------------
+!
+!* 1. INITIALIZATION
+! --------------
+!
+ILT=SIZE(PVMNH,1)
+ILN=SIZE(PVMNH,2)
+IKU=SIZE(PVMNH,3)
+INP=SIZE(PVZL,3)
+PVZL=PUNDEF
+IF (PRESENT (KNIVMOD)) KNIVMOD=KKB
+!
+print*,'in SINTER ',ILT,ILN,IKU,INP
+!------------------------------------------------------------------------------
+!
+!* 2. INTERPOLATION
+! -------------
+!
+OX: DO JI =1,ILT
+ OY: DO JJ =1,ILN
+ PLEV: DO JKZL=1,INP
+ !
+ ! i) Zones flagging
+ !
+ IKD=0
+ IF(PLZL(JI,JJ,JKZL).GE.PZGMNH(JI,JJ,IKU)) IKD=10*IKU
+ DO JK =IKU-1,KKB,-1
+ IF((PZGMNH(JI,JJ,JK+1).GT.PLZL(JI,JJ,JKZL)).AND. &
+ (PLZL(JI,JJ,JKZL).GE.PZGMNH(JI,JJ,JK))) IKD=JK
+ END DO
+ IF(PLZL(JI,JJ,JKZL).LT.PZGMNH(JI,JJ,KKB)) IKD=-10*IKU
+ IF(IKD==0) IKD=10*IKU !! pas propre...
+ !
+ ! ii) Regular points interpolation
+ !
+ IF(ABS(IKD).NE.(10*IKU)) THEN
+ IF ( PVMNH(JI,JJ,IKD) /= PUNDEF .AND. PVMNH(JI,JJ,IKD+1)/= PUNDEF) THEN
+ ZSLOPE=(PLZL(JI,JJ,JKZL)-PZGMNH(JI,JJ,IKD)) &
+ /(PZGMNH(JI,JJ,IKD+1)-PZGMNH(JI,JJ,IKD))
+ PVZL(JI,JJ,JKZL)=PVMNH(JI,JJ,IKD) &
+ +ZSLOPE*(PVMNH(JI,JJ,IKD+1)-PVMNH(JI,JJ,IKD))
+ IF (PRESENT (KNIVMOD)) THEN
+ KNIVMOD(JI,JJ)=IKD+1
+ ENDIF
+ ELSE
+ PVZL(JI,JJ,JKZL)=PUNDEF
+ ENDIF
+ ELSE
+ !
+ ! iii) No extrapolation below the ground and above the top
+ !
+ PVZL(JI,JJ,JKZL)=PUNDEF
+ ENDIF
+ END DO PLEV
+ END DO OY
+END DO OX
+!
+END SUBROUTINE SINTER
+!
+! ####################################################
+ SUBROUTINE ZINTER(PVMNH,PZGMNH,PVZL,PLZL,KKB,PUNDEF,KNIVMOD)
+! ####################################################
+!
+!
+!!**** *ZINTER * - routine to linearly interpolate
+!!
+!! PURPOSE
+!! -------
+! This routine interpolates an input field on Gal-Chen grid, linearly in
+! another Z-grid (regular or not).
+!
+!!** METHOD
+!! ------
+!!
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Research manual 2 ECMWF forecast model, 1988, Ref M1.6/3
+!! "adiabatic part", Appendix 6 postprocessing
+!! Section 3. Vertical interpolation, p. A6.5-6
+!! Section 3.4 Extrapolation, pp. A6.6-7
+!!
+!! AUTHOR
+!! ------
+!! P. Mascart * LA *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 22/04/96
+!! Modification 11/02/99 Chaboureau - some simplifications
+!!-----------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODI_SINTER
+IMPLICIT NONE
+!
+!* 0.1 Declaration of arguments
+!
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PVMNH
+REAL,DIMENSION(:,:,:),INTENT(IN) :: PZGMNH
+REAL,DIMENSION(:,:,:),INTENT(OUT):: PVZL
+REAL,DIMENSION(:),INTENT(IN) :: PLZL
+REAL,INTENT(IN) :: PUNDEF
+!
+INTEGER,INTENT(IN) :: KKB
+INTEGER,DIMENSION(:,:),INTENT(OUT),OPTIONAL:: KNIVMOD
+!
+!* 0.2 Declaration of local variables
+!
+INTEGER :: ILT,ILN ! number of points in the 1st and 2nd dimensions
+INTEGER :: IKU ! number of input vertical levels
+INTEGER :: INP ! number of new vertical levels (1: base ; INP: top)
+REAL,DIMENSION(:,:,:),ALLOCATABLE :: ZLZL
+!
+!------------------------------------------------------------------------------
+!
+!* 1. INITIALIZATION
+! --------------
+!
+ILT=SIZE(PVMNH,1)
+ILN=SIZE(PVMNH,2)
+INP=SIZE(PVZL,3)
+!
+ALLOCATE(ZLZL(ILT,ILN,INP))
+ZLZL(:,:,:) = SPREAD( SPREAD( PLZL(1:INP),1,ILT ) ,2,ILN )
+!
+!------------------------------------------------------------------------------
+!
+!* 2. INTERPOLATION
+! -------------
+!
+CALL SINTER(PVMNH,PZGMNH,PVZL,ZLZL,KKB,PUNDEF,KNIVMOD)
+!
+END SUBROUTINE ZINTER
diff --git a/LIBTOOLS/tools/diachro/src/listing b/LIBTOOLS/tools/diachro/src/listing
new file mode 100755
index 0000000000000000000000000000000000000000..3fd4761a9e13fbde5244f4bf50dc69a665a34d1f
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/listing
@@ -0,0 +1,21 @@
+>list_diachro
+for rep in mesonh_MOD MOD ; do
+echo '==============================================================================='>> list_diachro
+echo '==============================================================================='>> list_diachro
+echo " repertoire **** $rep ****">>list_diachro
+echo " **************">>list_diachro
+echo '==============================================================================='>> list_diachro
+echo '==============================================================================='>> list_diachro
+cd $rep
+echo $rep
+for fic in *.f* ; do
+echo '==============================================================================='>> ../list_diachro
+echo " fichier **** $fic ****">>../list_diachro
+echo '==============================================================================='>> ../list_diachro
+cat $fic >>../list_diachro
+echo >>../list_diachro
+echo '==============================================================================='>> ../list_diachro
+done
+cd ..
+done
+
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/hor_interp_4pts.f90 b/LIBTOOLS/tools/diachro/src/mesonh/hor_interp_4pts.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6e116d84e7ef0006c1978b599931e698f7d04916
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/hor_interp_4pts.f90
@@ -0,0 +1,311 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+! ###########################
+ MODULE MODI_HOR_INTERP_4PTS
+! ###########################
+INTERFACE HOR_INTERP_4PTS
+ SUBROUTINE HOR_INTERP_4PTS_2D(PX1,PY1,PFIELD1,PX2,PY2,PFIELD2)
+
+!
+REAL, DIMENSION(:),INTENT(IN) :: PX1 ! x of each grid mesh.
+REAL, DIMENSION(:),INTENT(IN) :: PY1 ! y of each grid mesh.
+REAL, DIMENSION(:,:),INTENT(IN) :: PFIELD1 ! field on grid mesh
+!
+REAL, DIMENSION(:,:),INTENT(IN) :: PX2 ! x of each new grid mesh.
+REAL, DIMENSION(:,:),INTENT(IN) :: PY2 ! y of each new grid mesh.
+REAL, DIMENSION(:,:),INTENT(OUT) :: PFIELD2 ! field on new grid mesh
+!
+END SUBROUTINE HOR_INTERP_4PTS_2D
+!
+ SUBROUTINE HOR_INTERP_4PTS_3D(PX1,PY1,PFIELD1,PX2,PY2,PFIELD2)
+
+!
+REAL, DIMENSION(:),INTENT(IN) :: PX1 ! x of each grid mesh.
+REAL, DIMENSION(:),INTENT(IN) :: PY1 ! y of each grid mesh.
+REAL, DIMENSION(:,:,:),INTENT(IN) :: PFIELD1 ! field on grid mesh
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PX2 ! x of each new grid mesh.
+REAL, DIMENSION(:,:), INTENT(IN) :: PY2 ! y of each new grid mesh.
+REAL, DIMENSION(:,:,:),INTENT(OUT) :: PFIELD2 ! field on new grid mesh
+!
+END SUBROUTINE HOR_INTERP_4PTS_3D
+END INTERFACE
+END MODULE MODI_HOR_INTERP_4PTS
+!
+!
+! ##############################
+ MODULE MODI_HOR_INTERP_4PTS_3D
+! ##############################
+INTERFACE HOR_INTERP_4PTS_3D
+ SUBROUTINE HOR_INTERP_4PTS_3D(PX1,PY1,PFIELD1,PX2,PY2,PFIELD2)
+
+!
+REAL, DIMENSION(:),INTENT(IN) :: PX1 ! x of each grid mesh.
+REAL, DIMENSION(:),INTENT(IN) :: PY1 ! y of each grid mesh.
+REAL, DIMENSION(:,:,:),INTENT(IN) :: PFIELD1 ! field on grid mesh
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PX2 ! x of each new grid mesh.
+REAL, DIMENSION(:,:), INTENT(IN) :: PY2 ! y of each new grid mesh.
+REAL, DIMENSION(:,:,:),INTENT(OUT) :: PFIELD2 ! field on new grid mesh
+!
+END SUBROUTINE HOR_INTERP_4PTS_3D
+END INTERFACE
+END MODULE MODI_HOR_INTERP_4PTS_3D
+!
+! ##############################################################
+ SUBROUTINE HOR_INTERP_4PTS_3D(PX1,PY1,PFIELD1,PX2,PY2,PFIELD2)
+! ##############################################################
+!
+!!**** *HOR_INTERP_4PTS* interpolates horizontally a 3D field from a
+!! REGULAR horizontal grid to any other grid
+!!
+!! PURPOSE
+!! -------
+!!
+!!
+!! METHOD
+!! ------
+!!
+!! Bogus value of input field is XUNDEF
+!!
+!! The routine uses only the points with physical values for interpolation:
+!! 4pts available: interpolations linear in the 2 directions
+!! 3pts available: plane interpolation
+!! 2pts available: linear interpolation
+!! 1pt available: copy
+!!
+!! Bogus value returned where field could not be interpolated is XUNDEF
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. Masson Meteo-France
+!!
+!! MODIFICATION
+!! ------------
+!!
+!! Original 19/03/95
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATION
+! -----------
+!
+!USE MODE_FM
+!USE MODD_LUNIT
+USE MODD_PARAMETERS, ONLY: XUNDEF
+!
+IMPLICIT NONE
+!
+!* 0.1 Declaration of arguments
+! ------------------------
+!
+REAL, DIMENSION(:),INTENT(IN) :: PX1 ! x of each grid mesh.
+REAL, DIMENSION(:),INTENT(IN) :: PY1 ! y of each grid mesh.
+REAL, DIMENSION(:,:,:),INTENT(IN) :: PFIELD1 ! field on grid mesh
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PX2 ! x of each new grid mesh.
+REAL, DIMENSION(:,:), INTENT(IN) :: PY2 ! y of each new grid mesh.
+REAL, DIMENSION(:,:,:),INTENT(OUT) :: PFIELD2 ! field on new grid mesh
+!
+!* 0.2 Declaration of local variables
+! ------------------------------
+!
+INTEGER :: ILUOUT0 ! logical unit
+INTEGER :: IRESP ! return codes
+INTEGER :: JK
+INTEGER :: IIU,IJU,IIOUT,IJOUT,II,IJ
+INTEGER :: JI,JJ,JIOUT,JJOUT
+REAL :: ZEPS
+REAL :: ZXA,ZXB,ZXC,ZXD,ZYA,ZYB,ZYC,ZYD,ZA,ZB,ZC,ZD
+REAL, DIMENSION(3) :: ZX,ZY,ZF
+INTEGER :: JLOOP
+REAL :: ZDET,ZALPHA,ZBETA,ZGAMMA
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. Initializations
+! ---------------
+!
+print *,'HOR_INTERP_4PTS: old grid',SIZE(PX1),SIZE(PY1), &
+ 'new grid ',SIZE(PX2,1),SIZE(PY2,2)
+!CALL FMLOOK_ll(CLUOUT0,CLUOUT0,ILUOUT0,IRESP)
+IIOUT=SIZE(PX2,1)
+IJOUT=SIZE(PY2,2)
+IIU=SIZE(PX1)
+IJU=SIZE(PY1)
+ZEPS=1.E-10
+!
+!-------------------------------------------------------------------------------
+!
+!print * ,' avant boucle JK= k i j iold jold',SIZE(PFIELD1,3) ,IIOUT,IJOUT,SIZE(PX1),SIZE(PY1)
+!print *, 'PX1(fin), PY1(fin)', PX1(SIZE(PX1)), PY1(SIZE(PY1))
+!print *, 'PX2(IIOUT,IJOUT), PY2(IIOUT,IJOUT)', PX2(IIOUT,IJOUT), PY2(IIOUT,IJOUT)
+DO JK=1,SIZE(PFIELD1,3)
+ DO JIOUT=1,IIOUT
+ DO JJOUT=1,IJOUT
+ II=COUNT(PX1(:)<PX2(JIOUT,JJOUT))
+ IJ=COUNT(PY1(:)<PY2(JIOUT,JJOUT))
+ IF ( II<1 .OR. II>=IIU .OR. IJ<1 .OR. IJ>=IJU) THEN
+ PFIELD2(JIOUT,JJOUT,:)=XUNDEF
+ !print *,'pt nouvelle grille hors ancienne grille i j nbi nbj:',JIOUT,JJOUT,II,IJ
+ !print *,'PX2(JIOUT,JJOUT),PY2(JIOUT,JJOUT)' ,PX2(JIOUT,JJOUT),PY2(JIOUT,JJOUT)
+ CYCLE
+ END IF
+!
+ !print *,' valeur non indef i j nbi nbj:',JIOUT,JJOUT, II,IJ
+ ZXA=PX1(II)
+ ZXB=PX1(II)
+ ZXC=PX1(II+1)
+ ZXD=PX1(II+1)
+!
+ ZYA=PY1(IJ)
+ ZYB=PY1(IJ+1)
+ ZYC=PY1(IJ)
+ ZYD=PY1(IJ+1)
+!
+ ZA=PFIELD1(II,IJ,JK)
+ ZB=PFIELD1(II,IJ+1,JK)
+ ZC=PFIELD1(II+1,IJ,JK)
+ ZD=PFIELD1(II+1,IJ+1,JK)
+!
+ IF (ALL(ABS(PFIELD1(II:II+1,IJ:IJ+1,JK)-XUNDEF)<ZEPS) ) THEN
+ !print * ,' 4 points a indef :', PFIELD1(II:II+1,IJ:IJ+1,JK)
+ PFIELD2(JIOUT,JJOUT,JK)=XUNDEF
+ CYCLE
+ ELSE IF (ALL(ABS(PFIELD1(II:II+1,IJ:IJ+1,JK)-XUNDEF)>=ZEPS) ) THEN
+ ZALPHA=ZA+(ZB-ZA)*(PY2(JIOUT,JJOUT)-ZYA)/(ZYB-ZYA)
+ ZBETA =ZC+(ZD-ZC)*(PY2(JIOUT,JJOUT)-ZYC)/(ZYD-ZYC)
+ PFIELD2(JIOUT,JJOUT,JK)=ZALPHA+(ZBETA-ZALPHA)*(PX2(JIOUT,JJOUT)-ZXA)/(ZXC-ZXA)
+ ELSE
+ JLOOP=0
+ DO JI=II,II+1
+ DO JJ=IJ,IJ+1
+ IF (ABS(PFIELD1(JI,JJ,JK)-XUNDEF)>ZEPS) THEN
+ JLOOP=JLOOP+1
+ ZX(JLOOP)=PX1(JI)
+ ZY(JLOOP)=PY1(JJ)
+ ZF(JLOOP)=PFIELD1(JI,JJ,JK)
+ END IF
+ END DO
+ END DO
+ IF (JLOOP==1) THEN
+ PFIELD2(JIOUT,JJOUT,JK)=ZF(1)
+ ELSE IF (JLOOP==2) THEN
+ IF (ABS(ZX(1)-ZX(2))>ZEPS) THEN
+ PFIELD2(JIOUT,JJOUT,JK)=ZF(1)+(ZF(2)-ZF(1))*(PX2(JIOUT,JJOUT)-ZX(1))/(ZX(2)-ZX(1))
+ ELSE
+ PFIELD2(JIOUT,JJOUT,JK)=ZF(1)+(ZF(2)-ZF(1))*(PY2(JIOUT,JJOUT)-ZY(1))/(ZY(2)-ZY(1))
+ END IF
+ ELSE IF (JLOOP==3) THEN
+ ZDET=(ZX(1)-ZX(3))*(ZY(2)-ZY(3))-(ZX(2)-ZX(3))*(ZY(1)-ZY(3))
+ ZALPHA=( (ZF(1)-ZF(3))*(ZY(2)-ZY(3))-(ZF(2)-ZF(3))*(ZY(1)-ZY(3)) )/ZDET
+ ZBETA=-( (ZF(1)-ZF(3))*(ZX(2)-ZX(3))-(ZF(2)-ZF(3))*(ZX(1)-ZX(3)) )/ZDET
+ ZGAMMA=ZF(1)-ZALPHA*ZX(1)-ZBETA*ZY(1)
+ PFIELD2(JIOUT,JJOUT,JK)=ZALPHA*PX2(JIOUT,JJOUT) &
+ +ZBETA *PY2(JIOUT,JJOUT) &
+ +ZGAMMA
+ END IF
+ END IF
+ END DO
+ END DO
+END DO
+print *, 'fin routine HOR_INTERP_4PTS_3D'
+!-------------------------------------------------------------------------------
+!
+!WRITE(ILUOUT0,*) ' Routine HOR_INTERP_4PTS completed'
+!
+END SUBROUTINE HOR_INTERP_4PTS_3D
+!
+! ##############################################################
+ SUBROUTINE HOR_INTERP_4PTS_2D(PX1,PY1,PFIELD1,PX2,PY2,PFIELD2)
+! ##############################################################
+!
+!!**** *HOR_INTERP_4PTS* interpolates horizontally a 2D field from a
+!! REGULAR horizontal grid to any other grid
+!!
+!! PURPOSE
+!! -------
+!!
+!!
+!! METHOD
+!! ------
+!!
+!! Bogus value of input field is XUNDEF
+!!
+!! The routine uses only the points with physical values for interpolation:
+!! 4pts available: interpolations linear in the 2 directions
+!! 3pts available: plane interpolation
+!! 2pts available: linear interpolation
+!! 1pt available: copy
+!!
+!! Bogus value returned where field could not be interpolated is XUNDEF
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!!
+!! V. Masson Meteo-France
+!!
+!! MODIFICATION
+!! ------------
+!!
+!! Original 04/07/96
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATION
+! -----------
+!
+USE MODI_HOR_INTERP_4PTS_3D
+!
+IMPLICIT NONE
+!
+!* 0.1 Declaration of arguments
+! ------------------------
+!
+REAL, DIMENSION(:),INTENT(IN) :: PX1 ! x of each grid mesh.
+REAL, DIMENSION(:),INTENT(IN) :: PY1 ! y of each grid mesh.
+REAL, DIMENSION(:,:), INTENT(IN) :: PFIELD1 ! field on grid mesh
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PX2 ! x of each new grid mesh.
+REAL, DIMENSION(:,:), INTENT(IN) :: PY2 ! y of each new grid mesh.
+REAL, DIMENSION(:,:), INTENT(OUT) :: PFIELD2 ! field on new grid mesh
+!
+!* 0.2 Declaration of local variables
+! ------------------------------
+!
+REAL, DIMENSION(SIZE(PFIELD1,1),SIZE(PFIELD1,2),1) :: ZFIELD1
+REAL, DIMENSION(SIZE(PFIELD2,1),SIZE(PFIELD2,2),1) :: ZFIELD2
+!
+!-------------------------------------------------------------------------------
+!
+ZFIELD1(:,:,1)=PFIELD1(:,:)
+CALL HOR_INTERP_4PTS_3D(PX1(:),PY1(:),ZFIELD1(:,:,:), &
+ PX2(:,:),PY2(:,:),ZFIELD2(:,:,:))
+PFIELD2(:,:)=ZFIELD2(:,:,1)
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE HOR_INTERP_4PTS_2D
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/ini_cst.f90 b/LIBTOOLS/tools/diachro/src/mesonh/ini_cst.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bfffa1babd68a578c862477c3ad9db9554a33a4b
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/ini_cst.f90
@@ -0,0 +1,151 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODI_INI_CST
+! ###################
+!
+INTERFACE
+!
+SUBROUTINE INI_CST
+END SUBROUTINE INI_CST
+!
+END INTERFACE
+!
+END MODULE MODI_INI_CST
+!
+!
+!
+! ##################
+ SUBROUTINE INI_CST
+! ##################
+!
+!!**** *INI_CST * - routine to initialize the module MODD_CST
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to initialize the physical constants
+! stored in module MODD_CST.
+!
+!
+!!** METHOD
+!! ------
+!! The physical constants are set to their numerical values
+!!
+!!
+!! EXTERNAL
+!! --------
+!! FMLOOK : to retrieve logical unit number associated to a file
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST : contains physical constants
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of the documentation (module MODD_CST, routine INI_CST)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 18/05/94
+!! J. Stein 02/01/95 add the volumic mass of liquid water
+!! J.-P. Pinty 13/12/95 add the water vapor pressure over solid ice
+!! J. Stein 29/06/97 add XTH00
+!! V. Masson 05/10/98 add XRHOLI
+!! C. Mari 31/10/00 add NDAYSEC
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CST
+!
+IMPLICIT NONE
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. FUNDAMENTAL CONSTANTS
+! ---------------------
+!
+XPI = 2.*ASIN(1.)
+XKARMAN = 0.4
+XLIGHTSPEED = 299792458.
+XPLANCK = 6.6260755E-34
+XBOLTZ = 1.380658E-23
+XAVOGADRO = 6.0221367E+23
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. ASTRONOMICAL CONSTANTS
+! ----------------------
+!
+XDAY = 86400.
+XSIYEA = 365.25*XDAY*2.*XPI/ 6.283076
+XSIDAY = XDAY/(1.+XDAY/XSIYEA)
+XOMEGA = 2.*XPI/XSIDAY
+NDAYSEC = 24*3600 ! Number of seconds in a day
+!
+!-------------------------------------------------------------------------------!
+!
+!
+!* 3. TERRESTRIAL GEOIDE CONSTANTS
+! ----------------------------
+!
+XRADIUS = 6371229.
+XG = 9.80665
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. REFERENCE PRESSURE
+! -------------------
+!
+XP00 = 1.E5
+XTH00 = 300.
+!-------------------------------------------------------------------------------
+!
+!* 5. RADIATION CONSTANTS
+! -------------------
+!
+XSTEFAN = 2.* XPI**5 * XBOLTZ**4 / (15.* XLIGHTSPEED**2 * XPLANCK**3)
+XI0 = 1370.
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. THERMODYNAMIC CONSTANTS
+! -----------------------
+!
+XMD = 28.9644E-3
+XMV = 18.0153E-3
+XRD = XAVOGADRO * XBOLTZ / XMD
+XRV = XAVOGADRO * XBOLTZ / XMV
+XCPD = 7.* XRD /2.
+XCPV = 4.* XRV
+XRHOLW = 1000.
+XRHOLI = 900.
+XCL = 4.218E+3
+XCI = 2.106E+3
+XTT = 273.16
+XLVTT = 2.5008E+6
+XLSTT = 2.8345E+6
+XLMTT = XLSTT - XLVTT
+XESTT = 611.14
+XGAMW = (XCL - XCPV) / XRV
+XBETAW = (XLVTT/XRV) + (XGAMW * XTT)
+XALPW = LOG(XESTT) + (XBETAW /XTT) + (XGAMW *LOG(XTT))
+XGAMI = (XCI - XCPV) / XRV
+XBETAI = (XLSTT/XRV) + (XGAMI * XTT)
+XALPI = LOG(XESTT) + (XBETAI /XTT) + (XGAMI *LOG(XTT))
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE INI_CST
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/init_for_convlfi.f90 b/LIBTOOLS/tools/diachro/src/mesonh/init_for_convlfi.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f481c05e36d03e3fa8ba243f7b74d8783594f1b7
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/init_for_convlfi.f90
@@ -0,0 +1,395 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!###########################
+MODULE MODI_INIT_FOR_CONVLFI
+!###########################
+!
+INTERFACE
+ SUBROUTINE INIT_FOR_CONVLFI(HINIFILE,HLUOUT)
+!
+CHARACTER(LEN=28), INTENT(IN) :: HINIFILE ! file being read
+CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! output listing
+!
+END SUBROUTINE INIT_FOR_CONVLFI
+END INTERFACE
+END MODULE MODI_INIT_FOR_CONVLFI
+!
+! ############################################
+ SUBROUTINE INIT_FOR_CONVLFI(HINIFILE,HLUOUT)
+! ############################################
+!
+!!**** *INIT_FOR_CONVLFI * - light monitor to initialize the variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to initialize some variables
+! necessary in the conversion program.
+!
+!!** METHOD
+!! ------
+!! This initialization takes some parts of the whole initialization modules
+!! of monitor INIT:
+!! geometry and dimensions from ini_sizen
+!! grids, metric coefficients, dates and times from set_grid
+!! reading of the pressure field
+!!
+!!
+!! EXTERNAL
+!! --------
+!! INI_CST : to initialize physical constants
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! AUTHOR
+!! ------
+!! I. Mallet * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 20/02/01
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+USE MODD_CONF
+USE MODD_CST
+USE MODD_DIM1
+USE MODD_FIELD1
+USE MODD_GRID
+USE MODD_GRID1
+USE MODD_TIME
+USE MODD_TIME1
+!USE MODD_VAR_ll, ONLY : NPROC
+!
+USE MODE_TIME
+USE MODE_GRIDPROJ
+USE MODE_GRIDCART
+!
+!USE MODE_FM
+!USE MODE_FMREAD
+USE MODI_FMREAD
+!USE MODE_IO_ll
+!USE MODE_ll
+!
+!USE MODI_GATHER_ll
+USE MODI_INI_CST
+!
+IMPLICIT NONE
+!
+!* 0.1 Arguments variables
+!
+CHARACTER(LEN=28), INTENT(IN) :: HINIFILE ! file being read
+CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! output listing
+!
+!* 0.2 Local variables
+!
+INTEGER :: IGRID,ILENCH,IRESP,ILUOUT ! return code of file management
+CHARACTER (LEN=16) :: YRECFM ! management
+CHARACTER (LEN=100) :: YCOMMENT ! variables
+CHARACTER (LEN=2) :: YDIR
+INTEGER, DIMENSION(3) :: ITDATE ! date array
+CHARACTER (LEN=40) :: YTITLE ! Title for date print
+REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZJ ! Jacobian
+!
+REAL :: ZXHATM,ZYHATM ! coordinates of mass point
+REAL :: ZLATORI, ZLONORI ! lat and lon of left-bottom point
+INTEGER :: IIU,IJU ! Upper dimension in x,y direction (local)
+INTEGER :: IKU ! Upper dimension in z direction
+INTEGER :: IINFO_ll ! return code of // routines
+INTEGER :: ILENG ! for old fmread
+INTEGER :: IMASDEV ! masdev of the file
+LOGICAL :: GSLEVE ! local flag for SLEVE coordinate
+!-------------------------------------------------------------------------------
+!
+!CALL FMLOOK_ll(HLUOUT,HLUOUT,ILUOUT,IRESP)
+CALL FMLOOK(HLUOUT,HLUOUT,ILUOUT,IRESP)
+!
+!* 1. INITIALIZE EACH MODEL SIZES AND DEPENDENCY (ini_sizen)
+! ------------------------------------------
+!
+!* 1.1 Read the geometry kind in the LFIFM file (Cartesian or spherical)
+!
+YRECFM = 'CARTESIAN'
+YDIR='--'
+ILENG=1
+!CALL FMREAD(HINIFILE,YRECFM,HLUOUT,YDIR,LCARTESIAN,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,LCARTESIAN,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+!* 1.2 Read dimensions in initial file and initialize subdomain
+! dimensions and parallel variables
+!
+YRECFM='IMAX'
+YDIR='--'
+ILENG=1
+!CALL FMREAD(HINIFILE,YRECFM,HLUOUT,YDIR,NIMAX_ll,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,NIMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='JMAX'
+YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,NJMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM = 'L1D'
+YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,L1D,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP/=0) THEN
+ L1D=.FALSE.
+ IF( (NIMAX == 1).AND.(NJMAX == 1) ) L1D=.TRUE.
+ENDIF
+!
+YRECFM = 'L2D'
+YDIR='--'
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,L2D,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP/=0) THEN
+ L2D=.FALSE.
+ IF( (NIMAX /= 1).AND.(NJMAX == 1) ) L2D=.TRUE.
+ENDIF
+!
+YRECFM = 'PACK'
+YDIR='--'
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,LPACK,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP/=0) LPACK=.FALSE.
+!
+YRECFM='KMAX'
+YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,NKMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+!CSPLIT ='YSPLITTING' ; NHALO = 1
+!CALL SET_SPLITTING_ll(CSPLIT)
+!CALL SET_JP_ll(1,JPHEXT,JPVEXT, NHALO)
+!CALL SET_DAD0_ll()
+!CALL SET_DIM_ll(NIMAX_ll, NJMAX_ll, NKMAX)
+!CALL SET_FMPACK_ll(L1D,L2D,LPACK)
+!CALL SET_LBX_ll('OPEN', 1)
+!CALL SET_LBY_ll('OPEN', 1)
+!CALL SET_XRATIO_ll(1, 1)
+!CALL SET_YRATIO_ll(1, 1)
+!CALL SET_XOR_ll(1, 1)
+!CALL SET_XEND_ll(NIMAX_ll+2*JPHEXT, 1)
+!CALL SET_YOR_ll(1, 1)
+!CALL SET_YEND_ll(NJMAX_ll+2*JPHEXT, 1)
+!CALL SET_DAD_ll(0, 1)
+!CALL INI_PARA_ll(IINFO_ll)
+!
+!* 1.3 Compute sizes of arrays of the extended sub-domain (ini_modeln)
+!
+IKU=NKMAX + 2*JPVEXT
+!CALL GET_DIM_EXT_ll('B',IIU,IJU)
+!CALL GET_DIM_PHYS_ll('B',NIMAX,NJMAX)
+IIU=NIMAX +2*JPHEXT
+IJU=NJMAX +2*JPHEXT
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. INITIALIZE GRIDS AND METRIC COEFFICIENTS (set_grid)
+! ---------------------
+!
+! 2.1 reading
+!
+YRECFM='LON0'
+YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XLON0,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='LAT0'
+YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XLAT0,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='BETA'
+YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XBETA,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='XHAT'
+ALLOCATE(XXHAT(IIU))
+YDIR='XX'
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,IIU,XXHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='YHAT'
+ALLOCATE(XYHAT(IJU))
+YDIR='YY'
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,IJU,XYHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='MASDEV'
+YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,IMASDEV,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP /=0) IMASDEV=43
+!
+IF (.NOT.LCARTESIAN) THEN
+ YRECFM='RPK'
+ YDIR='--'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XRPK,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='LONORI'
+ YDIR='--'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XLONORI,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='LATORI'
+ YDIR='--'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XLATORI,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ IF (IMASDEV<=45) THEN
+ CALL FMREAD(HINIFILE,'LONOR',HLUOUT,ILENG,XLONORI,IGRID,ILENCH,YCOMMENT,IRESP)
+ CALL FMREAD(HINIFILE,'LATOR',HLUOUT,ILENG,XLATORI,IGRID,ILENCH,YCOMMENT,IRESP)
+ !ALLOCATE(ZXHAT_ll(NIMAX_ll+ 2 * JPHEXT),ZYHAT_ll(NJMAX_ll+2 * JPHEXT))
+ !CALL GATHERALL_FIELD_ll('XX',XXHAT,ZXHAT_ll,IRESP) !//
+ !CALL GATHERALL_FIELD_ll('YY',XYHAT,ZYHAT_ll,IRESP) !//
+ ZXHATM = - 0.5 * (XXHAT(1)+XXHAT(2))
+ ZYHATM = - 0.5 * (XYHAT(1)+XYHAT(2))
+ CALL SM_LATLON(XLATORI,XLONORI,ZXHATM,ZYHATM,ZLATORI,ZLONORI)
+ !DEALLOCATE(ZXHAT_ll,ZYHAT_ll)
+ XLATORI = ZLATORI
+ XLONORI = ZLONORI
+ END IF
+END IF
+!
+!
+YRECFM='ZS'
+ALLOCATE(XZS(IIU,IJU))
+YDIR='XY'
+ILENG=IIU*IJU
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XZS,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP/=0) XZS(:,:)=0.
+!
+YRECFM='ZHAT'
+ALLOCATE(XZHAT(IKU))
+YDIR='--'
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,IKU,XZHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+LSLEVE=.FALSE.
+XLEN1=7500.
+XLEN2=2500.
+ALLOCATE(XZSMT(IIU,IJU))
+!
+IF (IMASDEV<=46) THEN
+ XZSMT = XZS
+ LSLEVE = .FALSE.
+ELSE
+ YRECFM='SLEVE'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,GSLEVE,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF (IRESP ==0) LSLEVE=GSLEVE
+ !
+ YRECFM='ZSMT'
+ ILENG=IIU*IJU
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XZSMT,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='LEN1'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XLEN1,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='LEN2'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XLEN2,IGRID,ILENCH,YCOMMENT,IRESP)
+ print *,'init_for_convlfi: SLEVE=',LSLEVE,XLEN1,XLEN2
+END IF
+!
+YRECFM='DTEXP%TDATE'
+YDIR='--'
+ILENG=3
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+TDTEXP%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+!
+YRECFM='DTEXP%TIME'
+YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,TDTEXP%TIME,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='DTMOD%TDATE'
+YDIR='--'
+ILENG=3
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+TDTMOD%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+!
+YRECFM='DTMOD%TIME'
+YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,TDTMOD%TIME,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='DTSEG%TDATE'
+YDIR='--'
+ILENG=3
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+TDTSEG%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+!
+YRECFM='DTSEG%TIME'
+YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,TDTSEG%TIME,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='DTCUR%TDATE'
+YDIR='--'
+ILENG=3
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+TDTCUR%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+!
+YRECFM='DTCUR%TIME'
+YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,TDTCUR%TIME,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YTITLE='CURRENT DATE AND TIME'
+CALL SM_PRINT_TIME(TDTCUR,HLUOUT,YTITLE)
+!
+!* 3.2 Spatial grid
+!
+ALLOCATE(XDXHAT(IIU))
+ALLOCATE(XDYHAT(IJU))
+ALLOCATE(XZZ(IIU,IJU,IKU))
+ALLOCATE(ZJ(IIU,IJU,IKU))
+!
+YRECFM='STORAGE_TYPE'
+YDIR='--'
+ILENG=2
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,CSTORAGE_TYPE,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP/=0) CSTORAGE_TYPE='MT'
+IF (CSTORAGE_TYPE=='PG') CCONF='POSTP' ! pour fichier PGD dans mode_gridproj
+!
+CALL INI_CST
+!
+IF (LCARTESIAN) THEN
+ CALL SM_GRIDCART(HLUOUT,XXHAT,XYHAT,XZHAT,XZS,LSLEVE,XLEN1,XLEN2,XZSMT,XDXHAT,XDYHAT,XZZ,ZJ)
+ELSE
+ ALLOCATE(XLON(IIU,IJU))
+ ALLOCATE(XLAT(IIU,IJU))
+ ALLOCATE(XMAP(IIU,IJU))
+ CALL SM_GRIDPROJ(HLUOUT,XXHAT,XYHAT,XZHAT,XZS,LSLEVE,XLEN1,XLEN2,XZSMT,XLATORI,XLONORI, &
+ XMAP,XLAT,XLON,XDXHAT,XDYHAT,XZZ,ZJ)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. INITIALIZE THE PROGNOSTIC AND SURFACE FIELDS (read_field)
+! --------------------------------------------
+ALLOCATE(XPABSM(IIU,IJU,IKU))
+ALLOCATE(XPABST(IIU,IJU,IKU))
+!
+YDIR='XY'
+ILENG=IIU*IJU*IKU
+YRECFM = 'PABSM'
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XPABSM,IGRID,ILENCH,YCOMMENT,IRESP)
+YRECFM = 'PABST'
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XPABST,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE INIT_FOR_CONVLFI
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/menu_diachro.f90 b/LIBTOOLS/tools/diachro/src/mesonh/menu_diachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..644cb9010d44fb3ae329edd8a3884495b5570769
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/menu_diachro.f90
@@ -0,0 +1,165 @@
+! ######spl
+ MODULE MODI_MENU_DIACHRO
+! #########################
+!
+INTERFACE
+!
+SUBROUTINE MENU_DIACHRO(HFILEDIA,HLUOUTDIA,HGROUP)
+CHARACTER(LEN=*) :: HGROUP
+CHARACTER(LEN=*) :: HFILEDIA,HLUOUTDIA
+END SUBROUTINE MENU_DIACHRO
+!
+END INTERFACE
+!
+END MODULE MODI_MENU_DIACHRO
+! ##################################################
+ SUBROUTINE MENU_DIACHRO(HFILEDIA,HLUOUTDIA,HGROUP)
+! ##################################################
+!
+!!**** *MENU_DIACHRO* - Creation, ecriture (eventuellement lecture) de
+! l'enregistrement MENU_BUDGET dans un fichier diachronique
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+! A chaque ecriture d'un enregistrement dans un fichier diachronique,
+! cette routine est appelee pour memoriser le nom du groupe correspon-
+! -dant (passe en argument dans HGROUP)
+! Au terme des ecritures, elle est appelee avec HGROUP='END' qui
+! a pour effet d'ecrire dans le fichier diachronique le tableau contenant
+! le nom des groupes avec l'identificateur de record : MENU_BUDGET
+! Quand HGROUP='READ', l'enregistrement MENU_BUDGET est lu et la
+! liste des groupes enregistres est imprimee
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/01/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+
+USE MODD_OUT_DIA
+USE MODI_FMREAD
+USE MODI_FMWRIT
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HGROUP
+CHARACTER(LEN=*) :: HFILEDIA, HLUOUTDIA
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+CHARACTER(LEN=16) :: YRECFM
+CHARACTER(LEN=20) :: YCOMMENT
+CHARACTER(LEN=16),DIMENSION(2000),SAVE :: YGROUP
+!CHARACTER(LEN=16),DIMENSION(5000),SAVE :: YGROUP ! dans le conv2dia.select
+INTEGER :: ILENG, ILENCH, IGRID, J, JJ, ILENDIM, IALREADY
+INTEGER :: IRESPDIA
+INTEGER,SAVE :: IGROUP=0
+INTEGER,DIMENSION(:),ALLOCATABLE :: ITABCHAR
+!------------------------------------------------------------------------------
+!
+IF(HGROUP == 'END')THEN
+
+ IF(IGROUP == 0)THEN
+ print *,' No record for the diachronic file'
+ RETURN
+ ENDIF
+ IGRID=0
+ ILENDIM=1
+ ILENG=16*IGROUP
+ ILENCH=LEN(YCOMMENT)
+ YRECFM='MENU_BUDGET.DIM'
+ CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENDIM,ILENG,&
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+
+ YRECFM='MENU_BUDGET'
+ ALLOCATE(ITABCHAR(ILENG))
+ DO JJ=1,IGROUP
+ DO J = 1,16
+ ITABCHAR(16*(JJ-1)+J) = ICHAR(YGROUP(JJ)(J:J))
+ ENDDO
+ ENDDO
+ CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ DEALLOCATE(ITABCHAR)
+
+ELSE IF(HGROUP == 'READ')THEN
+
+ ILENDIM=1
+ YRECFM='MENU_BUDGET.DIM'
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENDIM,ILENG,&
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IF(IRESPDIA == -47)THEN
+ print *,' No record MENU_BUDGET '
+ RETURN
+ ENDIF
+
+ ALLOCATE(ITABCHAR(ILENG))
+ YRECFM='MENU_BUDGET'
+ CALL FMREAD(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ IGRID,ILENCH,YCOMMENT,IRESPDIA)
+ IGROUP=ILENG/16
+ DO JJ=1,IGROUP
+ DO J = 1,16
+ YGROUP(JJ)(J:J)=CHAR(ITABCHAR(16*(JJ-1)+J))
+ ENDDO
+ ENDDO
+ DO JJ=1,IGROUP
+ WRITE(NLUOUTD,*)' ******** YGROUP : ',YGROUP(JJ)
+ !print *,' ******** YGROUP : ',YGROUP(JJ)
+ ENDDO
+ print *,'****************************** GROUPS *****************************'
+ print 100,(YGROUP(JJ),JJ=1,IGROUP)
+100 FORMAT(1X,5A15)
+ DEALLOCATE(ITABCHAR)
+
+ELSE
+
+ IALREADY=0
+ IF(IGROUP > 1)THEN
+ DO JJ=1,IGROUP
+ IF(ADJUSTL(HGROUP) == YGROUP(JJ))IALREADY=1
+ ENDDO
+ ENDIF
+ IF(IALREADY == 0)THEN
+ IGROUP=IGROUP+1
+ YGROUP(IGROUP)=ADJUSTL(HGROUP)
+ ENDIF
+ENDIF
+!
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE MENU_DIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/mode_io.f90 b/LIBTOOLS/tools/diachro/src/mesonh/mode_io.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a6c32bddfb3648dce036e1bc9acea2efe60feef7
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/mode_io.f90
@@ -0,0 +1,17 @@
+FUNCTION UPCASE(HSTRING)
+CHARACTER(LEN=*) :: HSTRING
+CHARACTER(LEN=LEN(HSTRING)) :: UPCASE
+
+INTEGER :: JC
+INTEGER, PARAMETER :: IAMIN = IACHAR("a")
+INTEGER, PARAMETER :: IAMAJ = IACHAR("A")
+
+DO JC=1,LEN(HSTRING)
+ IF (HSTRING(JC:JC) >= "a" .AND. HSTRING(JC:JC) <= "z") THEN
+ UPCASE(JC:JC) = ACHAR(IACHAR(HSTRING(JC:JC)) - IAMIN + IAMAJ)
+ ELSE
+ UPCASE(JC:JC) = HSTRING(JC:JC)
+ END IF
+END DO
+
+END FUNCTION UPCASE
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/set_dim.f90 b/LIBTOOLS/tools/diachro/src/mesonh/set_dim.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d0ff832147e3712d038904984527204073fc77be
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/set_dim.f90
@@ -0,0 +1,237 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/mesonh/sources/init/s.set_dim.f90, Version:1.9, Date:98/06/23, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODI_SET_DIM
+! ###################
+!
+INTERFACE
+!
+SUBROUTINE SET_DIM(HINIFILE,HLUOUT,KIINF,KISUP,KJINF,KJSUP, &
+ KIMAX,KJMAX,KKMAX)
+CHARACTER (LEN=*), INTENT(IN) :: HINIFILE ! Name of the initial file
+CHARACTER (LEN=*), INTENT(IN) :: HLUOUT ! name for output-listing
+ ! of nested models
+INTEGER, INTENT(INOUT) :: KIINF ! Lower bound in x direction of the
+ ! arrays in Initialization or in
+ ! Post-processing subroutines
+INTEGER, INTENT(INOUT) :: KISUP ! Upper bound in x direction of the
+ ! arraysin Initialization or in
+ ! Post-processing subroutines
+INTEGER, INTENT(INOUT) :: KJINF ! Lower bound in y direction of the
+ ! arrays in Initialization or in
+ ! Post-processing subroutines
+INTEGER, INTENT(INOUT) :: KJSUP ! Upper bound in y direction of the
+ ! arraysin Initialization or in
+ ! Post-processing subroutines
+INTEGER, INTENT(OUT) :: KIMAX ! Dimension in x direction of the
+ ! arrays stored in LFIFM file
+INTEGER, INTENT(OUT) :: KJMAX ! Dimension in y direction of the
+ ! arrays stored in LFIFM file
+INTEGER, INTENT(OUT) :: KKMAX ! Dimension in z direction of the
+ ! arrays stored in LFIFM file
+END SUBROUTINE SET_DIM
+!
+END INTERFACE
+!
+END MODULE MODI_SET_DIM
+!
+!
+!
+! ##############################################################
+ SUBROUTINE SET_DIM(HINIFILE,HLUOUT,KIINF,KISUP,KJINF,KJSUP, &
+ KIMAX,KJMAX,KKMAX)
+! ##############################################################
+!
+!!**** *SET_DIM* - routine to set model dimensions
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to set dimensions of the model
+!
+!
+!!** METHOD
+!! ------
+!! The dimensions KIMAX,KJMAX,KKMAX are read in initial file.
+!! Then, the horizontal dimensions of arrays are deduced :
+!! - If it is a segment achievement configuration (CCONF='START' or
+!! 'RESTA'), the horizontal dimensions of the arrays are :
+!! KIINF=1, KISUP=KIMAX+2*JPHEXT
+!! KJINF=1, KJSUP=KJMAX+2*JPHEXT
+!! - If it is a postprocessing configuration (CCONF='POSTP'),
+!! an horizontal window is possible ; KIINF, KISUP,
+!! KJINF,KJSUP are the values read in EXSEG file, except when :
+!! * KIINF is greater than KIMAX + 2*JPHEXT . Then it is set
+!! equal to KIMAX + 2*JPHEXT
+!! * KISUP is greater than KIMAX + 2*JPHEXT . Then it is set
+!! equal to KIMAX + 2*JPHEXT
+!! * KJINF is greater than KJMAX + 2*JPHEXT . Then it is set
+!! equal to KJMAX + 2*JPHEXT
+!! * KJSUP is greater than KJMAX + 2*JPHEXT . Then it is set
+!! equal to KJMAX + 2*JPHEXT
+!! * KIINF or KISUP is less or equal to zero. It means that there
+!! is no window in x direction. Then, KIINF is set equal to 1 and KISUP
+!! is set equal to KIMAX + 2*JPHEXT.
+!! * KJINF or KJSUP is less or equal to zero. It means that there
+!! is no window in x direction. Then, KJINF is set equal to 1 and KJSUP
+!! is set equal to KJMAX + 2*JPHEXT.
+!!
+!!
+!!
+!! EXTERNAL
+!! --------
+!! FMREAD : to read data in LFIFM file
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS : contains declaration of parameter variables
+!!
+!! JPHEXT : Horizontal external points number
+!! JPVEXT : Vertical external points number
+!!
+!! Module MODD_CONF : contains declaration of configuration variables
+!!
+!! CCONF : configuration of models
+!! 'START' for start configuration
+!! 'RESTA' for restart configuration
+!! 'POSTP' for post-processing configuration
+!! NVERB : Level of informations on output-listing
+!! 0 for minimum prints
+!! 5 for intermediate level of prints
+!! 10 for maximum prints
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine SET_DIM)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 14/06/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+USE MODD_PARAMETERS
+USE MODD_CONF
+!
+USE MODI_FMREAD
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of argument
+!
+CHARACTER (LEN=*), INTENT(IN) :: HINIFILE ! Name of the initial file
+CHARACTER (LEN=*), INTENT(IN) :: HLUOUT ! name for output-listing
+ ! of nested models
+INTEGER, INTENT(INOUT) :: KIINF ! Lower bound in x direction of the
+ ! arrays in Initialization or in
+ ! Post-processing subroutines
+INTEGER, INTENT(INOUT) :: KISUP ! Upper bound in x direction of the
+ ! arraysin Initialization or in
+ ! Post-processing subroutines
+INTEGER, INTENT(INOUT) :: KJINF ! Lower bound in y direction of the
+ ! arrays in Initialization or in
+ ! Post-processing subroutines
+INTEGER, INTENT(INOUT) :: KJSUP ! Upper bound in y direction of the
+ ! arraysin Initialization or in
+ ! Post-processing subroutines
+INTEGER, INTENT(OUT) :: KIMAX ! Dimension in x direction of
+ ! the physical part of the
+ ! arrays stored in LFIFM file
+INTEGER, INTENT(OUT) :: KJMAX ! Dimension in y direction of the
+ ! physical part of the
+ ! arrays stored in LFIFM file
+INTEGER, INTENT(OUT) :: KKMAX ! Dimension in z direction of the
+ ! physical part of the
+ ! arrays stored in LFIFM file
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: ILENG,IGRID,ILENCH,IRESP ! File
+CHARACTER (LEN=16) :: YRECFM ! management
+CHARACTER (LEN=100) :: YCOMMENT ! variables
+INTEGER :: ILUOUT ! Logical unit number for
+ ! output-listing
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. READ DIMENSIONS OF ARRAYS IN LFIFM FILE
+! ---------------------------------------
+!
+YRECFM='IMAX'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,KIMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='JMAX'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,KJMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='KMAX'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,KKMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. SET DIMENSIONS FOR ARRAY IN INITIALIZATION OR POST-PROCESSING
+! -------------------------------------------------------------
+!
+IF (CCONF == 'POSTP') THEN
+!
+ IF ((KIINF <= 0).OR.(KISUP <= 0)) THEN ! this condition corresponds to a
+ KIINF = 1 ! post-processing case where the whole
+ KISUP = KIMAX + 2*JPHEXT ! simulation domain must be considered
+ ! along the x direction
+ ELSE
+ KIINF = MIN(KIINF,KIMAX+2*JPHEXT) ! post-processing case with an
+ KISUP = MIN(KISUP,KIMAX+2*JPHEXT) ! explicit window
+ END IF
+!
+ IF ((KJINF <= 0 ).OR.(KJSUP <= 0 )) THEN
+ KJINF = 1
+ KJSUP = KJMAX + 2* JPHEXT
+ ELSE
+ KJINF = MIN(KJINF,KJMAX+2*JPHEXT)
+ KJSUP = MIN(KJSUP,KJMAX+2*JPHEXT)
+ END IF
+!
+ELSE
+!
+ KIINF = 1 ! case corresponding to a simulation
+ KISUP = KIMAX + 2* JPHEXT
+ KJINF = 1
+ KJSUP = KJMAX+ 2* JPHEXT
+!
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. PRINT DIMENSIONS ON OUTPUT_LISTING
+! ----------------------------------
+!
+CALL FMLOOK(HLUOUT,HLUOUT,ILUOUT,IRESP)
+IF(KIINF > KISUP) THEN
+ WRITE(UNIT=ILUOUT,FMT="(' THE PROGRAM STOPS IN THE SET_DIM SUBROUTINE ',/,&
+ & 'BECAUSE THE WINDOW BOUNDS ARE NOT CONSISTENT ',/, &
+ & 'KIINF =',I5,' KISUP =',I5,' KJINF =',I5,' KJSUP =',I5)") &
+ KIINF,KISUP,KJINF,KJSUP
+ STOP
+END IF
+!
+IF (NVERB >= 5) THEN
+ WRITE(UNIT=ILUOUT,FMT="(' DIMENSIONS INITIALIZED BY SET_GRID :',/, &
+ & 'KIMAX =',I5,' KJMAX =',I5,' KKMAX =',I5,/, &
+ & 'KIINF =',I5,' KISUP =',I5,' KJINF =',I5,' KJSUP =',I5)") &
+ KIMAX,KJMAX,KKMAX,KIINF,KISUP,KJINF,KJSUP
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE SET_DIM
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/set_grid.f90 b/LIBTOOLS/tools/diachro/src/mesonh/set_grid.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c8fa0fe5dd7df6e74af4f71be531c755f1652a6d
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/set_grid.f90
@@ -0,0 +1,672 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/init/s.set_grid.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ####################
+ MODULE MODI_SET_GRID
+! ####################
+!
+INTERFACE
+!
+ SUBROUTINE SET_GRID(KMI,HINIFILE,HLUOUT, &
+ KIU,KJU,KKU,KIINF,KISUP,KJINF,KJSUP, &
+ PTSTEP,PSEGLEN, &
+ POUT1,POUT2,POUT3,POUT4,POUT5,POUT6,POUT7,POUT8, &
+ POUT9,POUT10,POUT11,POUT12,POUT13,POUT14,POUT15, &
+ POUT16,POUT17,POUT18,POUT19,POUT20, &
+ PLONOR,PLATOR,PLON,PLAT, &
+ PXHAT,PYHAT,PDXHAT,PDYHAT, PMAP, &
+ PZS,PZZ,PZHAT, &
+ PJ, &
+ TPDTMOD,TPDTCUR,KSTOP,KOUT_TIMES,KOUT_NUMB)
+!
+USE MODE_TIME
+!
+INTEGER, INTENT(IN) :: KMI ! Model index
+CHARACTER (LEN=*), INTENT(IN) :: HINIFILE ! Name of the initial file
+CHARACTER (LEN=*), INTENT(IN) :: HLUOUT ! name for output-listing
+ ! of nested models
+INTEGER, INTENT(IN) :: KIU ! Upper dimension in x direction
+ ! for arrays in initial file
+INTEGER, INTENT(IN) :: KJU ! Upper dimension in y direction
+ ! for arrays in initial file
+INTEGER, INTENT(IN) :: KKU ! Upper dimension in z direction
+ ! for arrays in initial file
+INTEGER, INTENT(IN) :: KIINF,KISUP
+ ! Lower and upper dimensions
+ ! in x direction for working
+ ! window
+INTEGER, INTENT(IN) :: KJINF,KJSUP
+ ! Lower and upper dimensions
+ ! in y direction for working
+ ! window
+REAL, INTENT(IN) :: PTSTEP ! time step of model KMI
+REAL, INTENT(INOUT) :: PSEGLEN ! segment duration (in seconds)
+REAL, INTENT(INOUT) :: POUT1,POUT2,POUT3,POUT4,POUT5,POUT6,POUT7,POUT8
+REAL, INTENT(INOUT) :: POUT9,POUT10,POUT11,POUT12,POUT13,POUT14,POUT15
+REAL, INTENT(INOUT) :: POUT16,POUT17,POUT18,POUT19,POUT20
+! increments in seconds from the beginning of the segment to the
+! instant where the n-th fields output on FM-files is realized
+!
+REAL, INTENT(OUT) :: PLONOR ! Longitude of the
+ ! Origine point for the
+ ! conformal projection
+REAL, INTENT(OUT) :: PLATOR ! Latitude of the
+ ! Origine point for the
+ ! conformal projectio
+REAL, DIMENSION(:,:), INTENT(OUT) :: PLON,PLAT ! Longitude and latitude
+REAL, DIMENSION(:), INTENT(OUT) :: PXHAT ! Position x in the conformal
+ ! plane or on the cartesian plane
+REAL, DIMENSION(:), INTENT(OUT) :: PYHAT ! Position y in the conformal
+ ! plane or on the cartesian plane
+REAL, DIMENSION(:), INTENT(OUT) :: PDXHAT ! horizontal stretching in x
+REAL, DIMENSION(:), INTENT(OUT) :: PDYHAT ! horizontal stretching in y
+REAL, DIMENSION(:,:), INTENT(OUT) :: PMAP ! Map factor
+!
+REAL, DIMENSION(:,:), INTENT(OUT) :: PZS ! orography
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PZZ ! Height z
+REAL, DIMENSION(:), INTENT(OUT) :: PZHAT ! Height level
+!
+TYPE (DATE_TIME), INTENT(OUT) :: TPDTMOD ! date and time of the model
+ ! beginning
+TYPE (DATE_TIME), INTENT(OUT) :: TPDTCUR ! Current date and time
+INTEGER, INTENT(OUT) :: KSTOP ! number of time steps for
+ ! current segment
+INTEGER, DIMENSION(:), INTENT(OUT) :: KOUT_TIMES ! list of the values
+ ! of the temporal index in the temporal model loop where fields
+ ! outputs on FM-files are realized
+INTEGER, INTENT(OUT) :: KOUT_NUMB ! number of outputs
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PJ ! Jacobian
+!
+END SUBROUTINE SET_GRID
+!
+END INTERFACE
+!
+END MODULE MODI_SET_GRID
+!
+!
+! #########################################################################
+ SUBROUTINE SET_GRID(KMI,HINIFILE,HLUOUT, &
+ KIU,KJU,KKU,KIINF,KISUP,KJINF,KJSUP, &
+ PTSTEP,PSEGLEN, &
+ POUT1,POUT2,POUT3,POUT4,POUT5,POUT6,POUT7,POUT8, &
+ POUT9,POUT10,POUT11,POUT12,POUT13,POUT14,POUT15, &
+ POUT16,POUT17,POUT18,POUT19,POUT20, &
+ PLONOR,PLATOR,PLON,PLAT, &
+ PXHAT,PYHAT,PDXHAT,PDYHAT, PMAP, &
+ PZS,PZZ,PZHAT, &
+ PJ, &
+ TPDTMOD,TPDTCUR,KSTOP,KOUT_TIMES,KOUT_NUMB)
+! #########################################################################
+!
+!!**** *SET_GRID* - routine to set grid variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to set spatio-temporal grid variables
+!
+!!** METHOD
+!! ------
+!!
+!! The spatial grid variables are read in initial file :
+!! * The reference latitude (XLAT0), the reference longitude (XLON0) and
+!! the projection parameter (XPRPK) are read if spherical geometry is used.
+!! (LCARTESIAN=.FALSE.) and only at the first call (by INI_MODEL1,i.e. KMI=1),
+!! since it is the same for all nested models.
+!! * The rotation angle (XBETA) is read only at the first call for the
+!! same reason.
+!! * The latitude and longitude of the origine points (XLATOR and XLONOR)
+!! are read for a spherical geometry (LCARTESIAN=.FALSE.).
+!! * The horizontal positions (PXHAT and PYHAT) are always read.
+!! * The orography (PZS) is set equal to zero if zero orography is needed
+!! (LFLAT=.TRUE.), else it is read in initial file.
+!!
+!! The temporal grid variables are read in initial file :
+!! * The number of time steps for the current segment depends on the time step
+!! PTSTEP and on the segment length PSEGLEN plus one time step of the first
+!! model for all models.
+!! * The time of the beginning of experiment (TDTEXP of type DATE_TIME)
+!! is read only at the first call by INI_MODEL1 (KMI=1),
+!! since it is the same for all nested models.
+!! * The times of the beginning of model (TPDTMOD of type DATE_TIME),
+!! of beginning of segment (TPDTSEG of type DATE_TIME) are read for
+!! all models
+!!
+!! Then, the other spatial grid variables are deduced :
+!! * If Cartesian geometry (LCARTESIAN=.TRUE.), SM_GRIDCART computes
+!! the horizontal stretchings (PDXHAT and PDYHAT) the height (PZZ) and the
+!! Jacobian (PJ).
+!! * if Spherical geometry (LCARTESIAN=.FALSE.), SM_GRIDPROJ computes
+!! the horizontal stretchings (PDXHAT and PDYHAT) the height (PZZ), the
+!! Jacobian (PJ), the map factor (PMAP), the latitude (PLAT) and the
+!! longitude (PLON).
+!!
+!! and the other temporal grid variables are deduced :
+!! The current time (TPDTCUR of type DATE_TIME) is set equal to the time
+!! of beginning of segment.
+!!
+!! IF verbose option (NVERB >=5), the time is printed on output-listing
+!! EXTERNAL
+!! --------
+!! FMREAD : to read data in LFIFM file
+!! FMLOOK : to retrieve a logical unit number
+!!
+!! Module MODE_GRIDPROJ : contains conformal projection routines
+!! SM_GRIDPROJ : to compute some grid variables in case of conformal
+!! projection
+!! SM_LATLON : to compute latitude and longitude, giving the
+!! positions on the grid
+!! Module MODE_GRIDCART : contains cartesian geometry routines
+!! SM_GRIDCART : to compute some grid_variables in case of cartesian
+!! geometry
+!! Module MODE_TIME : contains SM_PRINT_TIME routine
+!! and uses module MODD_TIME (for definition
+!! of types DATE_TIME and DATE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! Module MODD_CONF : contains declaration of configuration variables
+!! for all models
+!! CCONF : Configuration for all models ( START, RESTART or POST)
+!! LCARTESIAN : Logical for cartesian geometry
+!! .TRUE. = cartesian geometry
+!! LFLAT : Logical for zero ororography
+!! .TRUE. = no orography (zs=0.)
+!! NVERB : Level of informations on output-listing
+!! 0 for minimum prints
+!! 5 for intermediate level of prints
+!! 10 for maximum prints
+!! CSTORAGE_TYPE : type of stored informations ( 2 or one instant)
+!!
+!!
+!! Module MODD_GRID : contains spatial grid variables for all model
+!!
+!! XLON0 : Reference longitude for the conformal projection
+!! XLAT0 : Reference latitude
+!! XBETA : Rotation angle
+!! XRPK : Projection parameter for the conformal projection
+!!
+!! Module MODE_TIME : uses module MODD_TIME (contains temporal grid
+!! variables for all model
+!! TDTEXP : Date and time for the experiment beginning
+!! TDTSEG : Date and time for the segment beginning
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine SET_GRID)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 30/06/94
+!! J. STEIN 02/01/95 correct the TPDTCUR initialization
+!! J. STEIN 26/01/95 read TPDTCUR in the FM-file
+!! J. STEIN 16/03/95 bug in the TPDTCUR reading
+!! J. STEIN 16/04/95 another bug in the TPDTCUR initialization
+!! J. STEIN 03/01/96 change the temporal grid
+!! J. STEIN P.JABOUILLE 30/04/96 add the storage-type reading
+!! J. STEIN 25/05/96 read RPK only in the non-cartesian case
+!! J.P. LAFORE 03/07/97 gridnesting implementation
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+USE MODD_PARAMETERS
+USE MODD_CONF
+USE MODD_GRID
+USE MODD_BUDGET
+USE MODD_DYN
+USE MODD_FMOUT
+USE MODD_NESTING
+!
+USE MODE_GRIDCART
+USE MODE_GRIDPROJ
+USE MODE_TIME
+!
+USE MODI_FMREAD
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of argument
+!
+INTEGER, INTENT(IN) :: KMI ! Model index
+CHARACTER (LEN=*), INTENT(IN) :: HINIFILE ! Name of the initial file
+CHARACTER (LEN=*), INTENT(IN) :: HLUOUT ! name for output-listing
+ ! of nested models
+INTEGER, INTENT(IN) :: KIU ! Upper dimension in x direction
+ ! for arrays in initial file
+INTEGER, INTENT(IN) :: KJU ! Upper dimension in y direction
+ ! for arrays in initial file
+INTEGER, INTENT(IN) :: KKU ! Upper dimension in z direction
+ ! for arrays in initial file
+INTEGER, INTENT(IN) :: KIINF,KISUP
+ ! Lower and upper dimensions
+ ! in x direction for working
+ ! window
+INTEGER, INTENT(IN) :: KJINF,KJSUP
+ ! Lower and upper dimensions
+ ! in y direction for working
+ ! window
+REAL, INTENT(IN) :: PTSTEP ! time step of model KMI
+REAL, INTENT(INOUT) :: PSEGLEN ! segment duration (in seconds)
+REAL, INTENT(INOUT) :: POUT1,POUT2,POUT3,POUT4,POUT5,POUT6,POUT7,POUT8
+REAL, INTENT(INOUT) :: POUT9,POUT10,POUT11,POUT12,POUT13,POUT14,POUT15
+REAL, INTENT(INOUT) :: POUT16,POUT17,POUT18,POUT19,POUT20
+! increments in seconds from the beginning of the segment to the
+! instant where the n-th fields output on FM-files is realized
+!
+REAL, INTENT(OUT) :: PLONOR ! Longitude of the
+ ! Origine point for the
+ ! conformal projection
+REAL, INTENT(OUT) :: PLATOR ! Latitude of the
+ ! Origine point for the
+ ! conformal projectio
+REAL, DIMENSION(:,:), INTENT(OUT) :: PLON,PLAT ! Longitude and latitude
+REAL, DIMENSION(:), INTENT(OUT) :: PXHAT ! Position x in the conformal
+ ! plane or on the cartesian plane
+REAL, DIMENSION(:), INTENT(OUT) :: PYHAT ! Position y in the conformal
+ ! plane or on the cartesian plane
+REAL, DIMENSION(:), INTENT(OUT) :: PDXHAT ! horizontal stretching in x
+REAL, DIMENSION(:), INTENT(OUT) :: PDYHAT ! horizontal stretching in y
+REAL, DIMENSION(:,:), INTENT(OUT) :: PMAP ! Map factor
+!
+REAL, DIMENSION(:,:), INTENT(OUT) :: PZS ! orography
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PZZ ! Height z
+REAL, DIMENSION(:), INTENT(OUT) :: PZHAT ! Height level
+!
+TYPE (DATE_TIME), INTENT(OUT) :: TPDTMOD ! date and time of the model
+ ! beginning
+TYPE (DATE_TIME), INTENT(OUT) :: TPDTCUR ! Current date and time
+INTEGER, INTENT(OUT) :: KSTOP ! number of time steps for
+ ! current segment
+INTEGER, DIMENSION(:), INTENT(OUT) :: KOUT_TIMES ! list of the values
+ ! of the temporal index in the temporal model loop where fields
+ ! outputs on FM-files are realized
+INTEGER, INTENT(OUT) :: KOUT_NUMB ! number of outputs
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PJ ! Jacobian
+!
+!* 0.2 declarations of local variables
+!
+REAL, DIMENSION(KIU) :: Z1DI ! 1D array (x direction) used
+ ! to read data in inital file
+REAL, DIMENSION(KJU) :: Z1DJ ! 1D array (y direction) used
+ ! to read data in inital file
+REAL :: ZXHATM,ZYHATM ! coordinates of mass point
+ ! (KIINF,KJINF)
+REAL :: ZLATORNEW,ZLONORNEW ! geographical coordinates
+ ! of mass point (KIINF,KJINF)
+REAL, DIMENSION(KIU,KJU) :: Z2D ! 2D array (x,y directions) used
+ ! to read data in inital file
+INTEGER :: I2D ! size of 2D arrays
+INTEGER :: ILENG,IGRID,ILENCH,IRESP ! File
+CHARACTER (LEN=16) :: YRECFM ! management
+CHARACTER (LEN=100) :: YCOMMENT ! variables
+INTEGER, DIMENSION(3) :: ITDATE ! date array
+CHARACTER (LEN=40) :: YTITLE ! Title for date print
+INTEGER :: ILUOUT ! Logical unit number for
+ ! output-listing
+INTEGER :: JKLOOP,JOUT ! Loop index
+INTEGER :: IIUP,IJUP ,ISUP=1 ! size of working
+ ! window arrays,
+ ! supp. time steps
+INTEGER, DIMENSION(2) :: ISTORAGE_TYPE ! integer values of the
+ ! ASCII codes for CSTORAGE_TYPE
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. READ GRID VARIABLES IN INITIAL FILE
+! ------------------------------------
+!
+!* 1.1 Spatial grid
+!
+IF (KMI == 1) THEN
+ YRECFM='STORAGE_TYPE'
+ ILENG=2
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ISTORAGE_TYPE,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF (IRESP == 0) THEN
+ CSTORAGE_TYPE(1:1)=ACHAR(ISTORAGE_TYPE(1))
+ CSTORAGE_TYPE(2:2)=ACHAR(ISTORAGE_TYPE(2))
+ ELSE
+ CSTORAGE_TYPE='MT'
+ END IF
+ !
+ YRECFM='LON0' ! this parameter is also useful in the cartesian to
+ ILENG=1 ! compute the sun position for the radiation scheme
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XLON0,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='LAT0' ! this parameter is also useful in the cartesian to
+ ILENG=1 ! compute the Coriolis parameter
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XLAT0,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='BETA' ! this parameter is also useful in the cartesian to
+ ILENG=1 ! rotate the simulatin domain
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XBETA,IGRID,ILENCH,YCOMMENT,IRESP)
+END IF
+!
+IF (.NOT.LCARTESIAN) THEN
+ !
+ YRECFM='RPK'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XRPK,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='LONOR'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,PLONOR,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='LATOR'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,PLATOR,IGRID,ILENCH,YCOMMENT,IRESP)
+END IF
+YRECFM='XHAT'
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,KIU,Z1DI,IGRID,ILENCH,YCOMMENT,IRESP)
+PXHAT(:)=Z1DI(KIINF:KISUP)
+YRECFM='YHAT'
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,KJU,Z1DJ,IGRID,ILENCH,YCOMMENT,IRESP)
+PYHAT(:)=Z1DJ(KJINF:KJSUP)
+!
+! in case of postprocessing working window, compute new PLATOR,PLONOR
+! i.e. latitude and longitude of mass point (KIINF,KJINF)
+IF (.NOT.LCARTESIAN) THEN
+ IF ((KIINF /= 1).OR.(KJINF /= 1)) THEN
+ ZXHATM =0.5 * (PXHAT(1)+PXHAT(2))
+ ZYHATM =0.5 * (PYHAT(1)+PYHAT(2))
+ CALL SM_LATLON(Z1DI,Z1DJ,PLATOR,PLONOR,ZXHATM,ZYHATM,ZLATORNEW,ZLONORNEW)
+ PLATOR = ZLATORNEW
+ PLONOR = ZLONORNEW
+ END IF
+END IF
+!
+IF (LFLAT) THEN
+ PZS(:,:) = 0.
+ELSE
+ YRECFM='ZS'
+ I2D=KIU*KJU
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,I2D,Z2D,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF(IRESP /= 0)THEN
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,I2D/3,Z2D(:,2),IGRID,ILENCH,YCOMMENT,IRESP)
+ IF(IRESP == 0)THEN
+ Z2D(:,1)=Z2D(:,2)
+ Z2D(:,3)=Z2D(:,2)
+ PZS(:,:) = Z2D(KIINF:KISUP,KJINF:KJSUP)
+ ELSE
+ PZS(:,:) = 0.
+ ENDIF
+ ELSE
+! print *,' SET_GRID KIINF,KISUP,KJINF,KJSUP ',KIINF,KISUP,KJINF,KJSUP
+! print *,' SET_GRID size Z2D et PZS ',size(Z2D,1),size(Z2D,2),size(PZS,1),size(PZS,2)
+ PZS(:,:) = Z2D(KIINF:KISUP,KJINF:KJSUP)
+ ENDIF
+END IF
+YRECFM='ZHAT'
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,KKU,PZHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+!* 1.2 Temporal grid
+!
+IF (KMI == 1) THEN
+ YRECFM='DTEXP%TDATE'
+ ILENG=3
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+ TDTEXP%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+ YRECFM='DTEXP%TIME'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,TDTEXP%TIME,IGRID,ILENCH, &
+ YCOMMENT,IRESP)
+END IF
+!
+YRECFM='DTCUR%TDATE'
+ILENG=3
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+TPDTCUR%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+YRECFM='DTCUR%TIME'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,TPDTCUR%TIME,IGRID,ILENCH, &
+ YCOMMENT,IRESP)
+!
+YRECFM='DTMOD%TDATE'
+ILENG=3
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+TPDTMOD%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+YRECFM='DTMOD%TIME'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,TPDTMOD%TIME,IGRID,ILENCH, &
+ YCOMMENT,IRESP)
+!
+YRECFM='DTSEG%TDATE'
+ILENG=3
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+TDTSEG%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+YRECFM='DTSEG%TIME'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,TDTSEG%TIME,IGRID,ILENCH, &
+ YCOMMENT,IRESP)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. SET OTHER GRID VARIABLES
+! ------------------------
+!
+!
+!* 2.1 Spatial grid
+!
+IF (LCARTESIAN) THEN
+ CALL SM_GRIDCART(HLUOUT,PXHAT,PYHAT,PZHAT,PZS,PDXHAT,PDYHAT,PZZ,PJ)
+ELSE
+ CALL SM_GRIDPROJ(HLUOUT,PXHAT,PYHAT,PZHAT,PZS,PLATOR,PLONOR, &
+ PMAP,PLAT,PLON,PDXHAT,PDYHAT,PZZ,PJ)
+END IF
+!
+!* 2.2 Temporal grid - segment length
+!
+TDTSEG = TPDTCUR
+ISUP = 1 ! 1 corresponds to a last timestep
+ ! to obtain the prognostic and diagnostic fields all along this timestep
+!
+KOUT_TIMES(:) = -999
+!
+IF ( KMI == 1) PSEGLEN = PSEGLEN + PTSTEP*ISUP ! needed for the gridnesting case to get
+ ! the same PSEGLEN for all nested models
+KSTOP = NINT(PSEGLEN/PTSTEP)
+!
+!
+!* 2.3 Temporal grid - outputs managment
+!
+!* 2.3.1 a) synchronization between nested models through XFMOUT arrays (MODD_FMOUT)
+!
+DO JOUT = 1,20
+ IF (XFMOUT(KMI,JOUT) /= -999.) THEN
+ XFMOUT(KMI,JOUT) = NINT(XFMOUT(KMI,JOUT)/PTSTEP) * PTSTEP
+ DO JKLOOP = KMI,JPMODELMAX
+ XFMOUT(JKLOOP,JOUT) = XFMOUT(KMI,JOUT)
+ END DO
+ END IF
+END DO
+!
+!* 2.3.2 b) back to original XOUT variables (MODD_OUTn)
+!
+POUT1 = XFMOUT(KMI,1 )
+POUT2 = XFMOUT(KMI,2 )
+POUT3 = XFMOUT(KMI,3 )
+POUT4 = XFMOUT(KMI,4 )
+POUT5 = XFMOUT(KMI,5 )
+POUT6 = XFMOUT(KMI,6 )
+POUT7 = XFMOUT(KMI,7 )
+POUT8 = XFMOUT(KMI,8 )
+POUT9 = XFMOUT(KMI,9 )
+POUT10 = XFMOUT(KMI,10)
+POUT11 = XFMOUT(KMI,11)
+POUT12 = XFMOUT(KMI,12)
+POUT13 = XFMOUT(KMI,13)
+POUT14 = XFMOUT(KMI,14)
+POUT15 = XFMOUT(KMI,15)
+POUT16 = XFMOUT(KMI,16)
+POUT17 = XFMOUT(KMI,17)
+POUT18 = XFMOUT(KMI,18)
+POUT19 = XFMOUT(KMI,19)
+POUT20 = XFMOUT(KMI,20)
+!
+KOUT_NUMB =0
+!
+IF(POUT1 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT1/PTSTEP) + 1
+END IF
+!
+IF(POUT2 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT2/PTSTEP) + 1
+END IF
+!
+IF(POUT3 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT3/PTSTEP) + 1
+END IF
+!
+IF(POUT4 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT4/PTSTEP) + 1
+END IF
+!
+IF(POUT5 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT5/PTSTEP) + 1
+END IF
+!
+IF(POUT6 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT6/PTSTEP) + 1
+END IF
+!
+IF(POUT7 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT7/PTSTEP) + 1
+END IF
+!
+IF(POUT8 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT8/PTSTEP) + 1
+END IF
+!
+IF(POUT9 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT9/PTSTEP) + 1
+END IF
+!
+IF(POUT10 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT10/PTSTEP) + 1
+END IF
+!
+IF(POUT11 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT11/PTSTEP) + 1
+END IF
+!
+IF(POUT12 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT12/PTSTEP) + 1
+END IF
+!
+IF(POUT13 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT13/PTSTEP) + 1
+END IF
+!
+IF(POUT14 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT14/PTSTEP) + 1
+END IF
+!
+IF(POUT15 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT15/PTSTEP) + 1
+END IF
+!
+IF(POUT16 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT16/PTSTEP) + 1
+END IF
+!
+IF(POUT17 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT17/PTSTEP) + 1
+END IF
+!
+IF(POUT18 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT18/PTSTEP) + 1
+END IF
+!
+IF(POUT19 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT19/PTSTEP) + 1
+END IF
+!
+IF(POUT20 /= -999.) THEN
+ KOUT_NUMB = KOUT_NUMB + 1
+ KOUT_TIMES(KOUT_NUMB) = NINT(POUT20/PTSTEP) + 1
+END IF
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. PRINT ON OUTPUT-LISTING
+! -----------------------
+!
+CALL FMLOOK(HLUOUT,HLUOUT,ILUOUT,IRESP)
+IF (NVERB >= 10) THEN
+ IIUP = SIZE(PXHAT)
+ IJUP = SIZE(PYHAT)
+ WRITE(ILUOUT,*) ' SET_GRID : XLON0 = ', XLON0,' XLAT0 = ',XLAT0, &
+ ' XRPK = ',XRPK,' XBETA = ',XBETA,' PLONOR = ',PLONOR, &
+ ' PLATOR = ' , PLATOR
+ IF(LCARTESIAN) THEN
+ WRITE(ILUOUT,*) 'SET_GRID : No map projection used.'
+ ELSE
+ IF (XRPK == 1.) THEN
+ WRITE(ILUOUT,*) 'SET_GRID : Polar stereo used.'
+ ELSE IF (XRPK == 0.) THEN
+ WRITE(ILUOUT,*) 'SET_GRID : Mercator used.'
+ ELSE
+ WRITE(ILUOUT,*) 'SET_GRID : Lambert used, cone factor=',XRPK
+ END IF
+ END IF
+ WRITE(ILUOUT,*) ' SET_GRID : Some PXHAT values:'
+ WRITE(ILUOUT,*) ' I= 1 I=IIU/2 I=IIU'
+ WRITE(ILUOUT,*) PXHAT(1),PXHAT(IIUP/2),PXHAT(IIUP)
+!
+ WRITE(ILUOUT,*) ' SET_GRID : Some PYHAT values:'
+ WRITE(ILUOUT,*) ' I= 1 I=IIU/2 I=IIU'
+ WRITE(ILUOUT,*) PYHAT(1),PYHAT(IJUP/2),PYHAT(IJUP)
+!
+ WRITE(ILUOUT,*) ' SET_GRID : Some PZHAT values:'
+ WRITE(ILUOUT,*) ' I= 1 I=IIU/2 I=IIU'
+ WRITE(ILUOUT,*) PZHAT(1),PZHAT(KKU/2),PZHAT(KKU)
+!
+ WRITE(ILUOUT,*) ' SET_GRID : Some PZS values:'
+ WRITE(ILUOUT,*) ' I= 1 I=IIU/2 I=IIU'
+ WRITE(ILUOUT,*) PZS(1,1),PZS(IIUP/2,IJUP/2),PZS(IIUP,IJUP)
+!
+ YTITLE='CURRENT DATE AND TIME'
+ CALL SM_PRINT_TIME(TPDTCUR,HLUOUT,YTITLE)
+END IF
+IF (NVERB >= 5) THEN
+ YTITLE='DATE AND TIME OF EXPERIMENT BEGINNING'
+ CALL SM_PRINT_TIME(TDTEXP,HLUOUT,YTITLE)
+ YTITLE='DATE AND TIME OF MODEL BEGINNING'
+ CALL SM_PRINT_TIME(TPDTMOD,HLUOUT,YTITLE)
+END IF
+YTITLE='DATE AND TIME OF SEGMENT BEGINNING'
+CALL SM_PRINT_TIME(TDTSEG,HLUOUT,YTITLE)
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE SET_GRID
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/set_light_grid.f90 b/LIBTOOLS/tools/diachro/src/mesonh/set_light_grid.f90
new file mode 100644
index 0000000000000000000000000000000000000000..82dd1877c5bedc94df7f5e65a274fdadd119499e
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/set_light_grid.f90
@@ -0,0 +1,495 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+! ####################
+ MODULE MODI_SET_LIGHT_GRID
+! ####################
+!
+INTERFACE
+!
+ SUBROUTINE SET_LIGHT_GRID(KMI,HINIFILE,HLUOUT, &
+ KIU,KJU,KKU,KIMAX_ll,KJMAX_ll, &
+ PLONORI,PLATORI,PLON,PLAT, &
+ PXHAT,PYHAT,PDXHAT,PDYHAT, PMAP, &
+ PZS,PZZ,PZHAT,OSLEVE,PLEN1,PLEN2,PZSMT, &
+ PJ, &
+ TPDTMOD,TPDTCUR )
+!
+USE MODD_TYPE_DATE
+!
+INTEGER, INTENT(IN) :: KMI ! Model index
+CHARACTER (LEN=*), INTENT(IN) :: HINIFILE ! Name of the initial file
+CHARACTER (LEN=*), INTENT(IN) :: HLUOUT ! name for output-listing
+ ! of nested models
+INTEGER, INTENT(IN) :: KIU ! Upper dimension in x direction
+ ! for sub-domain arrays
+INTEGER, INTENT(IN) :: KJU ! Upper dimension in y direction
+ ! for sub-domain arrays
+INTEGER, INTENT(IN) :: KKU ! Upper dimension in z direction
+ ! for domain arrays
+INTEGER, INTENT(IN) :: KIMAX_ll ! Dimensions in x direction
+ ! of the physical domain,
+INTEGER, INTENT(IN) :: KJMAX_ll ! Dimensions in y direction
+ ! of the physical domain,
+!
+REAL, INTENT(OUT) :: PLONORI ! Longitude of the
+ ! Origine point of the
+ ! conformal projection
+REAL, INTENT(OUT) :: PLATORI ! Latitude of the
+ ! Origine point of the
+ ! conformal projection
+REAL, DIMENSION(:,:), INTENT(OUT) :: PLON,PLAT ! Longitude and latitude
+REAL, DIMENSION(:), INTENT(OUT) :: PXHAT ! Position x in the conformal
+ ! plane or on the cartesian plane
+REAL, DIMENSION(:), INTENT(OUT) :: PYHAT ! Position y in the conformal
+ ! plane or on the cartesian plane
+REAL, DIMENSION(:), INTENT(OUT) :: PDXHAT ! horizontal stretching in x
+REAL, DIMENSION(:), INTENT(OUT) :: PDYHAT ! horizontal stretching in y
+REAL, DIMENSION(:,:), INTENT(OUT) :: PMAP ! Map factor
+!
+REAL, DIMENSION(:,:), INTENT(OUT) :: PZS ! orography
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PZZ ! Height z
+REAL, DIMENSION(:), INTENT(OUT) :: PZHAT ! Height level
+LOGICAL, INTENT(OUT) :: OSLEVE ! flag for SLEVE coordinate
+REAL, INTENT(OUT) :: PLEN1 ! Decay scale for smooth topography
+REAL, INTENT(OUT) :: PLEN2 ! Decay scale for small-scale topography deviation
+REAL, DIMENSION(:,:), INTENT(OUT) :: PZSMT ! smooth-orography
+!
+TYPE (DATE_TIME), INTENT(OUT) :: TPDTMOD ! date and time of the model
+ ! beginning
+TYPE (DATE_TIME), INTENT(OUT) :: TPDTCUR ! Current date and time
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PJ ! Jacobian
+!
+END SUBROUTINE SET_LIGHT_GRID
+!
+END INTERFACE
+!
+END MODULE MODI_SET_LIGHT_GRID
+!
+!
+!
+!
+!
+! #########################################################################
+ SUBROUTINE SET_LIGHT_GRID(KMI,HINIFILE,HLUOUT, &
+ KIU,KJU,KKU,KIMAX_ll,KJMAX_ll, &
+ PLONORI,PLATORI,PLON,PLAT, &
+ PXHAT,PYHAT,PDXHAT,PDYHAT, PMAP, &
+ PZS,PZZ,PZHAT,OSLEVE,PLEN1,PLEN2,PZSMT, &
+ PJ, &
+ TPDTMOD,TPDTCUR )
+! #########################################################################
+!
+!!**** *SET_LIGHT_GRID* - routine to set grid variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to set spatio-temporal grid variables
+!
+!!** METHOD
+!! ------
+!!
+!! The spatial grid variables are read in initial file :
+!! * The reference latitude (XLAT0), the reference longitude (XLON0) and
+!! the projection parameter (XPRPK) are read if spherical geometry is used.
+!! (LCARTESIAN=.FALSE.) and only at the first call (by INI_MODEL1,i.e. KMI=1),
+!! since it is the same for all nested models.
+!! * The rotation angle (XBETA) is read only at the first call for the
+!! same reason.
+!! * The latitude and longitude of the origine points (XLATOR and XLONOR)
+!! are read for a spherical geometry (LCARTESIAN=.FALSE.).
+!! * The horizontal positions (PXHAT and PYHAT) are always read.
+!!
+!! The temporal grid variables are read in initial file :
+!! * The number of time steps for the current segment depends on the time step
+!! PTSTEP and on the segment length PSEGLEN plus one time step of the first
+!! model for all models.
+!! * The time of the beginning of experiment (TDTEXP of type DATE_TIME)
+!! is read only at the first call by INI_MODEL1 (KMI=1),
+!! since it is the same for all nested models.
+!! * The times of the beginning of model (TPDTMOD of type DATE_TIME),
+!! of beginning of segment (TPDTSEG of type DATE_TIME) are read for
+!! all models
+!!
+!! Then, the other spatial grid variables are deduced :
+!! * If Cartesian geometry (LCARTESIAN=.TRUE.), SM_GRIDCART computes
+!! the horizontal stretchings (PDXHAT and PDYHAT) the height (PZZ) and the
+!! Jacobian (PJ).
+!! * if Spherical geometry (LCARTESIAN=.FALSE.), SM_GRIDPROJ computes
+!! the horizontal stretchings (PDXHAT and PDYHAT) the height (PZZ), the
+!! Jacobian (PJ), the map factor (PMAP), the latitude (PLAT) and the
+!! longitude (PLON).
+!!
+!! and the other temporal grid variables are deduced :
+!! The current time (TPDTCUR of type DATE_TIME) is set equal to the time
+!! of beginning of segment.
+!!
+!! IF verbose option (NVERB >=5), the time is printed on output-listing
+!! EXTERNAL
+!! --------
+!! FMREAD : to read data in LFIFM file
+!! FMLOOK : to retrieve a logical unit number
+!!
+!! Module MODE_GRIDPROJ : contains conformal projection routines
+!! SM_GRIDPROJ : to compute some grid variables in case of conformal
+!! projection
+!! SM_LATLON : to compute latitude and longitude, giving the
+!! positions on the grid
+!! Module MODE_GRIDCART : contains cartesian geometry routines
+!! SM_GRIDCART : to compute some grid_variables in case of cartesian
+!! geometry
+!! Module MODE_TIME : contains SM_PRINT_TIME routine
+!! and uses module MODD_TIME (for definition
+!! of types DATE_TIME and DATE
+!! ZS_BOUNDARY : replace the orography outside the fine-mesh model by
+!! the large-scale orography of the DAD model
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!!
+!! Module MODD_CONF : contains declaration of configuration variables
+!! for all models
+!! CCONF : Configuration for all models ( START, RESTART or POST)
+!! LCARTESIAN : Logical for cartesian geometry
+!! .TRUE. = cartesian geometry
+!! NVERB : Level of informations on output-listing
+!! 0 for minimum prints
+!! 5 for intermediate level of prints
+!! 10 for maximum prints
+!! CSTORAGE_TYPE : type of stored informations ( 2 or one instant)
+!!
+!!
+!! Module MODD_GRID : contains spatial grid variables for all model
+!!
+!! XLON0 : Reference longitude for the conformal projection
+!! XLAT0 : Reference latitude
+!! XBETA : Rotation angle
+!! XRPK : Projection parameter for the conformal projection
+!!
+!! Module MODE_TIME : uses module MODD_TIME (contains temporal grid
+!! variables for all model
+!! TDTEXP : Date and time for the experiment beginning
+!! TDTSEG : Date and time for the segment beginning
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation (routine SET_LIGHT_GRID)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original /06/94
+!! J. STEIN 02/01/95 correct the TPDTCUR initialization
+!! J. STEIN 26/01/95 read TPDTCUR in the FM-file
+!! J. STEIN 16/03/95 bug in the TPDTCUR reading
+!! J. STEIN 16/04/95 another bug in the TPDTCUR initialization
+!! J. STEIN 03/01/96 change the temporal grid
+!! J. STEIN P.JABOUILLE 30/04/96 add the storage-type reading
+!! J. STEIN 25/05/96 read RPK only in the non-cartesian case
+!! J.P. LAFORE 03/07/97 gridnesting implementation
+!! V. DUCROCQ 13/08/98 //
+!! J. STEIN 01/02/99 change the orography at the boundary for the
+!! grid-nesting lbc
+!! V.MASSON 12/10/00 read of the orography in all cases, even if LFLAT=T
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF
+USE MODD_GRID
+USE MODD_TIME
+!
+USE MODE_GRIDCART
+USE MODE_GRIDPROJ
+!USE MODE_ll
+!USE MODI_GATHER_ll !!!! a mettre dans mode_ll
+!
+!USE MODE_FMREAD
+USE MODI_FMREAD
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of argument
+!
+INTEGER, INTENT(IN) :: KMI ! Model index
+CHARACTER (LEN=*), INTENT(IN) :: HINIFILE ! Name of the initial file
+CHARACTER (LEN=*), INTENT(IN) :: HLUOUT ! name for output-listing
+ ! of nested models
+INTEGER, INTENT(IN) :: KIU ! Upper dimension in x direction
+ ! for sub-domain arrays
+INTEGER, INTENT(IN) :: KJU ! Upper dimension in y direction
+ ! for sub-domain arrays
+INTEGER, INTENT(IN) :: KKU ! Upper dimension in z direction
+ ! for domain arrays
+INTEGER, INTENT(IN) :: KIMAX_ll ! Dimensions in x direction
+ ! of the physical domain,
+INTEGER, INTENT(IN) :: KJMAX_ll ! Dimensions in y direction
+ ! of the physical domain,
+!
+REAL, INTENT(OUT) :: PLONORI ! Longitude of the
+ ! Origine point of the
+ ! conformal projection
+REAL, INTENT(OUT) :: PLATORI ! Latitude of the
+ ! Origine point of the
+ ! conformal projection
+REAL, DIMENSION(:,:), INTENT(OUT) :: PLON,PLAT ! Longitude and latitude
+REAL, DIMENSION(:), INTENT(OUT) :: PXHAT ! Position x in the conformal
+ ! plane or on the cartesian plane
+REAL, DIMENSION(:), INTENT(OUT) :: PYHAT ! Position y in the conformal
+ ! plane or on the cartesian plane
+REAL, DIMENSION(:), INTENT(OUT) :: PDXHAT ! horizontal stretching in x
+REAL, DIMENSION(:), INTENT(OUT) :: PDYHAT ! horizontal stretching in y
+REAL, DIMENSION(:,:), INTENT(OUT) :: PMAP ! Map factor
+!
+REAL, DIMENSION(:,:), INTENT(OUT) :: PZS ! orography
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PZZ ! Height z
+REAL, DIMENSION(:), INTENT(OUT) :: PZHAT ! Height level
+LOGICAL, INTENT(OUT) :: OSLEVE ! flag for SLEVE coordinate
+REAL, INTENT(OUT) :: PLEN1 ! Decay scale for smooth topography
+REAL, INTENT(OUT) :: PLEN2 ! Decay scale for small-scale topography deviation
+REAL, DIMENSION(:,:), INTENT(OUT) :: PZSMT ! smooth-orography
+!
+TYPE (DATE_TIME), INTENT(OUT) :: TPDTMOD ! date and time of the model
+ ! beginning
+TYPE (DATE_TIME), INTENT(OUT) :: TPDTCUR ! Current date and time
+!
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PJ ! Jacobian
+!
+!* 0.2 declarations of local variables
+!
+REAL, DIMENSION(:), ALLOCATABLE :: ZXHAT_ll ! Position x in the conformal
+ ! plane (array on the complete domain)
+REAL, DIMENSION(:), ALLOCATABLE :: ZYHAT_ll ! Position y in the conformal
+ ! plane (array on the complete domain)
+REAL :: ZXHATM,ZYHATM ! coordinates of mass point
+REAL :: ZLONORI,ZLATORI ! lon/lat of mass point (x=0,y=0)
+INTEGER :: ILENG,IGRID,ILENCH,IRESP ! File
+CHARACTER (LEN=16) :: YRECFM ! management
+CHARACTER (LEN=100) :: YCOMMENT ! variables
+!CHARACTER (LEN=2) :: YDIR !
+INTEGER, DIMENSION(3) :: ITDATE ! date array
+INTEGER :: IMASDEV ! masdev of the file
+LOGICAL :: GSLEVE ! local flag for SLEVE coordinate
+!
+!-------------------------------------------------------------------------------
+!
+YRECFM='MASDEV'
+!YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,IMASDEV,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP /=0) IMASDEV=43
+!
+!* 1. READ GRID VARIABLES IN INITIAL FILE
+! ------------------------------------
+!
+!* 1.1 Spatial grid
+!
+IF (KMI == 1) THEN
+ YRECFM='STORAGE_TYPE'
+ !YDIR='--'
+ ILENG=2
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,CSTORAGE_TYPE,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF (IRESP /= 0) CSTORAGE_TYPE='MT'
+ !
+ YRECFM='LON0' ! this parameter is also useful in the cartesian to
+ !YDIR='--' ! compute the sun position for the radiation scheme
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XLON0,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='LAT0' ! this parameter is also useful in the cartesian to
+ !YDIR='--' ! compute the Coriolis parameter
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XLAT0,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='BETA' ! this parameter is also useful in the cartesian to
+ !YDIR='--' ! rotate the simulatin domain
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XBETA,IGRID,ILENCH,YCOMMENT,IRESP)
+END IF
+!
+YRECFM='XHAT'
+!YDIR='XX'
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,KIU,PXHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='YHAT'
+!YDIR='YY'
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,KJU,PYHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+IF (.NOT.LCARTESIAN) THEN
+ YRECFM='RPK'
+ !YDIR='--'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,XRPK,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='LONORI'
+ !YDIR='--'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,PLONORI,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='LATORI'
+ !YDIR='--'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,PLATORI,IGRID,ILENCH,YCOMMENT,IRESP)
+! compute PLATORI,PLONORI i.e. latitude and longitude of
+! coordinates x=0, y=0 of the grid.
+ IF (IMASDEV<=45) THEN
+!! compute PLATOR,PLONOR of each sub-domain
+!! i.e. latitude and longitude of mass point (1,1)
+ !IF (NPROC > 1) THEN
+ ! ALLOCATE(ZXHAT_ll(KIMAX_ll+ 2 * JPHEXT),ZYHAT_ll(KJMAX_ll+2 * JPHEXT))
+ ! CALL GATHERALL_FIELD_ll('XX',PXHAT,ZXHAT_ll,IRESP) !//
+ ! CALL GATHERALL_FIELD_ll('YY',PYHAT,ZYHAT_ll,IRESP) !//
+ ! ZXHATM =0.5 * (PXHAT(1)+PXHAT(2))
+ ! ZYHATM =0.5 * (PYHAT(1)+PYHAT(2))
+ ! CALL SM_LATLON(ZXHAT_ll,ZYHAT_ll,PLATOR_ll,PLONOR_ll,ZXHATM,ZYHATM,&
+ ! PLATOR,PLONOR)
+ ! DEALLOCATE(ZXHAT_ll,ZYHAT_ll)
+ !ELSE
+ ! PLATOR = PLATOR_ll
+ ! PLONOR = PLONOR_ll
+ !END IF
+ YRECFM='LONOR'
+ !YDIR='--'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,PLONORI,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='LATOR'
+ !YDIR='--'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,PLATORI,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ ZXHATM = - 0.5 * (PXHAT(1)+PXHAT(2))
+ ZYHATM = - 0.5 * (PYHAT(1)+PYHAT(2))
+ CALL SM_LATLON(PLATORI,PLONORI,ZXHATM,ZYHATM,&
+ ZLATORI,ZLONORI)
+ PLATORI = ZLATORI
+ PLONORI = ZLONORI
+ END IF
+ !
+END IF
+!
+YRECFM='ZS'
+!YDIR='XY'
+ILENG=KIU*KJU
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,PZS,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP /= 0)THEN
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG/3,PZS(:,2),IGRID,ILENCH,YCOMMENT,IRESP)
+ IF(IRESP == 0)THEN
+ PZS(:,1)=PZS(:,2)
+ PZS(:,3)=PZS(:,2)
+ ELSE
+ PZS(:,:) = 0.
+ ENDIF
+ENDIF
+!
+YRECFM='ZHAT'
+!YDIR='--'
+ILENG=KKU
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,PZHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+!CALL DEFAULT_SLEVE(OSLEVE,PLEN1,PLEN2)
+OSLEVE=.FALSE.
+PLEN1=7500.
+PLEN2=2500.
+!
+IF (IMASDEV<=46) THEN
+ PZSMT = PZS
+ OSLEVE = .FALSE.
+ELSE
+ YRECFM='SLEVE'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,GSLEVE,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF (IRESP ==0) OSLEVE=GSLEVE
+ !
+ YRECFM='ZSMT'
+ ILENG=KIU*KJU
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,PZSMT,IGRID,ILENCH,YCOMMENT,IRESP)
+END IF
+!
+IF (OSLEVE) THEN
+ YRECFM='LEN1'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,PLEN1,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='LEN2'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,PLEN2,IGRID,ILENCH,YCOMMENT,IRESP)
+ print *,'set_light_grid: SLEVE=',OSLEVE,PLEN1,PLEN2
+END IF
+!
+!* 1.2 Temporal grid
+!
+IF (KMI == 1) THEN
+ YRECFM='DTEXP%TDATE'
+ !YDIR='--'
+ ILENG=3
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+ TDTEXP%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+ YRECFM='DTEXP%TIME'
+ !YDIR='--'
+ ILENG=1
+ CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,TDTEXP%TIME,IGRID,ILENCH, &
+ YCOMMENT,IRESP)
+END IF
+!
+YRECFM='DTCUR%TDATE'
+!YDIR='--'
+ILENG=3
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+TPDTCUR%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+YRECFM='DTCUR%TIME'
+!YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,TPDTCUR%TIME,IGRID,ILENCH, &
+ YCOMMENT,IRESP)
+!
+YRECFM='DTMOD%TDATE'
+!YDIR='--'
+ILENG=3
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+TPDTMOD%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+YRECFM='DTMOD%TIME'
+!YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,TPDTMOD%TIME,IGRID,ILENCH, &
+ YCOMMENT,IRESP)
+!
+YRECFM='DTSEG%TDATE'
+!YDIR='--'
+ILENG=3
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+TDTSEG%TDATE=DATE(ITDATE(1),ITDATE(2),ITDATE(3))
+YRECFM='DTSEG%TIME'
+!YDIR='--'
+ILENG=1
+CALL FMREAD(HINIFILE,YRECFM,HLUOUT,ILENG,TDTSEG%TIME,IGRID,ILENCH, &
+ YCOMMENT,IRESP)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. SET OTHER GRID VARIABLES
+! ------------------------
+!
+!* 2.1 Spatial grid
+!
+IF (LCARTESIAN) THEN
+ CALL SM_GRIDCART(HLUOUT,PXHAT,PYHAT,PZHAT,PZS,OSLEVE,PLEN1,PLEN2,PZSMT,PDXHAT,PDYHAT,PZZ,PJ)
+ELSE
+ CALL SM_GRIDPROJ(HLUOUT,PXHAT,PYHAT,PZHAT,PZS,OSLEVE,PLEN1,PLEN2,PZSMT,PLATORI,PLONORI, &
+ PMAP,PLAT,PLON,PDXHAT,PDYHAT,PZZ,PJ)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE SET_LIGHT_GRID
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/shuman.f90 b/LIBTOOLS/tools/diachro/src/mesonh/shuman.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4845b8f2dda1b36c7506a8ed254ded7446fb4eba
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/shuman.f90
@@ -0,0 +1,1243 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+! ##################
+ MODULE MODI_SHUMAN
+! ##################
+!
+INTERFACE
+!
+FUNCTION DXF(PA) RESULT(PDXF)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux
+ ! side
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PDXF ! result at mass
+ ! localization
+END FUNCTION DXF
+!
+FUNCTION DXM(PA) RESULT(PDXM)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass
+ ! localization
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PDXM ! result at flux
+ ! side
+END FUNCTION DXM
+!
+FUNCTION DYF(PA) RESULT(PDYF)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux
+ ! side
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PDYF ! result at mass
+ ! localization
+END FUNCTION DYF
+!
+FUNCTION DYM(PA) RESULT(PDYM)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass
+ ! localization
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PDYM ! result at flux
+ ! side
+END FUNCTION DYM
+!
+FUNCTION DZF(PA) RESULT(PDZF)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux
+ ! side
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PDZF ! result at mass
+ ! localization
+END FUNCTION DZF
+!
+FUNCTION DZM(PA) RESULT(PDZM)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass
+ ! localization
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PDZM ! result at flux
+ ! side
+END FUNCTION DZM
+!
+FUNCTION MXF(PA) RESULT(PMXF)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux
+ ! side
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMXF ! result at mass
+ ! localization
+END FUNCTION MXF
+!
+FUNCTION MXM(PA) RESULT(PMXM)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass localization
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMXM ! result at flux localization
+END FUNCTION MXM
+!
+FUNCTION MYF(PA) RESULT(PMYF)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux
+ ! side
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMYF ! result at mass
+ ! localization
+END FUNCTION MYF
+!
+FUNCTION MYM(PA) RESULT(PMYM)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass localization
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMYM ! result at flux localization
+END FUNCTION MYM
+!
+FUNCTION MZF(PA) RESULT(PMZF)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux
+ ! side
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMZF ! result at mass
+ ! localization
+END FUNCTION MZF
+!
+FUNCTION MZM(PA) RESULT(PMZM)
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass localization
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMZM ! result at flux localization
+END FUNCTION MZM
+!
+END INTERFACE
+!
+END MODULE MODI_SHUMAN
+!
+!
+! ###############################
+ FUNCTION MXF(PA) RESULT(PMXF)
+! ###############################
+!
+!!**** *MXF* - Shuman operator : mean operator in x direction for a
+!! variable at a flux side
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute a mean
+! along the x direction (I index) for a field PA localized at a x-flux
+! point (u point). The result is localized at a mass point.
+!
+!!** METHOD
+!! ------
+!! The result PMXF(i,:,:) is defined by 0.5*(PA(i,:,:)+PA(i+1,:,:))
+!! At i=size(PA,1), PMXF(i,:,:) are replaced by the values of PMXF,
+!! which are the right values in the x-cyclic case
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT: define the number of marginal points out of the
+!! physical domain along the horizontal directions.
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (SHUMAN operators)
+!! Technical specifications Report of The Meso-NH (chapters 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 04/07/94
+!! Modification to include the periodic case 13/10/94 J.Stein
+!! optimisation 20/08/00 J. Escobar
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux
+ ! side
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMXF ! result at mass
+ ! localization
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JI ! Loop index in x direction
+INTEGER :: IIU ! upper bound in x direction of PA
+!
+INTEGER :: JJK,IJU,IKU
+INTEGER :: JIJK,JIJKOR,JIJKEND
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DEFINITION OF MXF
+! ------------------
+!
+IIU = SIZE(PA,1)
+IJU = SIZE(PA,2)
+IKU = SIZE(PA,3)
+!
+JIJKOR = 1 + JPHEXT
+JIJKEND = IIU*IJU*IKU
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJK=JIJKOR , JIJKEND
+ PMXF(JIJK-1,1,1) = 0.5*( PA(JIJK-1,1,1)+PA(JIJK,1,1) )
+END DO
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JJK=1,IJU*IKU
+ PMXF(IIU,JJK,1) = PMXF(2*JPHEXT,JJK,1)
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION MXF
+! ###############################
+ FUNCTION MXM(PA) RESULT(PMXM)
+! ###############################
+!
+!!**** *MXM* - Shuman operator : mean operator in x direction for a
+!! mass variable
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute a mean
+! along the x direction (I index) for a field PA localized at a mass
+! point. The result is localized at a x-flux point (u point).
+!
+!!** METHOD
+!! ------
+!! The result PMXM(i,:,:) is defined by 0.5*(PA(i,:,:)+PA(i-1,:,:))
+!! At i=1, PMXM(1,:,:) are replaced by the values of PMXM,
+!! which are the right values in the x-cyclic case.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT: define the number of marginal points out of the
+!! physical domain along the horizontal directions.
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (SHUMAN operators)
+!! Technical specifications Report of The Meso-NH (chapters 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 04/07/94
+!! Modification to include the periodic case 13/10/94 J.Stein
+!! optimisation 20/08/00 J. Escobar
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass localization
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMXM ! result at flux localization
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JI ! Loop index in x direction
+INTEGER :: IIU ! Size of the array in the x direction
+!
+INTEGER :: JJK,IJU,IKU
+INTEGER :: JIJK,JIJKOR,JIJKEND
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DEFINITION OF MXM
+! ------------------
+!
+IIU = SIZE(PA,1)
+IJU = SIZE(PA,2)
+IKU = SIZE(PA,3)
+!
+JIJKOR = 1 + JPHEXT
+JIJKEND = IIU*IJU*IKU
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJK=JIJKOR , JIJKEND
+ PMXM(JIJK,1,1) = 0.5*( PA(JIJK,1,1)+PA(JIJK-1,1,1) )
+END DO
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JJK=1,IJU*IKU
+ PMXM(1,JJK,1) = PMXM(IIU-2*JPHEXT+1,JJK,1)
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION MXM
+! ###############################
+ FUNCTION MYF(PA) RESULT(PMYF)
+! ###############################
+!
+!!**** *MYF* - Shuman operator : mean operator in y direction for a
+!! variable at a flux side
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute a mean
+! along the y direction (J index) for a field PA localized at a y-flux
+! point (v point). The result is localized at a mass point.
+!
+!!** METHOD
+!! ------
+!! The result PMYF(i,:,:) is defined by 0.5*(PA(:,j,:)+PA(:,j+1,:))
+!! At j=size(PA,2), PMYF(:,j,:) are replaced by the values of PMYF,
+!! which are the right values in the y-cyclic case
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT: define the number of marginal points out of the
+!! physical domain along the horizontal directions.
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (SHUMAN operators)
+!! Technical specifications Report of The Meso-NH (chapters 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 04/07/94
+!! Modification to include the periodic case 13/10/94 J.Stein
+!! optimisation 20/08/00 J. Escobar
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux
+ ! side
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMYF ! result at mass
+ ! localization
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JJ ! Loop index in y direction
+INTEGER :: IJU ! upper bound in y direction of PA
+!
+INTEGER :: IIU,IKU
+INTEGER :: JIJK,JIJKOR,JIJKEND
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DEFINITION OF MYF
+! ------------------
+!
+IIU = SIZE(PA,1)
+IJU = SIZE(PA,2)
+IKU = SIZE(PA,3)
+!
+JIJKOR = 1 + IIU
+JIJKEND = IIU*IJU*IKU
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJK=JIJKOR , JIJKEND
+ PMYF(JIJK-IIU,1,1) = 0.5*( PA(JIJK-IIU,1,1)+PA(JIJK,1,1) )
+END DO
+!
+PMYF(:,IJU,:) = PMYF(:,2*JPHEXT,:)
+!
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION MYF
+! ###############################
+ FUNCTION MYM(PA) RESULT(PMYM)
+! ###############################
+!
+!!**** *MYM* - Shuman operator : mean operator in y direction for a
+!! mass variable
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute a mean
+! along the y direction (J index) for a field PA localized at a mass
+! point. The result is localized at a y-flux point (v point).
+!
+!!** METHOD
+!! ------
+!! The result PMYM(:,j,:) is defined by 0.5*(PA(:,j,:)+PA(:,j-1,:))
+!! At j=1, PMYM(:,j,:) are replaced by the values of PMYM,
+!! which are the right values in the y-cyclic case.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT: define the number of marginal points out of the
+!! physical domain along the horizontal directions.
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (SHUMAN operators)
+!! Technical specifications Report of The Meso-NH (chapters 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 04/07/94
+!! Modification to include the periodic case 13/10/94 J.Stein
+!! optimisation 20/08/00 J. Escobar
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass localization
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMYM ! result at flux localization
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JJ ! Loop index in y direction
+INTEGER :: IJU ! Size of the array in the y direction
+!
+!
+INTEGER :: IIU,IKU
+INTEGER :: JIJK,JIJKOR,JIJKEND
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DEFINITION OF MYM
+! ------------------
+!
+IIU=SIZE(PA,1)
+IJU=SIZE(PA,2)
+IKU=SIZE(PA,3)
+!
+JIJKOR = 1 + IIU
+JIJKEND = IIU*IJU*IKU
+!CDIR NODEP
+!OCL NOVREC
+DO JIJK=JIJKOR , JIJKEND
+ PMYM(JIJK,1,1) = 0.5*( PA(JIJK,1,1)+PA(JIJK-IIU,1,1) )
+END DO
+!
+PMYM(:,1,:) = PMYM(:,IJU-2*JPHEXT+1,:)
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION MYM
+! ###############################
+ FUNCTION MZF(PA) RESULT(PMZF)
+! ###############################
+!
+!!**** *MZF* - Shuman operator : mean operator in z direction for a
+!! variable at a flux side
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute a mean
+! along the z direction (K index) for a field PA localized at a z-flux
+! point (w point). The result is localized at a mass point.
+!
+!!** METHOD
+!! ------
+!! The result PMZF(:,:,k) is defined by 0.5*(PA(:,:,k)+PA(:,:,k+1))
+!! At k=size(PA,3), PMZF(:,:,k) is defined by -999.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (SHUMAN operators)
+!! Technical specifications Report of The Meso-NH (chapters 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 04/07/94
+!! optimisation 20/08/00 J. Escobar
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux
+ ! side
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMZF ! result at mass
+ ! localization
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JK ! Loop index in z direction
+INTEGER :: IKU ! upper bound in z direction of PA
+!
+INTEGER :: IIU,IJU
+INTEGER :: JIJ
+INTEGER :: JIJK,JIJKOR,JIJKEND
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DEFINITION OF MZF
+! ------------------
+!
+IIU = SIZE(PA,1)
+IJU = SIZE(PA,2)
+IKU = SIZE(PA,3)
+!
+JIJKOR = 1 + IIU*IJU
+JIJKEND = IIU*IJU*IKU
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJK=JIJKOR , JIJKEND
+ PMZF(JIJK-IIU*IJU,1,1) = 0.5*( PA(JIJK-IIU*IJU,1,1)+PA(JIJK,1,1) )
+END DO
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJ=1,IIU*IJU
+ PMZF(JIJ,1,IKU) = -999.
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION MZF
+! ###############################
+ FUNCTION MZM(PA) RESULT(PMZM)
+! ###############################
+!
+!!**** *MZM* - Shuman operator : mean operator in z direction for a
+!! mass variable
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute a mean
+! along the z direction (K index) for a field PA localized at a mass
+! point. The result is localized at a z-flux point (w point).
+!
+!!** METHOD
+!! ------
+!! The result PMZM(:,:,k) is defined by 0.5*(PA(:,:,k)+PA(:,:,k-1))
+!! At k=1, PMZM(:,:,1) is defined by -999.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (SHUMAN operators)
+!! Technical specifications Report of The Meso-NH (chapters 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 04/07/94
+!! optimisation 20/08/00 J. Escobar
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass localization
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PMZM ! result at flux localization
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JK ! Loop index in z direction
+INTEGER :: IKU ! upper bound in z direction of PA
+!
+INTEGER :: IIU,IJU
+INTEGER :: JIJ,JI,JJ
+INTEGER :: JIJK,JIJKOR,JIJKEND
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DEFINITION OF MZM
+! ------------------
+!
+IIU = SIZE(PA,1)
+IJU = SIZE(PA,2)
+IKU = SIZE(PA,3)
+!
+JIJKOR = 1 + IIU*IJU
+JIJKEND = IIU*IJU*IKU
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJK=JIJKOR , JIJKEND
+ PMZM(JIJK,1,1) = 0.5*( PA(JIJK,1,1)+PA(JIJK-IIU*IJU,1,1) )
+END DO
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJ=1,IIU*IJU
+ PMZM(JIJ,1,1) = -999.
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION MZM
+! ###############################
+ FUNCTION DXF(PA) RESULT(PDXF)
+! ###############################
+!
+!!**** *DXF* - Shuman operator : finite difference operator in x direction
+!! for a variable at a flux side
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute a finite difference
+! along the x direction (I index) for a field PA localized at a x-flux
+! point (u point). The result is localized at a mass point.
+!
+!!** METHOD
+!! ------
+!! The result PDXF(i,:,:) is defined by (PA(i+1,:,:)-PA(i,:,:))
+!! At i=size(PA,1), PDXF(i,:,:) are replaced by the values of PDXF,
+!! which are the right values in the x-cyclic case
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT: define the number of marginal points out of the
+!! physical domain along the horizontal directions.
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (SHUMAN operators)
+!! Technical specifications Report of The Meso-NH (chapters 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/07/94
+!! Modification to include the periodic case 13/10/94 J.Stein
+!! optimisation 20/08/00 J. Escobar
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux
+ ! side
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PDXF ! result at mass
+ ! localization
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JI ! Loop index in x direction
+INTEGER :: IIU ! upper bound in x direction of PA
+!
+INTEGER :: JJK,IJU,IKU
+INTEGER :: JIJK,JIJKOR,JIJKEND
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DEFINITION OF DXF
+! ------------------
+!
+IIU = SIZE(PA,1)
+IJU = SIZE(PA,2)
+IKU = SIZE(PA,3)
+!
+JIJKOR = 1 + JPHEXT
+JIJKEND = IIU*IJU*IKU
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJK=JIJKOR , JIJKEND
+ PDXF(JIJK-1,1,1) = PA(JIJK,1,1) - PA(JIJK-1,1,1)
+END DO
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JJK=1,IJU*IKU
+ PDXF(IIU,JJK,1) = PDXF(2*JPHEXT,JJK,1)
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION DXF
+! ###############################
+ FUNCTION DXM(PA) RESULT(PDXM)
+! ###############################
+!
+!!**** *DXM* - Shuman operator : finite difference operator in x direction
+!! for a variable at a mass localization
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute a finite difference
+! along the x direction (I index) for a field PA localized at a mass
+! point. The result is localized at a x-flux point (u point).
+!
+!!** METHOD
+!! ------
+!! The result PDXM(i,:,:) is defined by (PA(i,:,:)-PA(i-1,:,:))
+!! At i=1, PDXM(1,:,:) are replaced by the values of PDXM,
+!! which are the right values in the x-cyclic case.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT: define the number of marginal points out of the
+!! physical domain along the horizontal directions.
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (SHUMAN operators)
+!! Technical specifications Report of The Meso-NH (chapters 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/07/94
+!! Modification to include the periodic case 13/10/94 J.Stein
+!! optimisation 20/08/00 J. Escobar
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass
+ ! localization
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PDXM ! result at flux
+ ! side
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JI ! Loop index in x direction
+INTEGER :: IIU ! Size of the array in the x direction
+!
+!
+INTEGER :: JJK,IJU,IKU
+INTEGER :: JIJK,JIJKOR,JIJKEND
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DEFINITION OF DXM
+! ------------------
+!
+IIU = SIZE(PA,1)
+IJU = SIZE(PA,2)
+IKU = SIZE(PA,3)
+!
+JIJKOR = 1 + 1
+JIJKEND = IIU*IJU*IKU
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJK=JIJKOR , JIJKEND
+ PDXM(JIJK,1,1) = PA(JIJK,1,1) - PA(JIJK-1,1,1)
+END DO
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JJK=1,IJU*IKU
+ PDXM(1,JJK,1) = PDXM(IIU-2*JPHEXT+1,JJK,1)
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION DXM
+! ###############################
+ FUNCTION DYF(PA) RESULT(PDYF)
+! ###############################
+!
+!!**** *DYF* - Shuman operator : finite difference operator in y direction
+!! for a variable at a flux side
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute a finite difference
+! along the y direction (J index) for a field PA localized at a y-flux
+! point (v point). The result is localized at a mass point.
+!
+!!** METHOD
+!! ------
+!! The result PDYF(:,j,:) is defined by (PA(:,j+1,:)-PA(:,j,:))
+!! At j=size(PA,2), PDYF(:,j,:) are replaced by the values of PDYM,
+!! which are the right values in the y-cyclic case
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT: define the number of marginal points out of the
+!! physical domain along the horizontal directions.
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (SHUMAN operators)
+!! Technical specifications Report of The Meso-NH (chapters 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/07/94
+!! Modification to include the periodic case 13/10/94 J.Stein
+!! optimisation 20/08/00 J. Escobar
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux
+ ! side
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PDYF ! result at mass
+ ! localization
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JJ ! Loop index in y direction
+INTEGER :: IJU ! upper bound in y direction of PA
+!
+!
+INTEGER :: IIU,IKU
+INTEGER :: JIJK,JIJKOR,JIJKEND
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DEFINITION OF DYF
+! ------------------
+!
+IIU = SIZE(PA,1)
+IJU = SIZE(PA,2)
+IKU = SIZE(PA,3)
+!
+JIJKOR = 1 + IIU
+JIJKEND = IIU*IJU*IKU
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJK=JIJKOR , JIJKEND
+ PDYF(JIJK-IIU,1,1) = PA(JIJK,1,1) - PA(JIJK-IIU,1,1)
+END DO
+!
+PDYF(:,IJU,:) = PDYF(:,2*JPHEXT,:)
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION DYF
+! ###############################
+ FUNCTION DYM(PA) RESULT(PDYM)
+! ###############################
+!
+!!**** *DYM* - Shuman operator : finite difference operator in y direction
+!! for a variable at a mass localization
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute a finite difference
+! along the y direction (J index) for a field PA localized at a mass
+! point. The result is localized at a y-flux point (v point).
+!
+!!** METHOD
+!! ------
+!! The result PDYM(:,j,:) is defined by (PA(:,j,:)-PA(:,j-1,:))
+!! At j=1, PDYM(:,1,:) are replaced by the values of PDYM,
+!! which are the right values in the y-cyclic case.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS: declaration of parameter variables
+!! JPHEXT: define the number of marginal points out of the
+!! physical domain along the horizontal directions.
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (SHUMAN operators)
+!! Technical specifications Report of The Meso-NH (chapters 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/07/94
+!! Modification to include the periodic case 13/10/94 J.Stein
+!! optimisation 20/08/00 J. Escobar
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass
+ ! localization
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PDYM ! result at flux
+ ! side
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JJ ! Loop index in y direction
+INTEGER :: IJU ! Size of the array in the y direction
+!
+!
+INTEGER :: IIU,IKU
+INTEGER :: JIJK,JIJKOR,JIJKEND
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DEFINITION OF DYM
+! ------------------
+!
+IIU=SIZE(PA,1)
+IJU=SIZE(PA,2)
+IKU=SIZE(PA,3)
+!
+JIJKOR = 1 + IIU
+JIJKEND = IIU*IJU*IKU
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJK=JIJKOR , JIJKEND
+ PDYM(JIJK,1,1) = PA(JIJK,1,1) - PA(JIJK-IIU,1,1)
+END DO
+!
+PDYM(:,1,:) = PDYM(:,IJU-2*JPHEXT+1,:)
+!
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION DYM
+! ###############################
+ FUNCTION DZF(PA) RESULT(PDZF)
+! ###############################
+!
+!!**** *DZF* - Shuman operator : finite difference operator in z direction
+!! for a variable at a flux side
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute a finite difference
+! along the z direction (K index) for a field PA localized at a z-flux
+! point (w point). The result is localized at a mass point.
+!
+!!** METHOD
+!! ------
+!! The result PDZF(:,:,k) is defined by (PA(:,:,k+1)-PA(:,:,k))
+!! At k=size(PA,3), PDZF(:,:,k) is defined by -999.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (SHUMAN operators)
+!! Technical specifications Report of The Meso-NH (chapters 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/07/94
+!! optimisation 20/08/00 J. Escobar
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at flux
+ ! side
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PDZF ! result at mass
+ ! localization
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JK ! Loop index in z direction
+INTEGER :: IKU ! upper bound in z direction of PA
+!
+!
+INTEGER :: IIU,IJU
+INTEGER :: JIJ
+INTEGER :: JIJK,JIJKOR,JIJKEND
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DEFINITION OF DZF
+! ------------------
+!
+IIU = SIZE(PA,1)
+IJU = SIZE(PA,2)
+IKU = SIZE(PA,3)
+!
+JIJKOR = 1 + IIU*IJU
+JIJKEND = IIU*IJU*IKU
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJK=JIJKOR , JIJKEND
+ PDZF(JIJK-IIU*IJU,1,1) = PA(JIJK,1,1)-PA(JIJK-IIU*IJU,1,1)
+END DO
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJ=1,IIU*IJU
+ PDZF(JIJ,1,IKU) = -999.
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION DZF
+! ###############################
+ FUNCTION DZM(PA) RESULT(PDZM)
+! ###############################
+!
+!!**** *DZM* - Shuman operator : finite difference operator in z direction
+!! for a variable at a mass localization
+!!
+!! PURPOSE
+!! -------
+! The purpose of this function is to compute a finite difference
+! along the z direction (K index) for a field PA localized at a mass
+! point. The result is localized at a z-flux point (w point).
+!
+!!** METHOD
+!! ------
+!! The result PDZM(:,j,:) is defined by (PA(:,:,k)-PA(:,:,k-1))
+!! At k=1, PDZM(:,:,k) is defined by -999.
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (SHUMAN operators)
+!! Technical specifications Report of The Meso-NH (chapters 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/07/94
+!! optimisation 20/08/00 J. Escobar
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of argument and result
+! ------------------------------------
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PA ! variable at mass
+ ! localization
+REAL, DIMENSION(SIZE(PA,1),SIZE(PA,2),SIZE(PA,3)) :: PDZM ! result at flux
+ ! side
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: JK ! Loop index in z direction
+INTEGER :: IKU ! upper bound in z direction of PA
+!
+!
+INTEGER :: IIU,IJU
+INTEGER :: JIJ
+INTEGER :: JIJK,JIJKOR,JIJKEND
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. DEFINITION OF DZM
+! ------------------
+!
+IIU = SIZE(PA,1)
+IJU = SIZE(PA,2)
+IKU = SIZE(PA,3)
+!
+JIJKOR = 1 + IIU*IJU
+JIJKEND = IIU*IJU*IKU
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJK=JIJKOR , JIJKEND
+ PDZM(JIJK,1,1) = PA(JIJK,1,1)-PA(JIJK-IIU*IJU,1,1)
+END DO
+!
+!CDIR NODEP
+!OCL NOVREC
+DO JIJ=1,IIU*IJU
+ PDZM(JIJ,1,1) = -999.
+END DO
+!
+!-------------------------------------------------------------------------------
+!
+END FUNCTION DZM
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/temporal_dist.f90 b/LIBTOOLS/tools/diachro/src/mesonh/temporal_dist.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3b0dad34a3ab665874cb8b775783615026e288d3
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/temporal_dist.f90
@@ -0,0 +1,210 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/mesonh/sources/operators/s.temporal_dist.f90, Version:1.6, Date:98/06/23, Last modified:98/06/04
+!-----------------------------------------------------------------
+! #########################
+ MODULE MODI_TEMPORAL_DIST
+! #########################
+INTERFACE
+ SUBROUTINE TEMPORAL_DIST(KYEARF, KMONTHF, KDAYF, PSECF, &
+ KYEARI, KMONTHI, KDAYI, PSECI, &
+ PDIST )
+!
+INTEGER, INTENT(IN) :: KYEARF ! year of Final date
+INTEGER, INTENT(IN) :: KMONTHF ! month of Final date
+INTEGER, INTENT(IN) :: KDAYF ! day of Final date
+REAL, INTENT(IN) :: PSECF ! number of seconds since date at 00 UTC
+ ! of Final date
+INTEGER, INTENT(IN) :: KYEARI ! year of Initial date
+INTEGER, INTENT(IN) :: KMONTHI ! month of Initial date
+INTEGER, INTENT(IN) :: KDAYI ! day of Initial date
+REAL, INTENT(IN) :: PSECI ! number of seconds since date at 00 UTC
+ ! of Initial date
+REAL, INTENT(OUT):: PDIST ! temporal distance in secunds between the final
+ ! and initial date
+!
+END SUBROUTINE TEMPORAL_DIST
+!
+END INTERFACE
+!
+END MODULE MODI_TEMPORAL_DIST
+!
+! #############################################################
+ SUBROUTINE TEMPORAL_DIST(KYEARF, KMONTHF, KDAYF, PSECF, &
+ KYEARI, KMONTHI, KDAYI, PSECI, &
+ PDIST )
+! #############################################################
+!
+!!**** *TEMPORAL_DIST* - finds the number of secunds between 2 dates
+!!
+!! PURPOSE
+!! -------
+!!
+!! WARNING
+!!
+!! -----> Only correct for dates between 19900301 and 21000228 <-----
+!!
+!! The correct test should be:
+!! IF( ((MOD(KYEAR,4)==0).AND.(MOD(KYEAR,100)/=0)) .OR. (MOD(KYEAR,400)==0))THEN
+!!
+!!** METHOD
+!! ------
+!!
+!! A comparison term by term of the elements of the 2 dates is performed.
+!! and the temporal distance between the 2 dates is then deduced.
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book 2
+!!
+!! AUTHOR
+!! ------
+!!
+! J.Stein Meteo-France
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 02/01/96
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declaration of arguments
+! ------------------------
+INTEGER, INTENT(IN) :: KYEARF ! year of Final date
+INTEGER, INTENT(IN) :: KMONTHF ! month of Final date
+INTEGER, INTENT(IN) :: KDAYF ! day of Final date
+REAL, INTENT(IN) :: PSECF ! number of seconds since date at 00 UTC
+ ! of Final date
+INTEGER, INTENT(IN) :: KYEARI ! year of Initial date
+INTEGER, INTENT(IN) :: KMONTHI ! month of Initial date
+INTEGER, INTENT(IN) :: KDAYI ! day of Initial date
+REAL, INTENT(IN) :: PSECI ! number of seconds since date at 00 UTC
+ ! of Initial date
+REAL, INTENT(OUT):: PDIST ! temporal distance in secunds between the final
+ ! and initial date
+!
+!* 0.2 Declaration of local variables
+! ------------------------------
+!
+INTEGER :: IDAYS ! number of days between the two dates
+INTEGER :: JMONTH,JYEAR ! loop index on months or years
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. SAME YEARS AND SAME MONTHS
+! --------------------------
+!
+IF ( (KYEARF==KYEARI) .AND. (KMONTHF==KMONTHI) ) THEN
+ PDIST = ( KDAYF-KDAYI) * 86400. + PSECF - PSECI
+ ! check chronological order
+ IF (PDIST < 0.) PDIST=-999.
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. SAME YEARS AND DIFFERENT MONTHS
+! -------------------------------
+!
+IF ( (KYEARF==KYEARI) .AND. (KMONTHF/=KMONTHI) ) THEN
+ ! check chronological order
+ IF ( KMONTHF < KMONTHI ) THEN
+ PDIST=-999.
+ RETURN
+ END IF
+ !
+ ! cumulate the number of days for the months in between KMONTHF-1 and
+ ! KMONTHI
+ IDAYS = 0
+ DO JMONTH = KMONTHI, KMONTHF-1
+ SELECT CASE (JMONTH)
+ CASE(4,6,9,11)
+ IDAYS=IDAYS+30
+ CASE(1,3,5,7:8,10,12)
+ IDAYS=IDAYS+31
+ CASE(2)
+ IF (MOD(KYEARI,4)==0) THEN
+ IDAYS=IDAYS+29
+ ELSE
+ IDAYS=IDAYS+28
+ ENDIF
+ END SELECT
+ END DO
+ !
+ ! compute the temporal distance
+ PDIST = ( IDAYS + KDAYF - KDAYI) * 86400. + PSECF - PSECI
+ !
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. DIFFERENT YEARS AND DIFFERENT MONTHS
+! ------------------------------------
+!
+IF ( (KYEARF/=KYEARI) .AND. (KMONTHF/=KMONTHI) ) THEN
+ ! check chronological order
+ IF ( KYEARF < KYEARI ) THEN
+ PDIST=-999.
+ RETURN
+ END IF
+ !
+ ! cumulate the number of days for the months in between KMONTHI and
+ ! December
+ IDAYS = 0
+ DO JMONTH = KMONTHI, 12
+ SELECT CASE (JMONTH)
+ CASE(4,6,9,11)
+ IDAYS=IDAYS+30
+ CASE(1,3,5,7:8,10,12)
+ IDAYS=IDAYS+31
+ CASE(2)
+ IF (MOD(KYEARI,4)==0) THEN
+ IDAYS=IDAYS+29
+ ELSE
+ IDAYS=IDAYS+28
+ ENDIF
+ END SELECT
+ END DO
+ DO JMONTH = 1,KMONTHF-1
+ SELECT CASE (JMONTH)
+ CASE(4,6,9,11)
+ IDAYS=IDAYS+30
+ CASE(1,3,5,7:8,10,12)
+ IDAYS=IDAYS+31
+ CASE(2)
+ IF (MOD(KYEARF,4)==0) THEN
+ IDAYS=IDAYS+29
+ ELSE
+ IDAYS=IDAYS+28
+ ENDIF
+ END SELECT
+ END DO
+ ! add the number of days corresponding to full years between the two dates
+ DO JYEAR=KYEARI+1, KYEARF-1
+ IF (MOD(JYEAR,4)==0) THEN
+ IDAYS=IDAYS+366
+ ELSE
+ IDAYS=IDAYS+365
+ END IF
+ END DO
+ !
+ ! compute the temporal distance
+ PDIST = ( IDAYS + KDAYF - KDAYI) * 86400. + PSECF - PSECI
+ !
+END IF
+!
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE TEMPORAL_DIST
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/uv_to_zonal_and_merid.f90 b/LIBTOOLS/tools/diachro/src/mesonh/uv_to_zonal_and_merid.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1e5394c781ec14dcfb7e4eff796fcbcaceb4c2a7
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/uv_to_zonal_and_merid.f90
@@ -0,0 +1,287 @@
+!-----------------------------------------------------------------
+! #################################
+ MODULE MODI_UV_TO_ZONAL_AND_MERID
+! #################################
+INTERFACE UV_TO_ZONAL_AND_MERID
+ SUBROUTINE UV_TO_ZONAL_AND_MERID3D(PU,PV,KGRID,PZC,PMC, &
+ HFMFILE,HRECU,HRECV,HCOMMENT)
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PU ! input U component
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PV ! input V component
+INTEGER, INTENT(IN) :: KGRID ! grid positions of components
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(OUT) :: PZC ! output U component
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(OUT) :: PMC ! output V component
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HFMFILE ! Name of FM-file to write
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HRECU ! Name of the U article
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HRECV ! Name of the V article
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HCOMMENT ! Comment string
+!
+END SUBROUTINE UV_TO_ZONAL_AND_MERID3D
+!
+ SUBROUTINE UV_TO_ZONAL_AND_MERID2D(PU,PV,KGRID,PZC,PMC, &
+ HFMFILE,HRECU,HRECV,HCOMMENT)
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PU ! input U component
+REAL, DIMENSION(:,:), INTENT(IN) :: PV ! input V component
+INTEGER, INTENT(IN) :: KGRID ! grid positions of components
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(OUT) :: PZC ! output U component
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(OUT) :: PMC ! output V component
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HFMFILE ! Name of FM-file to write
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HRECU ! Name of the U article
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HRECV ! Name of the V article
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HCOMMENT ! Comment string
+!
+END SUBROUTINE UV_TO_ZONAL_AND_MERID2D
+!
+END INTERFACE
+END MODULE MODI_UV_TO_ZONAL_AND_MERID
+!
+! ###################################
+ MODULE MODI_UV_TO_ZONAL_AND_MERID3D
+! ###################################
+INTERFACE
+!
+ SUBROUTINE UV_TO_ZONAL_AND_MERID3D(PU,PV,KGRID,PZC,PMC, &
+ HFMFILE,HRECU,HRECV,HCOMMENT)
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PU ! input U component
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PV ! input V component
+INTEGER, INTENT(IN) :: KGRID ! grid positions of components
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(OUT) :: PZC ! output U component
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(OUT) :: PMC ! output V component
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HFMFILE ! Name of FM-file to write
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HRECU ! Name of the U article
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HRECV ! Name of the V article
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HCOMMENT ! Comment string
+!
+END SUBROUTINE UV_TO_ZONAL_AND_MERID3D
+END INTERFACE
+END MODULE MODI_UV_TO_ZONAL_AND_MERID3D
+!
+! ##########################################
+ SUBROUTINE UV_TO_ZONAL_AND_MERID3D(PU,PV,KGRID,PZC,PMC, &
+ HFMFILE,HRECU,HRECV,HCOMMENT)
+! ##########################################
+!
+!!**** *UV_TO_ZONAL_AND_MERID* - compute the zonal and meridien components
+!! of input wind, and return or write them
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! I. Mallet *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 02/11/00
+!! N.Asencio 10/09/03 no pointer for PZC,PMC (no pointer in SHUMAN)
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF
+USE MODD_CST
+USE MODD_GRID
+USE MODD_PARAMETERS ! XUNDEF
+USE MODD_DIM1
+USE MODD_GRID1 ! XLON
+USE MODD_LUNIT1
+!
+! en attendant un phasage plus propre
+!USE MODE_FM
+!USE MODE_FMWRIT
+!
+USE MODI_SHUMAN
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PU ! input U component
+REAL, DIMENSION(:,:,:), INTENT(IN) :: PV ! input V component
+INTEGER, INTENT(IN) :: KGRID ! grid positions of components
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(OUT) :: PZC ! output U component
+REAL, DIMENSION(:,:,:), OPTIONAL, INTENT(OUT) :: PMC ! output V component
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HFMFILE ! Name of FM-file to write
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HRECU ! Name of the U article
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HRECV ! Name of the V article
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HCOMMENT ! Comment string
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: IKU
+REAL :: ZRAD_O_DG
+REAL, DIMENSION(:,:), ALLOCATABLE :: ZWORK2
+REAL, DIMENSION(:,:,:), ALLOCATABLE:: ZWORK3
+REAL, DIMENSION(:,:,:), ALLOCATABLE:: ZZC,ZMC
+!
+INTEGER :: IRESP ! return-code for the file routines
+INTEGER :: IGRID ! grid indicator
+INTEGER :: ILENCH ! length of comment string
+INTEGER :: ILUOUT ! logical unit for output listing
+!-----------------------------------------------------------------
+!
+!CALL FMLOOK_ll(CLUOUT,CLUOUT,ILUOUT,IRESP)
+ILUOUT=6
+!
+!IKU=NKMAX+2*JPVEXT
+IKU=SIZE(PU,3)
+ALLOCATE(ZWORK2(SIZE(XLON,1),SIZE(XLON,2)))
+ALLOCATE(ZWORK3(SIZE(XLON,1),SIZE(XLON,2),IKU))
+!
+ALLOCATE(ZZC(SIZE(XLON,1),SIZE(XLON,2),IKU))
+ALLOCATE(ZMC(SIZE(XLON,1),SIZE(XLON,2),IKU))
+!
+ZRAD_O_DG = XPI/180.
+IF (LCARTESIAN) THEN ! cartesian geometry
+ ZWORK2(:,:) = -XBETA *ZRAD_O_DG
+ELSE ! conformal projection
+ ZWORK2(:,:) = XRPK * (XLON(:,:) -XLON0) * ZRAD_O_DG -(XBETA *ZRAD_O_DG)
+END IF
+ZWORK3(:,:,:) = SPREAD( ZWORK2(:,:),DIM=3,NCOPIES=IKU )
+DEALLOCATE(ZWORK2)
+!
+ZZC(:,:,:) = XUNDEF
+ZMC(:,:,:) = XUNDEF
+!
+! Zonal and Meridien components of wind
+!
+IF (KGRID==23) THEN
+ WRITE(ILUOUT,*) '- zonal and meridien components of winds are computed'
+ WHERE(PU(:,:,:)/=XUNDEF .AND. PV(:,:,:)/=XUNDEF)
+ ZZC(:,:,:) = PU(:,:,:) *MXM(COS(ZWORK3(:,:,:))) &
+ + MYF(MXM(PV(:,:,:))) *MXM(SIN(ZWORK3(:,:,:)))
+ ZMC(:,:,:) = - MXF(MYM(PU(:,:,:))) *MYM(SIN(ZWORK3(:,:,:))) &
+ + PV(:,:,:) *MYM(COS(ZWORK3(:,:,:)))
+ ENDWHERE
+ELSE IF (KGRID==11) THEN
+ WRITE(ILUOUT,*) '- zonal and meridien components of winds are computed'
+ WHERE(PU(:,:,:)/=XUNDEF .AND. PV(:,:,:)/=XUNDEF)
+ ZZC(:,:,:) = PU(:,:,:) *COS(ZWORK3(:,:,:)) +PV(:,:,:) *SIN(ZWORK3(:,:,:))
+ ZMC(:,:,:) = - PU(:,:,:) *SIN(ZWORK3(:,:,:)) +PV(:,:,:) *COS(ZWORK3(:,:,:))
+ ENDWHERE
+ELSE IF (KGRID==0) THEN
+!
+! in this case, input winds are ZONal and MERidien
+! and, output ones are in MesoNH grid (mass points)
+ WRITE(ILUOUT,*) '- components of winds are replaced in MesoNH grid'
+ WHERE(PU(:,:,:)/=XUNDEF .AND. PV(:,:,:)/=XUNDEF)
+ ZZC(:,:,:) = COS(ZWORK3(:,:,:))* PU(:,:,:) - SIN(ZWORK3(:,:,:))* PV(:,:,:)
+ ZMC(:,:,:) = SIN(ZWORK3(:,:,:))* PU(:,:,:) + COS(ZWORK3(:,:,:))* PV(:,:,:)
+ ENDWHERE
+ELSE
+ WRITE(ILUOUT,*) '- warning in uv_to_zonal_and_merid: no computation for KGRIDKGRID= ',KGRID
+ RETURN
+END IF
+!
+IF (PRESENT(PZC) .AND. PRESENT(PMC)) THEN
+ PZC(:,:,:) = ZZC(:,:,:)
+ PMC(:,:,:) = ZMC(:,:,:)
+ELSE
+ WRITE(ILUOUT,*) '- warning in uv_to_zonal_and_merid3d: bad optional arguments'
+ RETURN
+END IF
+!
+!-------------------------------------------------------------------------------
+DEALLOCATE(ZWORK3)
+DEALLOCATE(ZZC,ZMC)
+!
+END SUBROUTINE UV_TO_ZONAL_AND_MERID3D
+!
+!
+! ##########################################
+ SUBROUTINE UV_TO_ZONAL_AND_MERID2D(PU,PV,KGRID,PZC,PMC, &
+ HFMFILE,HRECU,HRECV,HCOMMENT)
+! ##########################################
+!
+!!**** *UV_TO_ZONAL_AND_MERID* - compute the zonal and meridien components
+!! of input wind, and return or write them
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! I. Mallet *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 02/11/00
+!! I. Mallet 11/09/03 call to UV_ZONAL_AND_MERID3D
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODI_UV_TO_ZONAL_AND_MERID3D
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PU ! input U component
+REAL, DIMENSION(:,:), INTENT(IN) :: PV ! input V component
+INTEGER, INTENT(IN) :: KGRID ! grid positions of components
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(OUT) :: PZC ! output U component
+REAL, DIMENSION(:,:), OPTIONAL, INTENT(OUT) :: PMC ! output V component
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HFMFILE ! Name of FM-file to write
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HRECU ! Name of the U article
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HRECV ! Name of the V article
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HCOMMENT ! Comment string
+!
+!* 0.2 declarations of local variables
+!
+REAL, DIMENSION(SIZE(PU,1),SIZE(PU,2),1) :: ZU3D,ZV3D
+REAL, DIMENSION(SIZE(PU,1),SIZE(PU,2),1) :: ZZC3D,ZMC3D
+INTEGER :: ILUOUT ! logical unit for output listing
+!-----------------------------------------------------------------
+!
+!CALL FMLOOK_ll(CLUOUT,CLUOUT,ILUOUT,IRESP)
+ILUOUT=6
+!
+ZU3D(:,:,1)=PU(:,:)
+ZV3D(:,:,1)=PV(:,:)
+!
+CALL UV_TO_ZONAL_AND_MERID3D(ZU3D,ZV3D,KGRID,PZC=ZZC3D,PMC=ZMC3D)
+IF (PRESENT(PZC).AND.PRESENT(PMC)) THEN
+ PZC(:,:)=ZZC3D(:,:,1)
+ PMC(:,:)=ZMC3D(:,:,1)
+ELSE
+ WRITE(ILUOUT,*) '- warning in uv_to_zonal_and_merid2d: bad optional arguments'
+ RETURN
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE UV_TO_ZONAL_AND_MERID2D
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/vert_coord.f90 b/LIBTOOLS/tools/diachro/src/mesonh/vert_coord.f90
new file mode 100644
index 0000000000000000000000000000000000000000..88d4e27fd34b82ffde049ba553ddf24faca1e6a1
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/vert_coord.f90
@@ -0,0 +1,253 @@
+! $Source$
+!-----------------------------------------------------------------
+! ######################
+ MODULE MODI_VERT_COORD
+! ######################
+!
+INTERFACE
+!
+ SUBROUTINE VERT_COORD(OSLEVE,PZS,PZSMT,PLEN1,PLEN2,PZHAT,PZZ)
+!
+LOGICAL, INTENT(IN) :: OSLEVE! flag for Sleve coordinate
+REAL, DIMENSION(:,:), INTENT(IN) :: PZS ! fine orography
+REAL, DIMENSION(:,:), INTENT(IN) :: PZSMT ! smooth orography
+REAL, INTENT(IN) :: PLEN1 ! Decay scale for smooth topography
+REAL, INTENT(IN) :: PLEN2 ! Decay scale for small-scale topography deviation
+REAL, DIMENSION(:), INTENT(IN) :: PZHAT ! Positions z in the cartesian plane
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PZZ ! True altitude of the w grid-point
+!
+END SUBROUTINE VERT_COORD
+!
+END INTERFACE
+!
+END MODULE MODI_VERT_COORD
+!
+!
+!
+! #############################
+ SUBROUTINE VERT_COORD(OSLEVE,PZS,PZSMT,PLEN1,PLEN2,PZHAT,PZZ)
+! #############################
+!
+!!**** *VERT_COORD* computes smoothed orography for SLEVE coordinate
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of the documentation
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Masson * Meteo-France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original nov 2005
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+LOGICAL, INTENT(IN) :: OSLEVE! flag for Sleve coordinate
+REAL, DIMENSION(:,:), INTENT(IN) :: PZS ! fine orography
+REAL, DIMENSION(:,:), INTENT(IN) :: PZSMT ! smooth orography
+REAL, INTENT(IN) :: PLEN1 ! Decay scale for smooth topography
+REAL, INTENT(IN) :: PLEN2 ! Decay scale for small-scale topography deviation
+REAL, DIMENSION(:), INTENT(IN) :: PZHAT ! Positions z in the cartesian plane
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PZZ ! True altitude of the w grid-point
+!
+!
+!* 0.2 declarations of local variables
+!
+!
+!-------------------------------------------------------------------------------
+!
+IF (OSLEVE) THEN
+! Sleve coordinate
+ CALL SLEVE_COORD(PZS,PZSMT,PLEN1,PLEN2,PZHAT,PZZ)
+ELSE
+! Gal Chen coordinate
+ CALL GALCHEN_COORD(PZS,PZHAT,PZZ)
+END IF
+!
+!-------------------------------------------------------------------------------
+CONTAINS
+!
+! #############################
+ SUBROUTINE SLEVE_COORD(PZS,PZSMT,PLEN1,PLEN2,PZHAT,PZZ)
+! #############################
+!
+!!**** *SLEVE_COORD* computes smoothed orography for SLEVE coordinate
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of the documentation
+!!
+!!
+!! AUTHOR
+!! ------
+!! G. Zangler * LA *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original nov 2005
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+USE MODD_PARAMETERS, ONLY : JPVEXT
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PZS ! fine orography
+REAL, DIMENSION(:,:), INTENT(IN) :: PZSMT ! smooth orography
+REAL, INTENT(IN) :: PLEN1 ! Decay scale for smooth topography
+REAL, INTENT(IN) :: PLEN2 ! Decay scale for small-scale topography deviation
+REAL, DIMENSION(:), INTENT(IN) :: PZHAT ! Positions z in the cartesian plane
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PZZ ! True altitude of the w grid-point
+!
+!* 0.2 declarations of local variables
+!
+INTEGER :: IIU ! number of points in X direction
+INTEGER :: IJU ! number of points in Y direction
+INTEGER :: IKU ! number of points in Z direction
+INTEGER :: IKE ! upper physical point
+!
+REAL :: ZH ! model top
+REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2)) :: ZZSMALL ! small-scale topography deviation (PZS-PZSMT)
+!
+!-------------------------------------------------------------------------------
+!
+IIU = SIZE(PZZ,1)
+IJU = SIZE(PZZ,2)
+IKU = SIZE(PZZ,3)
+IKE = IKU - JPVEXT
+!
+ZH = PZHAT(IKE+1)
+!
+ZZSMALL(:,:) = PZS(:,:) - PZSMT(:,:) ! Small-scale topography deviation
+!
+! Sleve coordinate
+PZZ(:,:,:) = SPREAD(SPREAD(PZHAT(:),1,IIU),2,IJU) + &
+ SPREAD(PZSMT(:,:),3,IKU) * SINH( (ZH - &
+ SPREAD(SPREAD(PZHAT(:),1,IIU),2,IJU) ) /PLEN1 ) / &
+ SINH( ZH /PLEN1 ) + &
+ SPREAD(ZZSMALL(:,:),3,IKU) * SINH( (ZH - &
+ SPREAD(SPREAD(PZHAT(:),1,IIU),2,IJU) ) /PLEN2 ) / &
+ SINH( ZH /PLEN2 )
+
+! Ensure symmetry of layer depths below/above the true surface level
+! This is essential (!) for a correct surface pressure gradient computation over sloping topography
+!
+PZZ(:,:,1) = 2.*PZZ(:,:,2)-PZZ(:,:,3)
+!
+!-------------------------------------------------------------------------------
+END SUBROUTINE SLEVE_COORD
+!
+!-------------------------------------------------------------------------------
+!
+! #############################
+ SUBROUTINE GALCHEN_COORD(PZS,PZHAT,PZZ)
+! #############################
+!
+!!**** *GALCHEN_COORD* computes smoothed orography for Gal-Chen coordinate
+!!
+!! PURPOSE
+!! -------
+!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of the documentation
+!!
+!!
+!! AUTHOR
+!! ------
+!! G. Zangler * LA *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original nov 2005
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+!
+USE MODD_PARAMETERS, ONLY : JPVEXT
+!
+IMPLICIT NONE
+!
+!* 0.1 declarations of arguments
+!
+REAL, DIMENSION(:,:), INTENT(IN) :: PZS ! fine orography
+REAL, DIMENSION(:), INTENT(IN) :: PZHAT ! Positions z in the cartesian plane
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PZZ ! True altitude of the w grid-point
+!
+!* 0.2 declarations of local variables
+!
+!
+INTEGER :: IIU ! number of points in X direction
+INTEGER :: IJU ! number of points in Y direction
+INTEGER :: IKU ! number of points in Z direction
+INTEGER :: IKE ! upper physical point
+!
+REAL :: ZH ! model top
+REAL, DIMENSION(SIZE(PZZ,1),SIZE(PZZ,2)) :: ZCOEF ! 1-zs/H
+!
+!-------------------------------------------------------------------------------
+!
+IIU = SIZE(PZZ,1)
+IJU = SIZE(PZZ,2)
+IKU = SIZE(PZZ,3)
+IKE = IKU - JPVEXT
+!
+ZH = PZHAT(IKE+1)
+!
+ZCOEF(:,:) = 1.-PZS(:,:)/ZH
+PZZ(:,:,:) = SPREAD(SPREAD(PZHAT(1:IKU),1,IIU),2,IJU) &
+ * SPREAD(ZCOEF(1:IIU,1:IJU),3,IKU) &
+ + SPREAD(PZS(1:IIU,1:IJU),3,IKU)
+!
+! This is essential (!) for a correct surface pressure gradient computation over sloping topography
+PZZ(:,:,1) = 2.*PZZ(:,:,2)-PZZ(:,:,3)
+!
+!-------------------------------------------------------------------------------
+END SUBROUTINE GALCHEN_COORD
+!
+!-------------------------------------------------------------------------------
+END SUBROUTINE VERT_COORD
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/write_diachro.f90 b/LIBTOOLS/tools/diachro/src/mesonh/write_diachro.f90
new file mode 100644
index 0000000000000000000000000000000000000000..f05606fc69dc99246f0e430b10f7f6d7bbcd2888
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/write_diachro.f90
@@ -0,0 +1,404 @@
+! ######spl
+ MODULE MODI_WRITE_DIACHRO
+! #########################
+!
+INTERFACE
+!
+SUBROUTINE WRITE_DIACHRO(HFILEDIA,HLUOUTDIA,HGROUP,HTYPE,KGRID, &
+ PDATIME,PVAR,PTRAJT,HTITRE,HUNITE,HCOMMENT, &
+ OICP, OJCP, OKCP, KIL, KIH, KJL, KJH, KKL, KKH, &
+ PTRAJX,PTRAJY,PTRAJZ,PMASK)
+CHARACTER(LEN=*) :: HFILEDIA,HLUOUTDIA
+CHARACTER(LEN=*) :: HGROUP, HTYPE
+CHARACTER(LEN=*),DIMENSION(:) :: HTITRE, HUNITE, HCOMMENT
+
+INTEGER,DIMENSION(:) :: KGRID
+INTEGER,OPTIONAL :: KIL, KIH
+INTEGER,OPTIONAL :: KJL, KJH
+INTEGER,OPTIONAL :: KKL, KKH
+LOGICAL,OPTIONAL :: OICP, OJCP, OKCP
+REAL,DIMENSION(:,:,:,:,:,:),OPTIONAL :: PMASK
+REAL,DIMENSION(:,:) :: PDATIME
+REAL,DIMENSION(:,:,:,:,:,:) :: PVAR
+REAL,DIMENSION(:,:) :: PTRAJT
+REAL,DIMENSION(:,:,:),OPTIONAL :: PTRAJX
+REAL,DIMENSION(:,:,:),OPTIONAL :: PTRAJY
+REAL,DIMENSION(:,:,:),OPTIONAL :: PTRAJZ
+
+END SUBROUTINE WRITE_DIACHRO
+!
+END INTERFACE
+!
+END MODULE MODI_WRITE_DIACHRO
+! ##################################################################
+ SUBROUTINE WRITE_DIACHRO(HFILEDIA,HLUOUTDIA,HGROUP,HTYPE, &
+ KGRID,PDATIME,PVAR,PTRAJT, &
+ HTITRE,HUNITE,HCOMMENT,OICP,OJCP,OKCP,KIL,KIH,KJL,KJH,KKL,KKH, &
+ PTRAJX,PTRAJY,PTRAJZ,PMASK)
+! ##################################################################
+!
+!!**** *WRITE_DIACHRO* - Ecriture d'un enregistrement dans un fichier
+!! diachronique (de nom de base HGROUP)
+!!
+!! PURPOSE
+!! -------
+!
+!
+!!** METHOD
+!! ------
+!! En fait pour un groupe donne HGROUP, on ecrit systematiquement
+! plusieurs enregistrements :
+! - 1: HGROUP.TYPE (type d'informations a enregistrer)
+! - 2: HGROUP.DIM (dimensions de toutes les matrices a
+! enregistrer)
+! - 3: HGROUP.TITRE (Nom des processus)
+! - 4: HGROUP.UNITE (Unites pour chaque processus)
+! - 5: HGROUP.COMMENT (Champ commentaire pour chaque processus)
+! - 6: HGROUP.TRAJT (Temps)
+! - 7: HGROUP.PROCx (Champ traite . 1 enr./ 1 processus)
+! - 8: HGROUP.DATIM (Les differentes dates du modele)
+! et pour certains types d'informations on enregistre egalement
+! des coordonnees (HGROUP.TRAJX, HGROUP.TRAJY, HGROUP.TRAJZ)
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! J. Duron * Laboratoire d'Aerologie *
+!!
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 08/01/96
+!! Updated PM
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODI_MENU_DIACHRO
+!USE MODD_BUDGET
+USE MODI_FMWRIT
+
+IMPLICIT NONE
+!
+!* 0.1 Dummy arguments
+! ---------------
+
+CHARACTER(LEN=*) :: HFILEDIA,HLUOUTDIA
+CHARACTER(LEN=*) :: HGROUP, HTYPE
+CHARACTER(LEN=*),DIMENSION(:) :: HTITRE, HUNITE, HCOMMENT
+
+INTEGER,DIMENSION(:) :: KGRID
+INTEGER,OPTIONAL :: KIL, KIH
+INTEGER,OPTIONAL :: KJL, KJH
+INTEGER,OPTIONAL :: KKL, KKH
+LOGICAL,OPTIONAL :: OICP, OJCP, OKCP
+REAL,DIMENSION(:,:,:,:,:,:),OPTIONAL :: PMASK
+REAL,DIMENSION(:,:,:,:,:,:) :: PVAR
+REAL,DIMENSION(:,:) :: PDATIME
+REAL,DIMENSION(:,:) :: PTRAJT
+REAL,DIMENSION(:,:,:),OPTIONAL :: PTRAJX
+REAL,DIMENSION(:,:,:),OPTIONAL :: PTRAJY
+REAL,DIMENSION(:,:,:),OPTIONAL :: PTRAJZ
+
+!
+!* 0.1 Local variables
+! ---------------
+
+!
+CHARACTER(LEN=16) :: YRECFM
+CHARACTER(LEN=LEN(HFILEDIA)+4) :: YFILEDIA
+CHARACTER(LEN=20) :: YCOMMENT
+CHARACTER(LEN=2) :: YJ
+INTEGER :: ILENG, ILENCH, ILENTITRE, ILENUNITE, ILENCOMMENT, ILE, IRESP
+INTEGER :: ILUOUTDIA, IRESPDIA,INPRARDIA,IFTYPEDIA,IVERBDIA,ININARDIA
+INTEGER :: II, IJ, IK, IT, IN, IP, INUM, J, JJ, JM
+INTEGER :: INTRAJT, IKTRAJX, IKTRAJY, IKTRAJZ
+INTEGER :: ITTRAJX, ITTRAJY, ITTRAJZ
+INTEGER :: INTRAJX, INTRAJY, INTRAJZ
+INTEGER :: IIMASK, IJMASK, IKMASK, ITMASK, INMASK, IPMASK
+INTEGER :: ICOMPX, ICOMPY, ICOMPZ
+INTEGER,DIMENSION(:),ALLOCATABLE :: ITABCHAR
+!------------------------------------------------------------------------------
+!
+YCOMMENT=' '
+ILENCH = LEN(YCOMMENT)
+
+II = SIZE(PVAR,1) ; IT = SIZE(PVAR,4)
+IJ = SIZE(PVAR,2) ; IN = SIZE(PVAR,5)
+IK = SIZE(PVAR,3) ; IP = SIZE(PVAR,6)
+
+INTRAJT=SIZE(PTRAJT,2)
+
+IKTRAJX=0; IKTRAJY=0; IKTRAJZ=0
+ITTRAJX=0; ITTRAJY=0; ITTRAJZ=0
+INTRAJX=0; INTRAJY=0; INTRAJZ=0
+IF(PRESENT(PTRAJX))THEN
+ IKTRAJX=SIZE(PTRAJX,1)
+ ITTRAJX=SIZE(PTRAJX,2)
+ INTRAJX=SIZE(PTRAJX,3)
+ENDIF
+IF(PRESENT(PTRAJY))THEN
+ IKTRAJY=SIZE(PTRAJY,1)
+ ITTRAJY=SIZE(PTRAJY,2)
+ INTRAJY=SIZE(PTRAJY,3)
+ENDIF
+IF(PRESENT(PTRAJZ))THEN
+ IKTRAJZ=SIZE(PTRAJZ,1)
+ ITTRAJZ=SIZE(PTRAJZ,2)
+ INTRAJZ=SIZE(PTRAJZ,3)
+ENDIF
+
+IIMASK=0; IJMASK=0; IKMASK=0; ITMASK=0; INMASK=0; IPMASK=0
+IF(PRESENT(PMASK))THEN
+ IIMASK=SIZE(PMASK,1)
+ IJMASK=SIZE(PMASK,2)
+ IKMASK=SIZE(PMASK,3)
+ ITMASK=SIZE(PMASK,4)
+ INMASK=SIZE(PMASK,5)
+ IPMASK=SIZE(PMASK,6)
+ENDIF
+
+ILENTITRE = LEN(HTITRE)
+ILENUNITE = LEN(HUNITE)
+ILENCOMMENT = LEN(HCOMMENT)
+
+ICOMPX=0; ICOMPY=0; ICOMPZ=0
+IF(PRESENT(OICP))THEN
+IF(OICP)THEN
+ ICOMPX=1
+ENDIF
+IF(OJCP)THEN
+ ICOMPY=1
+ENDIF
+IF(OKCP)THEN
+ ICOMPZ=1
+ENDIF
+ENDIF
+CALL FMLOOK(HLUOUTDIA,HLUOUTDIA,ILUOUTDIA,IRESP)
+WRITE(ILUOUTDIA,*)' WRITE_DIACHRO IRESP ',IRESP
+IF(IRESP == -54)THEN
+ CALL FMATTR(HLUOUTDIA,HLUOUTDIA,ILUOUTDIA,IRESPDIA)
+ OPEN(UNIT=ILUOUTDIA,FILE=HLUOUTDIA)
+ IFTYPEDIA = 0; IVERBDIA = 5
+ENDIF
+YFILEDIA=ADJUSTL(ADJUSTR(HFILEDIA)//'.lfi')
+CALL FMLOOK(YFILEDIA,HLUOUTDIA,INUM,IRESPDIA)
+WRITE(ILUOUTDIA,*)' WRITE_DIACHRO IRESPDIA ',IRESPDIA
+IF(IRESPDIA == -54)THEN
+! Modif demandee par Nicole Asencio. 28/9/98
+ IFTYPEDIA=2
+ CALL FMOPEN(HFILEDIA,'NEW',HLUOUTDIA,INPRARDIA,IFTYPEDIA,IVERBDIA, &
+ ININARDIA,IRESPDIA)
+END IF
+
+!
+! 1er enregistrement TYPE
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TYPE')
+ILENG = LEN(HTYPE)
+ALLOCATE(ITABCHAR(ILENG))
+DO J = 1,ILENG
+ ITABCHAR(J) = ICHAR(HTYPE(J:J))
+ENDDO
+!print *,SIZE(ITABCHAR),' ITABCHAR ',ITABCHAR,' KGRID ',KGRID,HLUOUTDIA,HFILEDIA
+CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ITABCHAR,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+WRITE(ILUOUTDIA,*)' 1er ENREGISTREMENT OK'
+DEALLOCATE(ITABCHAR)
+!
+! 2eme enregistrement DIMENSIONS des MATRICES et LONGUEUR des TABLEAUX de CARACTERES et FLAGS de COMPRESSION sur les DIFFERENTS AXES
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.DIM')
+SELECT CASE(HTYPE)
+ CASE('CART','MASK','SPXY')
+ ILENG = 34
+ ALLOCATE(ITABCHAR(ILENG))
+ ITABCHAR(1)=ILENTITRE; ITABCHAR(2)=ILENUNITE
+ ITABCHAR(3)=ILENCOMMENT; ITABCHAR(4)=II
+ ITABCHAR(5)=IJ; ITABCHAR(6)=IK
+ ITABCHAR(7)=IT; ITABCHAR(8)=IN
+ ITABCHAR(9)=IP; ITABCHAR(10)=KIL
+ ITABCHAR(11)=KJL; ITABCHAR(12)=KKL
+ ITABCHAR(13)=KIH; ITABCHAR(14)=KJH
+ ITABCHAR(15)=KKH; ITABCHAR(16)=ICOMPX
+ ITABCHAR(17)=ICOMPY; ITABCHAR(18)=ICOMPZ
+ IF(HTYPE == 'MASK')THEN
+! ITABCHAR(10)=1; ITABCHAR(11)=1
+! ITABCHAR(13)=1; ITABCHAR(14)=1
+ ITABCHAR(16)=1; ITABCHAR(17)=1
+ ENDIF
+ ITABCHAR(19)=INTRAJT; ITABCHAR(20)=IKTRAJX
+ ITABCHAR(21)=IKTRAJY; ITABCHAR(22)=IKTRAJZ
+ ITABCHAR(23)=ITTRAJX; ITABCHAR(24)=ITTRAJY
+ ITABCHAR(25)=ITTRAJZ; ITABCHAR(26)=INTRAJX
+ ITABCHAR(27)=INTRAJY; ITABCHAR(28)=INTRAJZ
+ ITABCHAR(29)=IIMASK; ITABCHAR(30)=IJMASK
+ ITABCHAR(31)=IKMASK; ITABCHAR(32)=ITMASK
+ ITABCHAR(33)=INMASK; ITABCHAR(34)=IPMASK
+ CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+ WRITE(ILUOUTDIA,*)' ILENTITRE,ILENUNITE,ILENCOMMENT ',ILENTITRE,ILENUNITE,ILENCOMMENT
+ DEALLOCATE(ITABCHAR)
+ CASE DEFAULT
+ ILENG = 25
+ ALLOCATE(ITABCHAR(ILENG))
+ ITABCHAR(1)=ILENTITRE; ITABCHAR(2)=ILENUNITE
+ ITABCHAR(3)=ILENCOMMENT; ITABCHAR(4)=II
+ ITABCHAR(5)=IJ; ITABCHAR(6)=IK
+ ITABCHAR(7)=IT; ITABCHAR(8)=IN
+ ITABCHAR(9)=IP
+ ITABCHAR(10)=INTRAJT; ITABCHAR(11)=IKTRAJX
+ ITABCHAR(12)=IKTRAJY; ITABCHAR(13)=IKTRAJZ
+ ITABCHAR(14)=ITTRAJX; ITABCHAR(15)=ITTRAJY
+ ITABCHAR(16)=ITTRAJZ; ITABCHAR(17)=INTRAJX
+ ITABCHAR(18)=INTRAJY; ITABCHAR(19)=INTRAJZ
+ ITABCHAR(20)=IIMASK; ITABCHAR(21)=IJMASK
+ ITABCHAR(22)=IKMASK; ITABCHAR(23)=ITMASK
+ ITABCHAR(24)=INMASK; ITABCHAR(25)=IPMASK
+! CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ILENTITRE,ILENUNITE, &
+! ILENCOMMENT,II,IJ,IK,IT,IN,IP,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+ CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG,ITABCHAR, &
+ KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+ DEALLOCATE(ITABCHAR)
+END SELECT
+WRITE(ILUOUTDIA,*)' 2eme ENREGISTREMENT OK'
+!
+! 3eme enregistrement TITRE
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TITRE')
+ILE = LEN(HTITRE)
+ILENG = ILE*IP
+ALLOCATE(ITABCHAR(ILENG))
+DO JJ = 1,IP
+DO J = 1,ILE
+ ITABCHAR(ILE*(JJ-1)+J) = ICHAR(HTITRE(JJ)(J:J))
+ENDDO
+WRITE(ILUOUTDIA,*)HTITRE(JJ)
+ENDDO
+CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ITABCHAR,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+WRITE(ILUOUTDIA,*)' 3eme ENREGISTREMENT OK'
+DEALLOCATE(ITABCHAR)
+!
+! 4eme enregistrement UNITE
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.UNITE')
+ILE = LEN(HUNITE)
+ILENG = ILE*IP
+ALLOCATE(ITABCHAR(ILENG))
+DO JJ = 1,IP
+DO J = 1,ILE
+ ITABCHAR(ILE*(JJ-1)+J) = ICHAR(HUNITE(JJ)(J:J))
+ENDDO
+WRITE(ILUOUTDIA,*)HUNITE(JJ)
+ENDDO
+CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ITABCHAR,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+WRITE(ILUOUTDIA,*)' 4eme ENREGISTREMENT OK'
+DEALLOCATE(ITABCHAR)
+!
+! 5eme enregistrement COMMENT
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.COMMENT')
+ILE = LEN(HCOMMENT)
+ILENG = ILE*IP
+ALLOCATE(ITABCHAR(ILENG))
+DO JJ = 1,IP
+DO J = 1,ILE
+ ITABCHAR(ILE*(JJ-1)+J) = ICHAR(HCOMMENT(JJ)(J:J))
+ENDDO
+WRITE(ILUOUTDIA,*)HCOMMENT(JJ)
+ENDDO
+CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ITABCHAR,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+WRITE(ILUOUTDIA,*)' 5eme ENREGISTREMENT OK'
+DEALLOCATE(ITABCHAR)
+!
+! 6eme enregistrement PVAR
+!
+! Dans la mesure ou cette matrice risque d'etre tres volumineuse, on ecrira un
+! enregistrement par processus
+DO J = 1,IP
+YJ = ' '
+IF(J < 10)WRITE(YJ,'(I1)')J ; YJ = ADJUSTL(YJ)
+IF(J >= 10 .AND. J < 100)WRITE(YJ,'(I2)')J
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.PROC'//YJ)
+ILENG = II*IJ*IK*IT*IN
+CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ PVAR(:,:,:,:,:,J),KGRID(J),ILENCH,YCOMMENT,IRESPDIA)
+WRITE(ILUOUTDIA,*)' 6eme ENREGISTREMENT OK'
+ENDDO
+!
+! 7eme enregistrement TRAJT
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TRAJT')
+ILENG = IT*INTRAJT
+CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+PTRAJT,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+!
+! Dans certains cas
+!
+!
+! 8eme enregistrement TRAJX
+!
+IF(PRESENT(PTRAJX))THEN
+ YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TRAJX')
+ ILENG = IKTRAJX*ITTRAJX*INTRAJX
+ CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ PTRAJX,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+ENDIF
+!
+! ou
+!
+IF(PRESENT(PMASK))THEN
+ YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.MASK')
+ ILENG = IIMASK*IJMASK*IKMASK*ITMASK*INMASK*IPMASK
+ CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ PMASK,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+ENDIF
+!
+! 9eme enregistrement TRAJY
+!
+IF(PRESENT(PTRAJY))THEN
+ YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TRAJY')
+ ILENG = IKTRAJY*ITTRAJY*INTRAJY
+ CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ PTRAJY,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+ENDIF
+!
+! 10eme enregistrement TRAJZ
+!
+IF(PRESENT(PTRAJZ))THEN
+ YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.TRAJZ')
+ ILENG = IKTRAJZ*ITTRAJZ*INTRAJZ
+ CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+ PTRAJZ,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+ENDIF
+!
+! 11eme enregistrement PDATIME
+!
+YRECFM = ADJUSTL(ADJUSTR(HGROUP)//'.DATIM')
+ILENG=16*IT
+CALL FMWRIT(HFILEDIA,YRECFM,HLUOUTDIA,ILENG, &
+PDATIME,KGRID(1),ILENCH,YCOMMENT,IRESPDIA)
+!
+CALL MENU_DIACHRO(HFILEDIA,HLUOUTDIA,HGROUP)
+!-----------------------------------------------------------------------------
+!
+!* 2. EXITS
+! -----
+!
+RETURN
+END SUBROUTINE WRITE_DIACHRO
diff --git a/LIBTOOLS/tools/diachro/src/mesonh/write_lfifm1_fordiachro_cv.f90 b/LIBTOOLS/tools/diachro/src/mesonh/write_lfifm1_fordiachro_cv.f90
new file mode 100644
index 0000000000000000000000000000000000000000..20fe8c6b025ea71308de8b9395c02b27805f5532
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh/write_lfifm1_fordiachro_cv.f90
@@ -0,0 +1,623 @@
+! ######spl
+ MODULE MODI_WRITE_LFIFM1_FORDIACHRO_CV
+! ########################################
+!
+INTERFACE
+!
+SUBROUTINE WRITE_LFIFM1_FORDIACHRO_CV(HFMFILE)
+CHARACTER(LEN=28), INTENT(IN) :: HFMFILE ! Name of FM-file to write
+END SUBROUTINE WRITE_LFIFM1_FORDIACHRO_CV
+!
+END INTERFACE
+!
+END MODULE MODI_WRITE_LFIFM1_FORDIACHRO_CV
+! ##############################################
+ SUBROUTINE WRITE_LFIFM1_FORDIACHRO_CV(HFMFILE)
+! ##############################################
+!
+!!**** *WRITE_LFIFM1_FORDIACHRO_CV* - routine pour l'ecriture dans un
+!! fichier diachronique des dimensions, parametres de grille
+!! et etat de ref. lus dans les fichiers d'entree
+!!
+!! PURPOSE
+!! -------
+! Voir la routine write_lfifmn_fordiachron de mesonh.
+! Ici (_CV pour conv) ecriture en plus de MY_NAME, DAD_NAME,
+! DXRATIO, DYRATIO, XOR, YOR, XEND, YEND,
+! ainsi que traitement special pour ZS dans le cas 2D (recopie sur pts de
+! garde).
+!
+!!** METHOD
+!! ------
+!! The data written in the LFIFM file are :
+!! - dimensions
+!! - grid variables
+!! - configuration variables
+!! - 1D anelastic reference state
+!!
+!!
+!! EXTERNAL
+!! --------
+!! FMWRIT : FM-routine to write a record
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_DIM1 : contains dimensions
+!! Module MODD_TIME1 : contains time variables and uses MODD_TIME
+!! Module MODD_GRID : contains spatial grid variables for all models
+!! Module MODD_GRID1 : contains spatial grid variables
+!! Module MODD_REF : contains reference state variables
+!! Module MODD_LUNIT1: contains logical unit variables.
+!! Module MODD_CONF : contains configuration variables for all models
+!! Module MODD_CONF1 : contains configuration variables
+!! Module MODD_PARAM1 : contains parameterization options
+!!
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/05/94
+!! V. Ducrocq 27/06/94
+!! J.Stein 20/10/94 (name of the FMFILE)
+!! I. Mallet 09/04 for conv2dia: write MASDEV (for masdev4_6)
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF, ONLY: CPROGRAM,CSTORAGE_TYPE,LCARTESIAN,LTHINSHELL, &
+ NMASDEV,NBUGFIX,L1D,L2D,LPACK
+USE MODD_DIM1, ONLY: NIMAX,NJMAX,NKMAX
+USE MODD_GRID, ONLY: XRPK,XLON0,XLAT0,XBETA,XLONORI,XLATORI
+USE MODD_GRID1, ONLY: XXHAT,XYHAT,XZHAT,XZS,XZSMT,LSLEVE,XLEN1,XLEN2
+USE MODD_LUNIT1, ONLY: CLUOUT
+USE MODD_PARAM1, ONLY: CSURF
+USE MODD_TIME, ONLY: TDTEXP,TDTSEG
+USE MODD_TIME1, ONLY: TDTCUR,TDTMOD
+USE MODD_NESTING, ONLY: NDXRATIO_ALL,NDYRATIO_ALL, &
+ NXOR_ALL,NYOR_ALL,NXEND_ALL,NYEND_ALL
+USE MODD_PARAMETERS, ONLY: JPHEXT
+!
+USE MODD_DIACHRO, ONLY: CMY_NAME_DIA,CDAD_NAME_DIA
+USE MODD_DIMGRID_FORDIACHRO
+USE MODD_OUT_DIA
+!
+USE MODI_FMREAD
+USE MODI_FMWRIT
+!
+USE MODE_GRIDPROJ
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=28), INTENT(IN) :: HFMFILE ! Name of FM-file to write
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: IRESP ! IRESP : return-code if a problem appears
+ ! at the open of the file ! LFI routines
+INTEGER :: IGRID,ILENG ! IGRID : grid indicator
+ ! ILENG : length of the data field
+INTEGER :: ILENCH ! ILENCH : length of comment string
+INTEGER :: JT,JLOOP ! loop index
+INTEGER :: J ! loop index
+!
+CHARACTER(LEN=16) :: YRECFM ! Name of the article to be written
+CHARACTER(LEN=20) :: YCOMMENT ! Comment string
+CHARACTER(LEN=100) :: YCOMM ! Comment string
+!
+REAL :: ZLATOR, ZLONOR ! geographical coordinates of 1st mass point
+REAL :: ZXHATM, ZYHATM ! conformal coordinates of 1st mass point
+REAL, DIMENSION(:), ALLOCATABLE :: ZXHAT_ll ! Position x in the conformal
+ ! plane (array on the complete domain)
+REAL, DIMENSION(:), ALLOCATABLE :: ZYHAT_ll ! Position y in the conformal
+ ! plane (array on the complete domain)
+!
+INTEGER, DIMENSION(3) :: ITDATE ! date array
+INTEGER,DIMENSION(2) :: ISTORAGE_TYPE
+INTEGER, DIMENSION(28) :: INAME ! name array for HFMFILE
+ ! and HDADFILE writing
+REAL,DIMENSION(:),ALLOCATABLE,SAVE :: ZXZS
+REAL :: ZTDATE ! seconds
+!
+LOGICAL :: GPACK
+!-------------------------------------------------------------------------------
+!
+!* 1. WRITES IN THE LFI FILE
+! -----------------------
+!
+GPACK=LPACK
+IF(L1D .OR. L2D) THEN
+ print*,'** Warning PACK forced to FALSE because of duplication **'
+ ! cf IMULT dans write_othersfields.f90
+ LPACK=.FALSE.
+ENDIF
+!* 1.0 Version :
+!
+YRECFM='MASDEV'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,NMASDEV,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='BUGFIX'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,NBUGFIX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='L1D'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,L1D,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='L2D'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,L2D,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='PACK'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,LPACK,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='SURF'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=4
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,CSURF,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+!* 1.1 Dimensions :
+!
+YRECFM='MY_NAME'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=28
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+DO JLOOP=1,28
+ INAME(JLOOP)=IACHAR(CMY_NAME_DIA(JLOOP:JLOOP))
+!INAME(JLOOP)=IACHAR(HFMFILE(JLOOP:JLOOP))
+END DO
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,INAME,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='DAD_NAME'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=28
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+DO JLOOP=1,28
+ INAME(JLOOP)=IACHAR(CDAD_NAME_DIA(JLOOP:JLOOP))
+END DO
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,INAME,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+IF (LEN_TRIM(CDAD_NAME_DIA)>0) THEN
+ CALL FMWRIT(HFMFILE,'DXRATIO',CLUOUT,1,NDXRATIO_ALL(1),0,ILENCH,YCOMMENT,IRESP)
+ CALL ELIM('DXRATIO')
+ CALL FMWRIT(HFMFILE,'DYRATIO',CLUOUT,1,NDYRATIO_ALL(1),0,ILENCH,YCOMMENT,IRESP)
+ CALL ELIM('DYRATIO')
+ CALL FMWRIT(HFMFILE,'XOR' ,CLUOUT,1,NXOR_ALL(1) ,0,ILENCH,YCOMMENT,IRESP)
+ CALL ELIM('XOR')
+ CALL FMWRIT(HFMFILE,'YOR' ,CLUOUT,1,NYOR_ALL(1) ,0,ILENCH,YCOMMENT,IRESP)
+ CALL ELIM('YOR')
+ CALL FMWRIT(HFMFILE,'XEND',CLUOUT,1,NXEND_ALL(1),0,ILENCH,YCOMMENT,IRESP)
+ CALL ELIM('XEND')
+ CALL FMWRIT(HFMFILE,'YEND',CLUOUT,1,NYEND_ALL(1),0,ILENCH,YCOMMENT,IRESP)
+ CALL ELIM('YEND')
+END IF
+
+YRECFM='STORAGE_TYPE'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=2
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+ISTORAGE_TYPE(1)=IACHAR(CSTORAGE_TYPE(1:1))
+ISTORAGE_TYPE(2)=IACHAR(CSTORAGE_TYPE(2:2))
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,ISTORAGE_TYPE,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='IMAX'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,NIMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='JMAX'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,NJMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='KMAX'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,NKMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='JPHEXT'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,JPHEXT,IGRID,ILENCH,YCOMMENT,IRESP)
+!* 1.2 Grid variables :
+!
+IF (.NOT.LCARTESIAN) THEN
+!
+ YRECFM='RPK'
+ CALL ELIM(YRECFM)
+ YCOMMENT=' '
+ ILENG=1
+ IGRID=0
+ ILENCH=LEN(YCOMMENT)
+ CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XRPK,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+ YRECFM='LONORI'
+ CALL ELIM(YRECFM)
+ YCOMMENT='DEGREES'
+ ILENG=1
+ IGRID=0
+ ILENCH=LEN(YCOMMENT)
+ CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XLONORI,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+ YRECFM='LATORI'
+ CALL ELIM(YRECFM)
+ YCOMMENT='DEGREES'
+ ILENG=1
+ IGRID=0
+ ILENCH=LEN(YCOMMENT)
+ CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XLATORI,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+!* diagnostic of 1st mass point
+!
+ !ALLOCATE(ZXHAT_ll(NIMAX_ll+ 2 * JPHEXT),ZYHAT_ll(NJMAX_ll+2 * JPHEXT))
+ !CALL GATHERALL_FIELD_ll('XX',XXHAT,ZXHAT_ll,IRESP) !//
+ !CALL GATHERALL_FIELD_ll('YY',XYHAT,ZYHAT_ll,IRESP) !//
+ !ZXHATM = 0.5 * (ZXHAT_ll(1)+ZXHAT_ll(2))
+ !ZYHATM = 0.5 * (ZYHAT_ll(1)+ZYHAT_ll(2))
+ ZXHATM = 0.5 * (XXHAT(1)+XXHAT(2))
+ ZYHATM = 0.5 * (XYHAT(1)+XYHAT(2))
+ CALL SM_LATLON(XLATORI,XLONORI,ZXHATM,ZYHATM,ZLATOR,ZLONOR)
+ !DEALLOCATE(ZXHAT_ll,ZYHAT_ll)
+!
+ YRECFM='LONOR'
+ CALL ELIM(YRECFM)
+ YCOMMENT='DEGREES'
+ ILENG=1
+ IGRID=0
+ ILENCH=LEN(YCOMMENT)
+ CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,ZLONOR,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+ YRECFM='LATOR'
+ CALL ELIM(YRECFM)
+ YCOMMENT='DEGREES'
+ ILENG=1
+ IGRID=0
+ ILENCH=LEN(YCOMMENT)
+ CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,ZLATOR,IGRID,ILENCH,YCOMMENT,IRESP)
+END IF
+!
+YRECFM='THINSHELL'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,LTHINSHELL,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='LAT0'
+CALL ELIM(YRECFM)
+YCOMMENT='DEGREES'
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XLAT0,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='LON0'
+CALL ELIM(YRECFM)
+YCOMMENT='DEGREES'
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XLON0,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='BETA'
+CALL ELIM(YRECFM)
+YCOMMENT='DEGREES'
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XBETA,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='XHAT'
+CALL ELIM(YRECFM)
+YCOMMENT='METERS'
+ILENG=SIZE(XXHAT)
+IGRID=2
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XXHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='YHAT'
+CALL ELIM(YRECFM)
+YCOMMENT='METERS'
+ILENG=SIZE(XYHAT)
+IGRID=3
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XYHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='ZHAT'
+CALL ELIM(YRECFM)
+YCOMMENT='METERS'
+ILENG=SIZE(XZHAT)
+IGRID=4
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XZHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='ZS'
+! 051296 Non elimine . Pour l'enregister avec le nom ZSBIS
+!CALL ELIM(YRECFM)
+YCOMMENT='METERS'
+!print *,' NIMAX JPHEXT SIZE(XZS) ',NIMAX,JPHEXT,SIZE(XZS)
+JT=0
+DO J=1,NNB
+ IF(CRECFM2T(J,1) == 'ZS')THEN
+ JT=J
+ EXIT
+ ENDIF
+ENDDO
+!IF(JT /= 0 .AND.NSIZT(JT,1) == NIMAX+2*JPHEXT)THEN
+! expression evaluee l autre apres l autre
+IF(JT /= 0 )THEN
+IF(NSIZT(JT,1) == NIMAX+2*JPHEXT)THEN
+ ALLOCATE(ZXZS(NIMAX+2*JPHEXT))
+ ILENG=NIMAX+2*JPHEXT
+! Test sur la longueur du champ commentaire
+! Ajout le 4 Mai 2001 pour la prise en compte des commentaires >= 20 et <= 100
+! Cf instruction suivante apres .OR. -> Je charge dans un commentaire len=100
+ IF(NLENC(JT,1) == LEN(YCOMM) .OR. &
+ (NLENC(JT,1) > LEN(YCOMMENT).AND. NLENC(JT,1) <= LEN(YCOMM)))THEN
+ !IM!ILENCH=LEN(YCOMM) (output arg.)
+ CALL FMREAD(CNAMFILED(1),YRECFM,CLUOUT,ILENG,ZXZS,IGRID,ILENCH,YCOMM,IRESP)
+ ELSE IF(NLENC(JT,1) == LEN(YCOMMENT))THEN
+ !IM!ILENCH=LEN(YCOMMENT) (output arg.)
+ CALL FMREAD(CNAMFILED(1),YRECFM,CLUOUT,ILENG,ZXZS,IGRID,ILENCH,YCOMMENT,IRESP)
+ ELSE
+ print *,' Longueur du champ commentaire differente de 20 ou 100 . Imprevue ! ',NLENC(JT,1)
+ ENDIF
+print *,' Size ZXZS ',SIZE(ZXZS)
+print *,' Size XZS 1 2 ',SIZE(XZS,1),SIZE(XZS,2)
+ DO J=1,NJMAX+2*JPHEXT
+ XZS(1:SIZE(XZS,1),J)=ZXZS(:)
+ ENDDO
+!print *,' XZS(60,:) ',XZS(60,:),XZS(150,:)
+ ILENG=SIZE(XZS)
+! print *,' XZS',XZS(:,1)
+! print *,' XZS',XZS(:,2)
+! print *,' XZS',XZS(:,3)
+ELSE
+ ILENG=SIZE(XZS)
+ENDIF
+ENDIF
+IF (JT==0 )THEN
+ ILENG=SIZE(XZS)
+ENDIF
+IGRID=4
+ILENCH=LEN(YCOMMENT)
+IF(ALLOCATED(ZXZS))THEN
+ DEALLOCATE(ZXZS)
+ENDIF
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XZS,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='ZSMT'
+! 120106 Non elimine . Pour l'enregister avec le nom ZSMTBIS
+!CALL ELIM(YRECFM)
+YCOMMENT='METERS'
+ILENG=SIZE(XZSMT)
+IGRID=4
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XZSMT,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='SLEVE'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=1
+IGRID=4
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,LSLEVE,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+IF (LSLEVE) THEN
+ YRECFM='LEN1'
+ CALL ELIM(YRECFM)
+ YCOMMENT='METERS'
+ ILENG=1
+ IGRID=4
+ ILENCH=LEN(YCOMMENT)
+ CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XLEN1,IGRID,ILENCH,YCOMMENT,IRESP)
+ YRECFM='LEN2'
+ CALL ELIM(YRECFM)
+ YCOMMENT='METERS'
+ ILENG=1
+ IGRID=4
+ ILENCH=LEN(YCOMMENT)
+ CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XLEN2,IGRID,ILENCH,YCOMMENT,IRESP)
+END IF
+!
+YRECFM='DTCUR%TDATE' ! array of rank 3 for date is written in file
+CALL ELIM(YRECFM)
+YCOMMENT='YYYYMMDD'
+ITDATE(1)=TDTCUR%TDATE%YEAR
+ITDATE(2)=TDTCUR%TDATE%MONTH
+ITDATE(3)=TDTCUR%TDATE%DAY
+ILENG=3
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+YRECFM='DTCUR%TIME'
+CALL ELIM(YRECFM)
+YCOMMENT='SECONDS'
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,TDTCUR%TIME,IGRID,ILENCH, &
+ YCOMMENT,IRESP)
+!
+YRECFM='DTEXP%TDATE' ! array of rank 3 for date is written in file
+CALL ELIM(YRECFM)
+YCOMMENT='YYYYMMDD'
+IF (CSTORAGE_TYPE=='SU') THEN
+ ITDATE(1)=TDTCUR%TDATE%YEAR
+ ITDATE(2)=TDTCUR%TDATE%MONTH
+ ITDATE(3)=TDTCUR%TDATE%DAY
+ ZTDATE =TDTCUR%TIME
+ELSE
+ ITDATE(1)=TDTEXP%TDATE%YEAR
+ ITDATE(2)=TDTEXP%TDATE%MONTH
+ ITDATE(3)=TDTEXP%TDATE%DAY
+ ZTDATE =TDTEXP%TIME
+ENDIF
+ILENG=3
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+YRECFM='DTEXP%TIME'
+CALL ELIM(YRECFM)
+YCOMMENT='SECONDS'
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,ZTDATE,IGRID,ILENCH, &
+ YCOMMENT,IRESP)
+!
+YRECFM='DTMOD%TDATE' ! array of rank 3 for date is written in file
+CALL ELIM(YRECFM)
+YCOMMENT='YYYYMMDD'
+IF (CSTORAGE_TYPE=='SU') THEN
+ ITDATE(1)=TDTCUR%TDATE%YEAR
+ ITDATE(2)=TDTCUR%TDATE%MONTH
+ ITDATE(3)=TDTCUR%TDATE%DAY
+ ZTDATE =TDTCUR%TIME
+ELSE
+ ITDATE(1)=TDTMOD%TDATE%YEAR
+ ITDATE(2)=TDTMOD%TDATE%MONTH
+ ITDATE(3)=TDTMOD%TDATE%DAY
+ ZTDATE =TDTMOD%TIME
+ENDIF
+ILENG=3
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+YRECFM='DTMOD%TIME'
+CALL ELIM(YRECFM)
+YCOMMENT='SECONDS'
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,ZTDATE,IGRID,ILENCH, &
+ YCOMMENT,IRESP)
+!
+YRECFM='DTSEG%TDATE' ! array of rank 3 for date is written in file
+CALL ELIM(YRECFM)
+YCOMMENT='YYYYMMDD'
+IF (CSTORAGE_TYPE=='SU') THEN
+ ITDATE(1)=TDTCUR%TDATE%YEAR
+ ITDATE(2)=TDTCUR%TDATE%MONTH
+ ITDATE(3)=TDTCUR%TDATE%DAY
+ ZTDATE =TDTCUR%TIME
+ELSE
+ ITDATE(1)=TDTSEG%TDATE%YEAR
+ ITDATE(2)=TDTSEG%TDATE%MONTH
+ ITDATE(3)=TDTSEG%TDATE%DAY
+ ZTDATE =TDTSEG%TIME
+ENDIF
+ILENG=3
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+YRECFM='DTSEG%TIME'
+CALL ELIM(YRECFM)
+YCOMMENT='SECONDS'
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,ZTDATE,IGRID,ILENCH, &
+ YCOMMENT,IRESP)
+!
+!* 1.3 Configuration variables :
+!
+YRECFM='CARTESIAN'
+CALL ELIM(YRECFM)
+YCOMMENT=' '
+ILENG=1
+IGRID=0
+ILENCH=LEN(YCOMMENT)
+CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,LCARTESIAN,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+!* 1.6 Reference state variables :
+!
+!YRECFM='RHOREFZ'
+!CALL ELIM(YRECFM)
+!IF (CPROGRAM(4:6)/='DIA') THEN
+ !YCOMMENT=' '
+ !ILENG=SIZE(XRHODREFZ)
+ !IGRID=4
+ !ILENCH=LEN(YCOMMENT)
+ !CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XRHODREFZ,IGRID,ILENCH,YCOMMENT,IRESP)
+!END IF
+!
+!YRECFM='THVREFZ'
+!CALL ELIM(YRECFM)
+!IF (CPROGRAM(4:6)/='DIA') THEN
+ !YCOMMENT=' '
+ !ILENG=SIZE(XTHVREFZ)
+ !IGRID=4
+ !ILENCH=LEN(YCOMMENT)
+ !CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XTHVREFZ,IGRID,ILENCH,YCOMMENT,IRESP)
+!END IF
+!
+!YRECFM='EXNTOP'
+!CALL ELIM(YRECFM)
+!IF (CPROGRAM(4:6)/='DIA') THEN
+ !YCOMMENT=' '
+ !ILENG=1
+ !IGRID=4
+ !ILENCH=LEN(YCOMMENT)
+ !CALL FMWRIT(HFMFILE,YRECFM,CLUOUT,ILENG,XEXNTOP,IGRID,ILENCH,YCOMMENT,IRESP)
+!END IF
+!
+!print *,' SORTIE WRITE_LFIFM1_FORDIACHRO_CV'
+!-------------------------------------------------------------------------------
+LPACK=GPACK
+!
+END SUBROUTINE WRITE_LFIFM1_FORDIACHRO_CV
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_conf.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_conf.f90
new file mode 100644
index 0000000000000000000000000000000000000000..3e93737a148e0923207c9ba638c6dcf6c06866fe
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_conf.f90
@@ -0,0 +1,124 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+! #################
+ MODULE MODD_CONF
+! #################
+!
+!!**** *MODD_CONF* - declaration of configuration variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to specify the variables
+! which concern the configuration of all models. For exemple,
+! the type of geometry (Cartesian or conformal projection plane).
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_CONF)
+!! Technical Specifications Report of the Meso-NH (chapters 2 and 3)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/05/94
+!! J. Stein 09/01/95 add the 1D switch
+!! J. Stein and P. Jabouille 30/04/96 add the storage type
+!! J.-P. Pinty 13/02/96 add LFORCING switch
+!! J. Stein 25/07/97 add the equation system switch
+!! P. Jabouille 07/05/98 add LPACK
+!! V. Masson 18/03/98 add the VERSION switch
+!! V. Masson 15/03/99 add PROGRAM swith
+!! P. Jabouille 21/07/99 add NHALO and CSPLIT
+!! P. Jabouille 26/06/01 lagrangian variables
+!! V. Masson 09/07/01 add LNEUTRAL switch
+!! P. Jabouille 18/04/02 add NBUGFIX and CBIBUSER
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+CHARACTER (LEN=5),SAVE :: CCONF ! Configuration of models
+ ! 'START' for start configuration (variables
+ ! at time t and t-dt are the same in the
+ ! initial file)
+ ! 'RESTART' for restart configuration
+ ! (variables at time t and t-dt are different)
+ ! 'POST' for post-treatment configuration
+LOGICAL,SAVE :: LTHINSHELL ! Logical for thinshell approximation
+ ! .TRUE. = thinshell approximation
+ ! .FALSE. = no thinshell approximation
+LOGICAL,SAVE :: LCARTESIAN ! Logical for cartesian geometry :
+ ! .TRUE. = cartesian geometry
+ ! .FALSE. = conformal projection
+LOGICAL,SAVE :: L2D ! Logical for 2D model version
+ ! .TRUE. = 2D model version
+ ! .FALSE. = 3D model version
+LOGICAL,SAVE :: L1D ! Logical for 1D model version
+ ! .TRUE. = 1D model version
+ ! .FALSE. = 2D or 3D model version
+LOGICAL,SAVE :: LFLAT ! Logical for zero ororography
+ ! .TRUE. = no orography (zs=0.)
+ ! .FALSE. = orography
+INTEGER,SAVE :: NMODEL ! Number of nested models
+INTEGER,SAVE :: NVERB ! Level of informations on output-listing
+ ! 0 for minimum of prints
+ ! 5 for intermediate level of prints
+ ! 10 for maximum of prints
+CHARACTER (LEN=5),SAVE :: CEXP ! Experiment name
+CHARACTER (LEN=5),SAVE :: CSEG ! name of segment
+CHARACTER (LEN=2),SAVE :: CSTORAGE_TYPE ! storage type for the informations
+ ! written in the FM files ( 'TT' if the MesoNH
+ ! prognostic fields are at the same instant;
+ ! 'MT' if they are taken at two instants in
+ ! succession; 'PG' for PGD files informations )
+LOGICAL,SAVE :: LFORCING ! Logical for forcing sources
+ ! .TRUE. = add forcing sources
+ ! .FALSE. = no forcing fields
+!
+CHARACTER (LEN=3),SAVE :: CEQNSYS! EQuatioN SYStem resolved by the MESONH model
+ ! 'LHE' Lipps and HEmler anelastic system
+ ! 'DUR' approximated form of the DURran version
+ ! of the anelastic sytem
+ ! 'MAE' classical Modified Anelastic Equations
+ ! but with not any approximation in the
+ ! momentum equation
+ ! 'FCE' fully compressible equations ( not
+ ! yet developped )
+LOGICAL,SAVE :: LPACK ! Logical to compress 1D or 2D FM files
+!
+!
+INTEGER,SAVE :: NMASDEV ! NMASDEV=XY corresponds to the masdevX_Y
+INTEGER,SAVE :: NBUGFIX ! NBUGFIX=n corresponds to the BUGn of masdevX_Y
+CHARACTER(LEN=10),SAVE :: CBIBUSER! CBIBUSER is the name of the user binary library
+!
+CHARACTER(LEN=6),SAVE :: CPROGRAM ! CPROGRAM is the program currently running:
+! ! 'PGD ','ADVPGD','NESPGD','REAL ','IDEAL '
+! ! 'MESONH','SPAWN ','DIAG '
+!
+INTEGER,SAVE :: NHALO ! Size of the halo for parallel distribution
+!
+CHARACTER (LEN=10),SAVE :: CSPLIT ! kind of domain splitting for parallel distribution
+ ! "BSPLITTING","XSPLITTING","YSPLITTING"
+LOGICAL,SAVE :: LLG ! Logical to use lagrangian variables
+LOGICAL,SAVE :: LINIT_LG ! to reinitialize lagrangian variables
+LOGICAL,SAVE :: LNOMIXLG ! to use turbulence for lagrangian variables
+!
+LOGICAL,SAVE :: LNEUTRAL ! True if ref. theta field is uniform
+!
+END MODULE MODD_CONF
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_cst.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_cst.f90
new file mode 100644
index 0000000000000000000000000000000000000000..903f9fda8954526325c1cec7c3b5eab88c47c063
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_cst.f90
@@ -0,0 +1,86 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+! ###############
+ MODULE MODD_CST
+! ###############
+!
+!!**** *MODD_CST* - declaration of Physic constants
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to declare the
+! Physics constants.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (MODD_CST)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 16/05/94
+!! J. Stein 02/01/95 add xrholw
+!! J.-P. Pinty 13/12/95 add XALPI,XBETAI,XGAMI
+!! J. Stein 25/07/97 add XTH00
+!! V. Masson 05/10/98 add XRHOLI
+!! C. Mari 31/10/00 add NDAYSEC
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+REAL,SAVE :: XPI ! Pi
+!
+REAL,SAVE :: XDAY,XSIYEA,XSIDAY ! day duration, sideral year duration,
+ ! sideral day duration
+!
+REAL,SAVE :: XKARMAN ! von karman constant
+REAL,SAVE :: XLIGHTSPEED ! light speed
+DOUBLE PRECISION,SAVE :: XPLANCK ! Planck constant
+REAL,SAVE :: XBOLTZ ! Boltzman constant
+REAL,SAVE :: XAVOGADRO ! Avogadro number
+!
+REAL,SAVE :: XRADIUS,XOMEGA ! Earth radius, earth rotation
+REAL,SAVE :: XG ! Gravity constant
+!
+REAL,SAVE :: XP00 ! Reference pressure
+!
+REAL,SAVE :: XSTEFAN,XI0 ! Stefan-Boltzman constant, solar constant
+!
+REAL,SAVE :: XMD,XMV ! Molar mass of dry air and molar mass of vapor
+REAL,SAVE :: XRD,XRV ! Gaz constant for dry air, gaz constant for vapor
+REAL,SAVE :: XCPD,XCPV ! Cpd (dry air), Cpv (vapor)
+REAL,SAVE :: XRHOLW ! Volumic mass of liquid water
+REAL,SAVE :: XCL,XCI ! Cl (liquid), Ci (ice)
+REAL,SAVE :: XTT ! Triple point temperature
+REAL,SAVE :: XLVTT ! Vaporization heat constant
+REAL,SAVE :: XLSTT ! Sublimation heat constant
+REAL,SAVE :: XLMTT ! Melting heat constant
+REAL,SAVE :: XESTT ! Saturation vapor pressure at triple point
+ ! temperature
+REAL,SAVE :: XALPW,XBETAW,XGAMW ! Constants for saturation vapor
+ ! pressure function
+REAL,SAVE :: XALPI,XBETAI,XGAMI ! Constants for saturation vapor
+ ! pressure function over solid ice
+REAL, SAVE :: XTH00 ! reference value for the potential
+ ! temperature
+REAL,SAVE :: XRHOLI ! Volumic mass of liquid water
+!
+INTEGER, SAVE :: NDAYSEC ! Number of seconds in a day
+!
+END MODULE MODD_CST
+
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_dim1.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_dim1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..7e0504e2ccaf2180a373a97f117f262a8e5458bd
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_dim1.f90
@@ -0,0 +1,52 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+! ##################
+ MODULE MODD_DIM1
+! ##################
+!
+!!**** *MODD_DIM1* - declaration of dimensions
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to specify the dimensions
+! of the data arrays.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_DIMn)
+!! Technical Specifications Report of the Meso-NH (chapters 2 and 3)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/05/94
+!! Modifications 13/08/98 (V. Ducrocq) // NIINF .. NJSUP are no more used in the init part
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+INTEGER,SAVE :: NIMAX,NJMAX,NKMAX ! Dimensions respectively in x ,
+ ! y , z directions of the physical sub-domain.
+INTEGER,SAVE :: NIMAX_ll,NJMAX_ll ! Dimensions respectively in x and y
+ ! directions of the physical domain
+INTEGER,SAVE :: NIINF, NISUP ! Lower bound and upper bound of the arrays
+ ! in x direction
+INTEGER,SAVE :: NJINF, NJSUP ! Lower bound and upper bound of the arrays
+ ! in y direction
+!
+END MODULE MODD_DIM1
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_field1.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_field1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1f7deab60559ce42abb26fdadd650ea0c7f96e9c
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_field1.f90
@@ -0,0 +1,100 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODD_FIELD1
+! ###################
+!
+!!**** *MODD_FIELD1* - declaration of prognostic variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to specify the
+! prognostic variables.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_FIELDn)
+!! Technical Specifications Report of the Meso-NH (chapters 2 and 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/05/94
+!! Modifications 03/01/95 (Lafore) To add the dry mass variables Md
+!! 09/03/95 (Stein) eliminate R from the progn. var
+!! 15/03/95 (Stein) add EPS variable
+!! Modifications 21/03/95 (Carriere) To add the subgrid condensation
+!! related parameters
+!! 01/03/96 (J. Stein) add the cloud fraction
+!! 10/10/96 (J. Stein) add XSRCM and XSRCT
+!! 11/04/96 (J.-P. Pinty) add the ice concentration
+!! 25/07/97 (J. Stein) Change the variable pressure
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XUM,XVM,XWM ! U,V,W at time t-dt
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XUT,XVT,XWT ! U,V,W at time t
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XRUS,XRVS,XRWS ! Source of (rho U),
+ ! (rho V), (rho w)
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XTHM ! (rho theta) at time t-dt
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XTHT ! (rho theta) at time t
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XRTHS ! Source of (rho theta)
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XTKEM ! Kinetic energy
+ ! at time t-dt
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XTKET ! Kinetic energy
+ ! at time t
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XRTKES ! Source of kinetic energy
+ ! (rho e)
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XEPSM ! Dissipation of TKE
+ ! (eps) at time t-dt
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XEPST ! Dissipation of TKE
+ ! (eps) at time t
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XREPSS ! Source of Dissipation
+ ! of TKE (rho eps)
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XPABSM ! absolute pressure at
+ ! time t-dt
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XPABST ! absolute pressure at
+ ! time t
+REAL,SAVE, DIMENSION(:,:,:,:), ALLOCATABLE :: XRM ! Moist variables
+ ! at time t-dt
+REAL,SAVE, DIMENSION(:,:,:,:), ALLOCATABLE :: XRT ! Moist variables (rho Rn)
+ ! at time t
+REAL,SAVE, DIMENSION(:,:,:,:), ALLOCATABLE :: XRRS ! Source of Moist variables
+ ! (rho Rn)
+REAL,SAVE, DIMENSION(:,:,:,:), ALLOCATABLE :: XSVM ! Additionnal scalar
+ ! variables at time t-dt
+REAL,SAVE, DIMENSION(:,:,:,:), ALLOCATABLE :: XSVT ! Additionnal scalar
+ ! variables at time t
+REAL,SAVE, DIMENSION(:,:,:,:), ALLOCATABLE :: XRSVS ! Source of addi. scalar
+ ! variables (rho Sn.)
+REAL,SAVE :: XDRYMASST ! Mass of dry air Md
+REAL,SAVE :: XDRYMASSS ! LS sources of Md
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XSRC ! turbulent flux <s'Rc'>
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XSIGS ! =sqrt(<s's'>) for the
+ ! Subgrid Condensation
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XCLDFR ! cloud fraction
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XSRCM ! turbulent flux <s'Rc'>
+ ! at t- delta t
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XSRCT ! turbulent flux <s'Rc'>
+ ! at t
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XCIT ! Pristine ice concentration
+!
+END MODULE MODD_FIELD1
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_fmdeclar.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_fmdeclar.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d93bebd2e241a32f4e21036604bcaa210141899b
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_fmdeclar.f90
@@ -0,0 +1,69 @@
+! ######spl
+ MODULE MODD_FMDECLAR
+! ####################
+!
+!!**** *MODD_FMDECLAR* - declaration of global variables of the FM-routines
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of MODD_FMDECLAR is to declare all the global variables that
+! are needed by the FM-routines. It includes specific FM-software parameters
+! as well as storage arrays. These arrays allow the FM-routines to keep
+! in mind which logical unit is associated with which file name
+! and to state whether a file was actually opened.
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!!
+!! see the Technical Specifications Report for the Meso-nh project
+!! (in French)
+!!
+!! AUTHOR
+!! ------
+!!
+!! C. FISCHER *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 06/94
+!!
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+
+INTEGER,PARAMETER::JPNXLU=99 ! maximum number of logical units for Fortran
+INTEGER,PARAMETER::JPNXFM=JPNXLU-10
+ ! maximum number of files opened at the same time
+INTEGER,PARAMETER::JPXFIE=1.5E8! maximum record length for the FM-software
+INTEGER,PARAMETER::JPNIIL=-999 ! default value in integer arrays
+INTEGER,PARAMETER::JPFINL=32 ! length of the file name strings in FM
+INTEGER,PARAMETER::JPXKRK=100 ! maximum length for the comment string
+
+CHARACTER(LEN=JPFINL),PARAMETER::CPUDFN='UNDEFINED_FILE_NAME'
+CHARACTER(LEN=JPFINL),PARAMETER::CPUNLU='UNAUTHORIZED_LOGICAL_UNIT'
+!
+!----------------------------------------------------------------------------
+INTEGER::NOPEFI ! number of opened files
+
+INTEGER,DIMENSION(1:JPNXLU)::NFITYP
+ ! NFITYP contains the type of the FM file which
+ ! will be used in FMCLOS for the Unix save.
+
+CHARACTER(LEN=JPFINL),DIMENSION(1:JPNXLU)::CNAMFI
+ ! management array containing the names of all
+ ! opened files
+
+LOGICAL::LFCATT=.TRUE. ! This logical is true at the very first call
+ ! to FMATTR and is then set to false.
+
+END MODULE MODD_FMDECLAR
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_fmmulti.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_fmmulti.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d986bbe88857f1282cec314cbdc0550c3f11bb89
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_fmmulti.f90
@@ -0,0 +1,44 @@
+! ######spl
+ MODULE MODD_FMMULTI
+! ####################
+!
+!!**** *MODD_FMMULTI* - declaration of global variables for multitasked FM
+!!
+!! PURPOSE
+!! -------
+!
+! This module contains variables global to all models (tasks).
+! They are used to switch on (off) the multitasked mode in the File Manager.
+!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!!
+!! see "File structure and content in the Meso-NH model"
+!!
+!! AUTHOR
+!! ------
+!!
+!! C. FISCHER *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 07/95
+!!
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+
+INTEGER::NFMLOC ! identification of the lock
+LOGICAL::LFMMUL=.FALSE. ! becomes TRUE if multitasking is asked
+
+ END MODULE MODD_FMMULTI
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_grid.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_grid.f90
new file mode 100644
index 0000000000000000000000000000000000000000..ce3c316a0eacc279c3d785add876174a204960b7
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_grid.f90
@@ -0,0 +1,50 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_grid.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! #################
+ MODULE MODD_GRID
+! #################
+!
+!!**** *MODD_GRID* - declaration of grid variables for all models
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to declare the variables
+! describing the grid for all models.
+!
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_GRID)
+!! Technical Specifications Report of the Meso-NH (chapters 2 and 3)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/05/94
+!! V. Masson nov 2004 : add XLATORI and XLONORI
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+REAL,SAVE :: XLON0,XLAT0 ! Reference longitude and latitude
+ ! for the conformal projection
+REAL,SAVE :: XBETA,XRPK ! Rotation angle and projection parameter
+ ! for the conformal projection
+REAL,SAVE :: XLONORI,XLATORI ! Longitude and latitude of the point
+ ! of coordinates x=0, y=0
+ ! for the conformal projection
+!
+END MODULE MODD_GRID
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_grid1.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_grid1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..cc56f6d6e0396b8edf5abfb2bdeaa060ec6607cf
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_grid1.f90
@@ -0,0 +1,72 @@
+!-----------------------------------------------------------------
+! ##################
+ MODULE MODD_GRID1
+! ##################
+!
+!!**** *MODD_GRID1* - declaration of grid variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to declare the variables
+! describing the grid.
+!
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_GRIDn)
+!! Technical Specifications Report of the Meso-NH (chapters 2 and 3)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/05/94
+!! J. Stein 15/11/95 add the slope angle
+!! V. Ducrocq 13/08/98 // : add XLATOR_ll and XLONOR_ll
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+REAL,SAVE :: XLONOR,XLATOR ! Longitude and latitude of the Origine point
+ ! for the conformal projection of the sub-domain (//)
+REAL,SAVE :: XLONOR_ll,XLATOR_ll ! Longitude and latitude of the Origine point
+ ! for the conformal projection of the domain
+REAL,SAVE, DIMENSION(:,:), ALLOCATABLE :: XLON,XLAT ! Longitude and latitude
+!
+REAL,SAVE, DIMENSION(:), ALLOCATABLE :: XXHAT ! Position x in the
+ ! conformal or cartesian plane
+REAL,SAVE, DIMENSION(:), ALLOCATABLE :: XYHAT ! Position y in the
+ ! conformal or cartesian plane
+REAL,SAVE, DIMENSION(:), ALLOCATABLE :: XDXHAT ! horizontal stretching in x
+REAL,SAVE, DIMENSION(:), ALLOCATABLE :: XDYHAT ! horizontal stretching in y
+REAL,SAVE, DIMENSION(:,:), ALLOCATABLE :: XMAP ! Map factor
+!
+REAL,SAVE, DIMENSION(:,:), ALLOCATABLE :: XZS ! orography
+REAL,SAVE, DIMENSION(:,:,:), ALLOCATABLE :: XZZ ! height z
+REAL,SAVE, DIMENSION(:), ALLOCATABLE :: XZHAT ! height level without orography
+!
+REAL, DIMENSION(:,:) , ALLOCATABLE :: XDIRCOSXW,XDIRCOSYW,XDIRCOSZW
+ ! director cosinus of the normal
+ ! to the ground surface
+!
+REAL,SAVE, DIMENSION(:,:), ALLOCATABLE :: XCOSSLOPE ! cosinus of the angle
+ ! between i and the slope vector
+REAL,SAVE, DIMENSION(:,:), ALLOCATABLE :: XSINSLOPE ! sinus of the angle
+ ! between i and the slope vector
+!
+!* quantities for SLEVE vertical coordinate
+LOGICAL,SAVE :: LSLEVE ! Logical for SLEVE coordinate
+REAL,SAVE :: XLEN1 ! Decay scale for smooth topography
+REAL,SAVE :: XLEN2 ! Decay scale for small-scale topography deviation
+REAL,SAVE, DIMENSION(:,:), ALLOCATABLE :: XZSMT ! smooth orography for SLEVE coordinate
+!
+END MODULE MODD_GRID1
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_lunit1.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_lunit1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..438f3a3c359b1ad7d0dd81933c954a5830c04b8a
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_lunit1.f90
@@ -0,0 +1,54 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_lunitn.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODD_LUNIT1
+! ###################
+!
+!!**** *MODD_LUNIT1* - declaration of names and logical unit numbers of files
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to declare the names
+! for the initial Meso-NH files
+! and also the generic names for the output files for model n.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (MODD_LUNITn)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 05/05/94
+!! Modification 20/10/94 (J.Stein) add the output files
+!! Modification 10/03/95 (I.Mallet) add the coupling files names
+!! Modification 25/09/95 (J.Stein) add the output diachronic file
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+CHARACTER(LEN=28),SAVE :: CINIFILE ! Name of the input FM-file
+CHARACTER(LEN=24),SAVE :: COUTFILE ! Generic name of the output FM-files
+CHARACTER(LEN=28),SAVE :: CFMDIAC ! diachronic output FM-file
+!
+CHARACTER(LEN=16),SAVE :: CLUOUT ! Name of output_listing file
+CHARACTER(LEN=28),SAVE,DIMENSION(JPCPLFILEMAX) :: CCPLFILE ! Names of the
+ ! coupling FM-files
+!
+END MODULE MODD_LUNIT1
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_nesting.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_nesting.f90
new file mode 100644
index 0000000000000000000000000000000000000000..753e0bcd04fff654f22942b4fb4effb7be1ebbaa
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_nesting.f90
@@ -0,0 +1,75 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_nesting.f90, Version:1.3, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ###################
+ MODULE MODD_NESTING
+! ###################
+!
+!!**** *MODD_NESTING* - declaration of gridnesting configuration variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to specify the variables
+! which concern the gridnesting configuration of all models.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! Module MODD_PARAMETERS :
+!! JPMODELMAX : Maximum allowed number of nested models
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_NESTING)
+!!
+!! AUTHOR
+!! ------
+!! J.P. Lafore *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 18/08/95
+!! updated 29/07/96 (J.P. Lafore) MY_NAME(m) introduction
+
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+ ! resolution RATIO between models m and its father NDAD(m)
+INTEGER,SAVE, DIMENSION(JPMODELMAX) :: NDXRATIO_ALL ! in x-direction
+INTEGER,SAVE, DIMENSION(JPMODELMAX) :: NDYRATIO_ALL ! in y-direction
+INTEGER,SAVE, DIMENSION(JPMODELMAX) :: NDTRATIO ! in Time
+!
+INTEGER,SAVE, DIMENSION(JPMODELMAX) :: NXOR_ALL, NYOR_ALL ! horizontal position (i,j) of the
+INTEGER,SAVE, DIMENSION(JPMODELMAX) :: NXEND_ALL,NYEND_ALL ! ORigin and END of model m
+ ! relative to its father NDAD(m)
+!
+INTEGER,SAVE, DIMENSION(JPMODELMAX) :: NDAD ! model number of the father of each model "m"
+REAL,SAVE, DIMENSION(JPMODELMAX) :: XWAY ! model m interactive nesting level with its father NDAD(m)
+!
+ ! MeSsaGes concerning
+INTEGER,SAVE, DIMENSION(JPMODELMAX,JPMODELMAX) :: NMSG_IF ! var. Interpolation at Flux
+INTEGER,SAVE, DIMENSION(JPMODELMAX,JPMODELMAX) :: NMSG_IS ! and Scalar location
+INTEGER,SAVE, DIMENSION(JPMODELMAX,JPMODELMAX) :: NMSG_AVR ! AVeRage
+INTEGER,SAVE, DIMENSION(JPMODELMAX,JPMODELMAX) :: NMSG_END ! timestep END
+ ! MeSsaGes concerning
+INTEGER,SAVE, DIMENSION(JPMODELMAX,JPMODELMAX) :: NMSG_AVR_END ! AVeRage END
+!
+CHARACTER(LEN=28),SAVE, DIMENSION(JPMODELMAX) :: CMY_NAME,CDAD_NAME
+ ! names of the initial FM-Files
+ ! then generic names of output FM-Files
+ ! of each model "m"
+ ! and of its DAD model
+ ! (read and written on the LFI parts)
+INTEGER,SAVE, DIMENSION(JPMODELMAX) :: NDT_2_WAY ! number of times the time step
+ ! of model n used for the relaxation time of the 2_WAY grid-nesting
+ ! interaction i.e. Tau = NDT_2_WAY * XTSTEP
+END MODULE MODD_NESTING
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_param1.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_param1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9cf6b5d2622430e80e661c2a4b42050b389f2738
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_param1.f90
@@ -0,0 +1,57 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+! ####################
+ MODULE MODD_PARAM1
+! ####################
+!
+!!**** *MODD_PARAM$n* - declaration of parameterization and cloud physics variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to declare the
+! parameterization and cloud physics variables.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_PARAMn)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 15/06/94
+!! E. Richard 01/06/95 add the selctor for the microphysical scheme
+!! P. Bechtold 26/03/96 add the selector for the deep convection
+!! M. Tomasini 11/12/00 add the selector for the fluxes algorithm over water
+!! JP. Pinty 26/11/02 add the selector for the atmospheric electricity scheme
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+CHARACTER (LEN=4),SAVE :: CTURB ! Kind of turbulence parameterization
+ ! 'NONE' if no parameterization
+CHARACTER (LEN=4),SAVE :: CRAD ! Kind of radiation parameterization
+ ! 'NONE' if no parameterization
+CHARACTER (LEN=4),SAVE :: CDRAG ! Kind of drag parameterization
+ ! 'NONE' if no parameterization
+CHARACTER (LEN=4),SAVE :: CCLOUD ! Kind of cloud parameterization
+ ! 'NONE' if no parameterization
+CHARACTER (LEN=4),SAVE :: CDCONV ! Kind of deep convection
+ ! 'NONE' if no parameterization
+CHARACTER (LEN=4),SAVE :: CELEC ! Kind of atmospheric electricity scheme
+CHARACTER (LEN=4),SAVE :: CSURF ! Kind of surface processes parameterization
+!
+END MODULE MODD_PARAM1
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_parameters.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_parameters.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a6e4df8152d83afc9a3c3026cc6e91f7f92eeada
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_parameters.f90
@@ -0,0 +1,59 @@
+! ######################
+ MODULE MODD_PARAMETERS
+! ######################
+!
+!!**** *MODD_PARAMETERS* - declaration of parameter variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to specify the variables
+! which have the PARAMETER attribute
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! None
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_PARAMETER)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 4/07/94
+!! Modification 10/03/95 (I.Mallet) add the coupling files maximum number
+!! Modification 10/04/95 (Ph. Hereil) add the budget related informations
+!! Modification 15/03/99 (V. Masson) add default value
+!! Modification 17/11/00 (P.Jabouille) add the dummy array size
+!! Modification 22/01/01 (D.Gazen) change JPSVMAX from 100 to 200
+!! and JPBUMAX from 120 to 250
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+INTEGER, SAVE :: JPHEXT = 1 ! Horizontal External points number
+INTEGER, PARAMETER :: JPVEXT = 1 ! Vertical External points number
+INTEGER, PARAMETER :: JPMODELMAX = 8 ! Maximum allowed number of nested models
+INTEGER, PARAMETER :: JPCPLFILEMAX = 8 ! Maximum allowed number of CouPLing FILEs
+INTEGER, PARAMETER :: JPBUMAX= 250 ! Maximum of allowed budgets
+INTEGER, PARAMETER :: JPBUPROMAX = 40 ! Maximum of allowed processes for all
+ ! budgets
+INTEGER, PARAMETER :: JPRIMMAX = 6 ! Maximum number of points for the
+ ! horizontal relaxation for the outermost verticals
+INTEGER, PARAMETER :: JPSVMAX = 200 ! Maximum number of scalar variables
+!
+!
+REAL, PARAMETER :: XUNDEF = 999. ! default value for undefined or unused
+! ! field.
+INTEGER, PARAMETER :: NUNDEF = 999 ! default value for undefined or unused
+! ! field.
+INTEGER, PARAMETER :: JPDUMMY = 20 ! Size of dummy array
+!
+END MODULE MODD_PARAMETERS
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_time.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_time.f90
new file mode 100644
index 0000000000000000000000000000000000000000..cee89e1de9ee83927b11fa0076aba63a543d1627
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_time.f90
@@ -0,0 +1,50 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_time.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! #################
+ MODULE MODD_TIME
+! #################
+!
+!!**** *MODD_TIME* - declaration of temporal grid variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to specify the variables
+! which concern the time for all models
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_TIME)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/07/94
+!! Modification 10/03/95 (I.Mallet) add the coupling times
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_TYPE_DATE
+!
+USE MODD_PARAMETERS
+!
+IMPLICIT NONE
+!
+TYPE (DATE_TIME), SAVE :: TDTEXP ! Time and Date of Experiment beginning
+TYPE (DATE_TIME), SAVE :: TDTSEG ! Time and Date of the segment beginning
+!
+TYPE (DATE_TIME), SAVE, DIMENSION(JPCPLFILEMAX) :: TDTCPL ! Time and Date of
+ ! the CouPLing files
+END MODULE MODD_TIME
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_time1.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_time1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e556804ff9595c5487c0f03062e597bc18cc8252
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_time1.f90
@@ -0,0 +1,53 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_timen.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ##################
+ MODULE MODD_TIME1
+! ##################
+!
+!!**** *MODD_TIME1* - declaration of temporal grid variables
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to specify the variables
+! which concern the time for one nested model.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_TIME : contains the definition of the types for time
+!! variables and time variables for all model
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_TIME1)
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/07/94
+!! J.Stein 27/10/95 add the radiation call's instants
+!! P.Bechtold 26/03/96 add the last deep convection call
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_TYPE_DATE
+!
+IMPLICIT NONE
+!
+TYPE (DATE_TIME),SAVE :: TDTMOD ! Time and Date of the model beginning
+TYPE (DATE_TIME),SAVE :: TDTCUR ! Current Time and Date
+TYPE (DATE_TIME),SAVE :: TDTRAD_FULL ! Time and Date of the last full
+ ! radiation call
+TYPE (DATE_TIME),SAVE :: TDTRAD_CLONLY ! Time and Date of the last radiation
+ ! call for only the cloudy verticals
+TYPE (DATE_TIME),SAVE :: TDTDCONV ! Time and Date of the last deep convection
+ ! call
+!
+END MODULE MODD_TIME1
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_type_date.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_type_date.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9de36bc3ef1611259b3fcd3bedb5c6bc493c57dc
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/modd_type_date.f90
@@ -0,0 +1,52 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!-----------------------------------------------------------------
+! @(#) Lib:/opt/local/MESONH/sources/modd/s.modd_type_date.f90, Version:1.2, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! #################
+ MODULE MODD_TYPE_DATE
+! #################
+!
+!!**** *MODD_TYPE_DATE* - declaration of temporal types
+!!
+!! PURPOSE
+!! -------
+! The purpose of this declarative module is to define
+! the time types.
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!! Book2 of documentation of Meso-NH (module MODD_TYPE_DATE)
+!!
+!! AUTHOR
+!! ------
+!! P. Jabouille *Meteo France*
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 11/08/97
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!
+IMPLICIT NONE
+!
+TYPE DATE
+INTEGER :: YEAR
+INTEGER :: MONTH
+INTEGER :: DAY
+END TYPE DATE
+!
+TYPE DATE_TIME
+TYPE (DATE) :: TDATE
+REAL :: TIME
+END TYPE DATE_TIME
+!
+END MODULE MODD_TYPE_DATE
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/mode_gridcart.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/mode_gridcart.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4c64cba0002f8bb2e11c15d85dcece38bad75221
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/mode_gridcart.f90
@@ -0,0 +1,208 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/mode/s.mode_gridcart.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ####################
+ MODULE MODE_GRIDCART
+! ####################
+!
+!!**** *MODE_GRIDCART* - module routine SM_GRIDCART
+!!
+!! PURPOSE
+!! -------
+! The purpose of this executive module is to package
+! the routine SM_GRIDCART
+!
+!
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/05/94
+!--------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!-------------------------------------------------------------------------------
+!
+CONTAINS
+!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!
+!* 1. ROUTINE SM_GRIDCART
+! -------------------
+!-------------------------------------------------------------------------------
+! #########################################################################
+ SUBROUTINE SM_GRIDCART(HLUOUT,PXHAT,PYHAT,PZHAT,PZS,OSLEVE,PLEN1,PLEN2,PZSMT,PDXHAT,PDYHAT,PZZ,PJ)
+! #########################################################################
+!
+!!**** *SM_GRIDCART * - routine to compute J
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to compute the Jacobian (J) in the case
+! of a cartesian geometry
+!
+!
+!!** METHOD
+!! ------
+!! The height z is first determined, and then J is computed
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_PARAMETERS : contains array border depths
+!!
+!! JPHEXT,JPVEXT : Arrays border zone depth
+!!
+!! Module MODD_CONF : contains configuration variables for
+!! all models
+!
+!! NVERB : Listing verbosity
+!!
+!! REFERENCE
+!! ---------
+!! Technical Specifications Report of the Meso-NH project (chapters 2 and 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 06/05/94
+!! updated V. Ducrocq *Meteo France* 27/06/94
+!! Updated P.M. *LA* 22/07/94
+!! Updated V. Ducrocq *Meteo France* 23/08/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_PARAMETERS
+USE MODD_CONF
+!
+USE MODI_VERT_COORD
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Output-listing name
+REAL, DIMENSION(:), INTENT(IN) :: PXHAT,PYHAT,PZHAT ! positions x,y,z in
+ ! the cartesian plane
+REAL, DIMENSION(:,:), INTENT(IN) :: PZS ! orography
+LOGICAL, INTENT(IN) :: OSLEVE ! flag for SLEVE coordinate
+REAL, INTENT(IN) :: PLEN1 ! Decay scale for smooth topography
+REAL, INTENT(IN) :: PLEN2 ! Decay scale for small-scale topography deviation
+REAL, DIMENSION(:,:), INTENT(IN) :: PZSMT ! smooth orography
+!
+REAL, DIMENSION(:), INTENT(OUT) :: PDXHAT ! meshlength in x
+ ! direction
+REAL, DIMENSION(:), INTENT(OUT) :: PDYHAT ! meshlength in y
+ ! direction
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PZZ ! Height z
+REAL, DIMENSION(:,:,:), INTENT(OUT) :: PJ ! Jacobian of the
+ ! GCS transformation
+!
+!* 0.2 Declarations of local variables
+!
+REAL, DIMENSION(SIZE(PXHAT,1),SIZE(PYHAT,1),SIZE(PZHAT,1)) :: ZDZ ! meshlength in
+ ! z direction
+REAL, DIMENSION(SIZE(PZS,1),SIZE(PZS,2)) :: ZBOUNDZ ! Extrapolated
+REAL :: ZBOUNDX,ZBOUNDY ! value for the
+ ! upper bounds in
+ ! z,x,y directions
+!
+INTEGER :: IIB,IJB,IKB ! beginning of useful area of PXHAT,PYHAT,PZHAT
+INTEGER :: IIE,IJE,IKE ! end of useful area of PXHAT,PYHAT,PZHAT
+INTEGER :: IIU,IJU,IKU ! upper bounds of PXHAT,PYHAT,PZHAT
+INTEGER :: IKLOOP ! index for prints
+INTEGER :: ILUOUT,IRESP ! logical unit number for prints, error code
+!
+!-------------------------------------------------------------------------------
+!
+!* 1 RETRIEVE LOGICAL UNIT NUMBERFOR OUTPUT-LISTING AND DIMENSIONS
+! --------------------------------------------------------------
+!
+CALL FMLOOK(HLUOUT,HLUOUT,ILUOUT,IRESP)
+!
+IIU = UBOUND(PXHAT,1)
+IJU = UBOUND(PYHAT,1)
+IKU = UBOUND(PZHAT,1)
+IIE = IIU-JPHEXT
+IJE = IJU-JPHEXT
+IKE = IKU-JPVEXT
+IIB = 1+JPHEXT
+IJB = 1+JPHEXT
+IKB = 1+JPVEXT
+!
+IF(NVERB >= 10) THEN ! Parameter checking
+ WRITE(ILUOUT,*) 'SM_GRIDCART: IIU,IJU,IKU=',IIU,IJU,IKU
+ WRITE(ILUOUT,*) 'SM_GRIDCART: IIE,IJE,IKE=',IIE,IJE,IKE
+ WRITE(ILUOUT,*) 'SM_GRIDCART: IIB,IJB,IKB=',IIB,IJB,IKB
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. COMPUTE Z
+! ---------
+!
+CALL VERT_COORD(OSLEVE,PZS,PZSMT,PLEN1,PLEN2,PZHAT,PZZ)
+!
+IF(NVERB >= 10) THEN !Value control
+ WRITE(ILUOUT,*) 'SM_GRIDCART: Some PZS values:'
+ WRITE(ILUOUT,*) PZS(1,1),PZS(IIU/2,IJU/2),PZS(IIU,IJU)
+ WRITE(ILUOUT,*) 'SM_GRIDCART: Some PZZ values:'
+ DO IKLOOP=1,IKU
+ WRITE(ILUOUT,*) PZZ(1,1,IKLOOP),PZZ(IIU/2,IJU/2,IKLOOP), &
+ PZZ(IIU,IJU,IKLOOP)
+ END DO
+ENDIF
+!-------------------------------------------------------------------------------
+!
+!
+!* 3. COMPUTE J
+! ---------
+!
+ZBOUNDX = 2.*PXHAT(IIU) - PXHAT(IIU-1)
+ZBOUNDY = 2.*PYHAT(IJU) - PYHAT(IJU-1)
+ZBOUNDZ(:,:) = 2.*PZZ(:,:,IKU) - PZZ(:,:,IKU-1)
+PDXHAT(:) = EOSHIFT(PXHAT(:) ,1,ZBOUNDX) - PXHAT(:)
+PDYHAT(:) = EOSHIFT(PYHAT(:) ,1,ZBOUNDY) - PYHAT(:)
+ZDZ(:,:,:) = EOSHIFT(PZZ(:,:,:),1,ZBOUNDZ(:,:),3) - PZZ(:,:,:)
+PJ(:,:,:) = SPREAD((SPREAD(PDXHAT(:),2,IJU) * SPREAD(PDYHAT(:),1,IIU)),3,IKU) &
+ * ZDZ(:,:,:)
+!
+IF(NVERB >= 10) THEN !Value control
+ WRITE(ILUOUT,*) 'Some PJ values:'
+ DO IKLOOP=1,IKU
+ WRITE(ILUOUT,*) PJ(1,1,IKLOOP),PJ(IIU/2,IJU/2,IKLOOP), &
+ PJ(IIU,IJU,IKLOOP)
+ END DO
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE SM_GRIDCART
+!-------------------------------------------------------------------------------
+END MODULE MODE_GRIDCART
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/mode_gridproj.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/mode_gridproj.f90
new file mode 100644
index 0000000000000000000000000000000000000000..272fafbecd0dadb30aadc42f420dc2266bde4e9e
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/mode_gridproj.f90
@@ -0,0 +1,1563 @@
+! ####################
+ MODULE MODE_GRIDPROJ
+! ####################
+!
+!!**** *MODE_GRIDPROJ* - module routine SM_GRIDPROJ
+!!
+!! PURPOSE
+!! -------
+! This executable module packages a set of cartographic
+! module-procedures:
+!
+! SM_GRIDPROJ : to compute the Jacobian in the case of
+! conformal projection;
+! SM_LATLON : to compute geographic from conformal
+! cartesian coordinates;
+! SM_XYHAT : to compute conformal cartesian from
+! geographic coordinates;
+! LATREF2 : to compute the second reference latitude
+! in the case of Lambert conformal projection
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! NONE
+!!
+!! AUTHOR
+!! ------
+!! P.M. *LA*
+!!
+!! MODIFICATION
+!! ------------
+!! Original 24/05/94
+!!
+!!
+!------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!------------------------------------------------------------------------------
+!
+INTERFACE SM_LATLON
+ MODULE PROCEDURE SM_LATLON_A,SM_LATLON_S
+END INTERFACE
+INTERFACE SM_XYHAT
+ MODULE PROCEDURE SM_XYHAT_A,SM_XYHAT_S
+END INTERFACE
+!
+CONTAINS
+!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!
+!* 1. ROUTINE SM_GRIDPROJ
+! --------------------
+!-------------------------------------------------------------------------------
+! ####################################################################
+ SUBROUTINE SM_GRIDPROJ(HLUOUT,PXHAT,PYHAT,PZHAT,PZS, &
+ OSLEVE,PLEN1,PLEN2,PZSMT,PLATOR,PLONOR, &
+ PMAP,PLAT,PLON,PDXHAT,PDYHAT,PZZ,PJ)
+! ####################################################################
+!
+!!***** *SM_GRIDPROJ * - Computes Jacobian J, map factor M,
+!! horizontal grid-meshes, latitude and longitude at the
+!! "mass" point locations.
+!!
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to compute the Jacobian (J) at the
+! "mass" point location in the case of a conformal projection.
+! The map factor of the projection, the horizontal mesh-sizezs, and the
+! the geograpical locations are also computed in the course of
+! this calculation.
+! Five map projections are available:
+! - polar-stereographic from south pole (XRPK=1),
+! - lambert conformal from south pole (0<XRPK<1),
+! - mercator (XRPK=0),
+! - lambert conformal from north pole (-1<XRPK<0),
+! - polar-stereographic from north pole (XRPK=-1).
+!
+!
+!!** METHOD
+!! ------
+!! The height, and the correction for spherical earth are first computed.
+!! Next, the conformal horizontal locations, the geographical coordinates
+!! and the map factor are derived at the "mass" grid-points.
+!! The same formula can (hopefully) be used for all the projections cases
+!! (see Joly, 1992).
+!!
+!! WARNING: ALL INPUT AND OUTPUT ANGLES ARE IN DEGREES...
+!!
+!!
+!! EXTERNAL
+!! --------
+!! NONE
+!!
+!! EXPLICIT ARGUMENTS (not required, but given for convenience)
+!! ------------------
+!! PXHAT : conformal coordinate x (meters, u-grid, input)
+!! PYHAT : conformal coordinate y (meters, v-grid, input)
+!! PZHAT : Gal-chen altitude zhat (meters, w-grid, input)
+!! PZS : topography (meters, masss-grid, input)
+!! PLATOR : Latitude of the origine point (degrees, mass grid, input)
+!! PLONOR : Longitude of the origine point (degrees, mass grid, input)
+!! PMAP : map scale (no-unit, mass-grid, output)
+!! PLAT : latitude (degrees, mass-grid, output)
+!! PLON : longitude (degrees, mass-grid, output)
+!! PDXHAT : local x mesh size (meters, u-grid, output)
+!! PDYHAT : local y mesh size (meters, v-grid, output)
+!! PZZ : true altitude z (meters, w-grid, output)
+!! PJ : jacobian (no-unit, mass-grid, output)
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CONF : contains declaration of configuration variables
+!! LTHINSHELL : Logical for thinshell approximation
+!! NVERB : Listing verbosity control
+!!
+!! Module MODD_CST : contains Physical constants
+!! XPI : Pi;
+!! XRADIUS : Earth radius (meters);
+!!
+!! Module MODD_PARAMETERS: contains declaration of parameter variables
+!! JPHEXT : horizontal depth of arrays border
+!! JPVEXT : vertical depth of arrays border
+!!
+!! Module MODD_GRID : contains spatial grid variables
+!! XLAT0 : map reference latitude (degrees)
+!! XRPK : projection parameter (no-unit)
+!!
+!!
+!! REFERENCE
+!! ---------
+!! Asencio N. et al., 1994, "Le projet de modele non-hydrostatique
+!! commun CNRM-LA, specifications techniques",
+!! Note CNRM/GMME, 26, 139p, (Chapter 2).
+!! Ducrocq V., 1994, "Generation de la grille dans le modele",
+!! Note interne MNH, 5 mai, 3p.
+!! Joly A., 1992, "Geographic parameters for ARPEGE/ALADIN",
+!! Internal note ARPEGE/ALADIN, february 27,28p.
+!! Levallois J., 1970, "Geodesie generale", Tome 2, Collection
+!! de l'IGN, Eyrolles, Paris, 408p.
+!! (chapters 2 and 3)
+!!
+!!
+!! AUTHOR
+!! ------
+!! P. Mascart * LA *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original PM 20/06/94 (from SM_GRIDCART by V. Ducrocq)
+!! Updated PM 26/07/94
+!! Updated VD 23/08/94
+!! 14/04/95 (Masson) bug in the ZYHTAM computation
+!! 24/10/95 (Masson) controls during PMAP computation and
+!! projection from north pole (XPRK<0)
+!! 14/03/96 (Masson) enforce -180<XLONOR<+180
+!! 01/11/96 (Mallet) bug for the MAP FACTOR computation
+!! Sleve coordinate G. Zangler *LA* nov 2005
+!!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CONF
+USE MODD_CST
+USE MODD_PARAMETERS
+USE MODD_GRID
+!
+USE MODI_VERT_COORD
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*), INTENT(IN) :: HLUOUT ! Name of output-listing
+REAL, DIMENSION(:), INTENT(IN) :: PXHAT,PYHAT,PZHAT ! Positions x,y,z in
+ ! the cartesian plane
+REAL, DIMENSION(:,:), INTENT(IN) :: PZS ! Orography
+LOGICAL, INTENT(IN) :: OSLEVE ! flag for SLEVE coordinate
+REAL, INTENT(IN) :: PLEN1 ! Decay scale for smooth topography
+REAL, INTENT(IN) :: PLEN2 ! Decay scale for small-scale topography deviation
+REAL, DIMENSION(:,:), INTENT(IN) :: PZSMT ! smooth orography
+REAL, INTENT(IN) :: PLATOR ! Latitude of the
+ ! origine point
+REAL, INTENT(IN) :: PLONOR ! Longitude of the
+ ! origine point
+REAL, DIMENSION(:), INTENT(OUT) :: PDXHAT ! Local meshlength in
+ ! x direction
+REAL, DIMENSION(:), INTENT(OUT) :: PDYHAT ! Local meshlength in
+ ! y direction
+REAL, DIMENSION(:,:), INTENT(OUT) :: PMAP ! Local map scale
+ ! of mass gridpoints
+REAL, DIMENSION(:,:), INTENT(OUT) :: PLAT,PLON ! Latitude and longitude
+ ! of mass gridpoints
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PZZ ! True altitude of the
+ ! w grid-point
+REAL, DIMENSION(:,:,:), INTENT(OUT):: PJ ! Jacobian of the
+ ! GCS transformation
+ ! of mass gridpoints
+!
+!* 0.2 Declarations of local variables
+!
+REAL, DIMENSION(SIZE(PXHAT,1),SIZE(PYHAT,1),SIZE(PZHAT,1)):: ZDZ ! Local z
+ ! meshsize
+REAL :: ZH ! H
+REAL, DIMENSION(SIZE(PXHAT,1),SIZE(PYHAT,1)):: ZCOEF ! 1-zs/H
+ ! upper bounds in
+REAL, DIMENSION(SIZE(PXHAT,1),SIZE(PYHAT,1),SIZE(PZHAT,1)):: ZAPZOA2 ! Spherical
+ ! earth factor
+ ! for J
+REAL, DIMENSION(SIZE(PXHAT,1),SIZE(PYHAT,1)):: ZXHATM ! X and Y mass point
+REAL, DIMENSION(SIZE(PXHAT,1),SIZE(PYHAT,1)):: ZYHATM ! conformal coordinates
+!
+REAL ZRDSDG ! Radian to Degree conversion factor
+REAL ZCLAT0,ZSLAT0 ! Cos and Sin of XLAT0
+REAL,DIMENSION(SIZE(PLAT,1),SIZE(PLAT,2)) :: ZLAT
+REAL :: ZRPK,ZLAT0
+!
+INTEGER :: IIU,IJU,IKU ! Uupper bounds of PXHAT,PYHAT,PZHAT
+INTEGER :: IIE,IJE,IKE ! End of usefull area of PXHAT,PYHAT,PZHAT
+INTEGER :: IIB,IJB,IKB ! Begining of usefull area of PXHAT,PYHAT,PZHAT
+INTEGER :: IDELTA1 ! Switch=0 if thin shell approximation
+INTEGER :: ILUOUT,IRESP ! Unit number for prints, FM error code
+INTEGER :: JKLOOP ! Index for control prints
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. RETRIEVE LOGICAL UNIT NUMBER FOR OUTPUT-LISTING AND DIMENSIONS
+! --------------------------------------------------------------
+!
+CALL FMLOOK(HLUOUT,HLUOUT,ILUOUT,IRESP)
+!
+IIU = UBOUND(PXHAT,1)
+IJU = UBOUND(PYHAT,1)
+IKU = UBOUND(PZHAT,1)
+IIE = IIU-JPHEXT
+IJE = IJU-JPHEXT
+IKE = IKU-JPVEXT
+IIB = 1+JPHEXT
+IJB = 1+JPHEXT
+IKB = 1+JPVEXT
+!
+IF(NVERB >= 10) THEN !Value control
+ WRITE(ILUOUT,*) 'SM_GRIDPROJ: IIU,IJU,IKU=',IIU,IJU,IKU
+ WRITE(ILUOUT,*) 'SM_GRIDPROJ: IIE,IJE,IKE=',IIE,IJE,IKE
+ WRITE(ILUOUT,*) 'SM_GRIDPROJ: IIB,IJB,IKB=',IIB,IJB,IKB
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. COMPUTES Z (W LEVEL)
+! ----------------------
+!
+!JDJDJDJD 291196
+! Ai enleve le forcage ci-apres --> non compatibilite avec la partie CONVERSION
+! actuelle
+!CSTORAGE_TYPE='PG'
+!print *,' MODE_GRIDPROJ CSTORAGE_TYPE AP FORCAGE TEMPORAIRE ',CSTORAGE_TYPE
+IF((CCONF /= 'POSTP') .OR. (CCONF =='POSTP' .AND. CSTORAGE_TYPE /= 'PG' &
+ .AND. CSTORAGE_TYPE /= 'SU' ))THEN
+!JDJDJDJD 291196
+!
+CALL VERT_COORD(OSLEVE,PZS,PZSMT,PLEN1,PLEN2,PZHAT,PZZ)
+!
+IF(NVERB >= 10) THEN !Value control
+ WRITE(ILUOUT,*) 'SM_GRIDPROJ: Some PZS values:'
+ WRITE(ILUOUT,*) PZS(1,1),PZS(IIU/2,IJU/2),PZS(IIU,IJU)
+ WRITE(ILUOUT,*) 'SM_GRIDPROJ: Some PZZ values:'
+ DO JKLOOP=1,IKU
+ WRITE(ILUOUT,*) PZZ(1,1,JKLOOP),PZZ(IIU/2,IJU/2,JKLOOP), &
+ PZZ(IIU,IJU,JKLOOP)
+ END DO
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. COMPUTE SPHERICAL EARTH FACTOR (MASS LEVEL)
+! --------------------------------------------
+!
+! NOTE: In this routine LCARTESIAN is ALWAYS .F.
+! Hence, IDELTA2 is always set to 1
+!
+IF (LTHINSHELL) IDELTA1=0 ! THIN SHELL APPROX.
+IF(.NOT.LTHINSHELL) IDELTA1=1 ! NO THIN SHELL APPROX.
+!
+IF(NVERB >= 10) THEN !Value control
+ WRITE(ILUOUT,*) 'SM_GRIDPROJ: LTHINSHELL, IDELTA1=',LTHINSHELL,IDELTA1
+ WRITE(ILUOUT,*) 'SM_GRIDPROJ: XRADIUS=',XRADIUS
+ENDIF
+!
+! For the time being, an inline implementation of MZF
+! is provided here.
+!
+ZAPZOA2(:,:,1:IKU-1) = (.5*((XRADIUS+IDELTA1*PZZ(:,:,1:IKU-1)) &
+ + (XRADIUS+IDELTA1*PZZ(:,:,2:IKU))) &
+ /XRADIUS)**2
+ZAPZOA2(:,:,IKU) = 2.*ZAPZOA2(:,:,IKU-1)-ZAPZOA2(:,:,IKU-2)
+!
+IF(NVERB >= 10) THEN !Value control
+ WRITE(ILUOUT,*) 'SM_GRIDPROJ: Some ZAPZOA2 values:'
+ DO JKLOOP=1,IKU
+ WRITE(ILUOUT,*) ZAPZOA2(1,1,JKLOOP),ZAPZOA2(IIU/2,IJU/2,JKLOOP), &
+ ZAPZOA2(IIU,IJU,JKLOOP)
+ END DO
+END IF
+!JDJDJDJD 291196
+ENDIF
+!JDJDJDJD 291196
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. COMPUTE ZXHAT AND ZYHAT AT MASS POINTS
+! -------------------------------------
+!
+ZXHATM(1:IIU-1,1) = .5*(PXHAT(1:IIU-1)+PXHAT(2:IIU))
+ZXHATM(IIU,1) = 2.*PXHAT(IIU)-ZXHATM(IIU-1,1)
+ZXHATM(:,2:IJU) = SPREAD(ZXHATM(:,1),2,IJU-1)
+!
+ZYHATM(1,1:IJU-1) = .5*(PYHAT(1:IJU-1)+PYHAT(2:IJU))
+ZYHATM(1,IJU) = 2.*PYHAT(IJU)-ZYHATM(1,IJU-1)
+ZYHATM(2:IIU,:) = SPREAD(ZYHATM(1,:),1,IIU-1)
+!
+!-----------------------------------------------------------------------------
+!
+!* 5. COMPUTE LATITUDES AND LONGITUDES AT MASS POINTS
+! -------------------------------------------------
+!
+CALL SM_LATLON(PLATOR,PLONOR,ZXHATM,ZYHATM,PLAT,PLON)
+!
+!-----------------------------------------------------------------------------
+!
+!* 6. COMPUTE MAP FACTOR AT MASS POINTS
+! -----------------------------------
+!
+ IF (XRPK<0.) THEN ! projection from north pole
+ ZRPK=-XRPK
+ ZLAT0=-XLAT0
+ ZLAT(:,:)=-PLAT(:,:)
+ ELSE ! projection from south pole
+ ZRPK=XRPK
+ ZLAT0=XLAT0
+ ZLAT(:,:)=PLAT(:,:)
+ ENDIF
+!
+ZRDSDG = XPI/180.
+ZCLAT0 = COS(ZRDSDG*ZLAT0)
+ZSLAT0 = SIN(ZRDSDG*ZLAT0)
+!
+IF ((ABS(ZRPK-1.)>1.E-10).AND. (ANY(ABS(COS(ZRDSDG*ZLAT))<1.E-10))) THEN
+ WRITE(ILUOUT,*) 'Error in SM_GRIDPROJ : '
+ WRITE(ILUOUT,*) 'pole in the domain, but not with stereopolar projection'
+ STOP
+ENDIF
+!
+IF (ABS(ZCLAT0)<1.E-10 .AND. (ABS(ZRPK-1.)<1.E-10)) THEN
+ PMAP(:,:) = (1.+ZSLAT0)/(1.+SIN(ZRDSDG*ZLAT(:,:)))
+ELSE
+ WHERE (ABS(COS(ZRDSDG*ZLAT(:,:)))>1.E-10)
+ PMAP(:,:) = ((ZCLAT0/COS(ZRDSDG*ZLAT(:,:)))**(1.-ZRPK)) &
+ * ((1.+ZSLAT0)/(1.+SIN(ZRDSDG*ZLAT(:,:))))**ZRPK
+ ELSEWHERE
+ PMAP(:,:) = (1.+ZSLAT0)/(1.+SIN(ZRDSDG*ZLAT(:,:)))
+ ENDWHERE
+END IF
+!
+IF(NVERB >= 10) THEN !Value control
+ WRITE(ILUOUT,*) 'Some PMAP values:'
+ WRITE(ILUOUT,*) PMAP(1,1),PMAP(IIU/2,IJU/2),PMAP(IIU,IJU)
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 7. COMPUTE LOCAL MESH-SIZES AT MASS POINTS
+! --------------------------------------
+!
+PDXHAT(1:IIU-1) = PXHAT(2:IIU) - PXHAT(1:IIU-1)
+PDXHAT(IIU) = PDXHAT(IIU-1)
+!
+PDYHAT(1:IJU-1) = PYHAT(2:IJU) - PYHAT(1:IJU-1)
+PDYHAT(IJU) = PDYHAT(IJU-1)
+!
+!JDJDJDJD 291196
+ print*,'CCONF=',CCONF,' CSTORAGE_TYPE=',CSTORAGE_TYPE
+IF((CCONF /= 'POSTP') .OR. (CCONF == 'POSTP' .AND. CSTORAGE_TYPE /= 'PG' &
+ .AND. CSTORAGE_TYPE /= 'SU' ))THEN
+!JDJDJDJD 291196
+ZDZ(:,:,1:IKU-1) = PZZ(:,:,2:IKU) - PZZ(:,:,1:IKU-1)
+ZDZ(:,:,IKU) = ZDZ(:,:,IKU-1)
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. COMPUTE J AT MASS POINTS
+! -------------------------
+!
+PJ(:,:,:) = ZAPZOA2(:,:,:) &
+ * SPREAD( &
+ (1/PMAP(:,:)**2)*(SPREAD(PDXHAT(:),2,IJU)*SPREAD(PDYHAT(:),1,IIU)) &
+ ,3,IKU) * ZDZ(:,:,:)
+!JDJDJDJD 291196
+ENDIF
+!JDJDJDJD 291196
+!
+!
+!
+RETURN
+!-----------------------------------------------------------------------------
+END SUBROUTINE SM_GRIDPROJ
+!-----------------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------------
+!
+!
+!
+!* 2. ROUTINE SM_LATLON_S (Scalar Version)
+! -------------------
+!----------------------------------------------------------------------------
+! #################################################
+ SUBROUTINE SM_LATLON_S(PLATOR,PLONOR,PXHATM,PYHATM,PLAT,PLON)
+! #################################################
+!
+!!**** *SM_LATLON_S * - Routine to compute geographical coordinates
+!!
+!! PURPOSE
+!! -------
+! This routine computes the latitude and longitude of
+! a single point from the cartesian conformal coordinates
+! Five map projections are available:
+! - polar-stereographic from south pole (XRPK=1),
+! - lambert conformal from south pole (0<XRPK<1),
+! - mercator (XRPK=0),
+! - lambert conformal from north pole (-1<XRPK<0),
+! - polar-stereographic from north pole (XRPK=-1).
+!
+!
+!!** METHOD
+!! ------
+!! Spherical earth approximation is used. Longitude origin is
+!! set in Greenwich, and is positive eastwards. An anticlockwise
+!! rotation of XBETA degrees is applied to the conformal frame
+!! with respect to the geographical directions.
+!!
+!! WARNING: ALL INPUT AND OUTPUT ANGLES ARE IN DEGREES...
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! EXPLICIT ARGUMENTS
+!! ------------------
+!! PXHAT,PYHAT(:) : 1D arrays of the "velocity" gridpoints
+!! cartesian conformal coordinates (meters,input).
+!! PLATOR : Latitude of the (1,1) point of the "mass" grid
+!! (degrees,input);
+!! PLONOR : Longitude of the (1,1) point of the "mass" grid
+!! (degrees,input);
+!! PXHATM : conformal coordinate x (meters, mass-grid, input)
+!! PYHATM : conformal coordinate y (meters, mass-grid, input)
+!! PLAT : latitude (degrees, mass-grid, output)
+!! PLON : longitude (degrees, mass-grid, output)
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST : contains Physical constants
+!! XPI : Pi;
+!! XRADIUS : Earth radius (meters);
+!!
+!! Module MODD_GRID : contains spatial grid variables
+!! XLON0,XLAT0 : Reference latitude and longitude for
+!! the conformal projection (degrees);
+!! XBETA : Rotation angle of the conformal frame
+!! with respect to the geographical
+!! north (degrees);
+!! XRPK : Projection constant (0 Mercator,
+!! 0<XRPK<1 Lambert, 1 Polar-stereographic)
+!!
+!! REFERENCE
+!! ---------
+!! Asencio N. et al., 1994, "Le projet de modele non-hydrostatique
+!! commun CNRM-LA, specifications techniques",
+!! Note CNRM/GMME, 26, 139p, (Chapter 2).
+!! Ducrocq V., 1994, "Generation de la grille dans le modele",
+!! Note interne MNH, 5 mai, 3p.
+!! Joly A., 1992, "Geographic parameters for ARPEGE/ALADIN",
+!! Internal note ARPEGE/ALADIN, february 27,28p.
+!! Levallois J., 1970, "Geodesie generale", Tome 2, Collection
+!! de l'IGN, Eyrolles, Paris, 408p.
+!!
+!! AUTHOR
+!! ------
+!! P.M. *LA*
+!!
+!! MODIFICATION
+!! ------------
+!! Original PM 24/05/94
+!! Updated PM 27/07/94
+!! Updated VD 23/08/94
+!! Updated VM 24/10/95 projection from north pole (XRPK<0) and
+!! longitudes set between XLON0-180. and XLON0+180.
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CST
+USE MODD_GRID
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments and results
+!
+REAL, INTENT(IN) :: PLATOR ! Latitude of the origine point
+REAL, INTENT(IN) :: PLONOR ! Longitude of the origine point
+REAL, INTENT(IN) :: PXHATM,PYHATM ! given conformal coordinates of the
+ ! proccessed point (meters);
+REAL, INTENT(OUT):: PLAT,PLON ! returned geographic latitude and
+ ! longitude of the processed point
+ ! (degrees).
+!
+!* 0.2 Declarations of local variables
+!
+REAL :: ZRPK,ZBETA,ZLAT0,ZLON0,ZLATOR,ZLONOR,ZYHATM
+REAL :: ZRDSDG,ZCLAT0,ZSLAT0,ZCLATOR,ZSLATOR
+REAL :: ZXBM0,ZYBM0,ZRO0,ZGA0
+!! JDJDJDJDJD Modif pour supporter des calculs intermediaires de capacite>32bits
+!REAL :: ZXP,ZYP,ZEPSI,ZT1,ZCGAM,ZSGAM,ZRACLAT0
+REAL :: ZXP,ZYP,ZEPSI,ZCGAM,ZSGAM,ZRACLAT0
+REAL(KIND=8) :: ZT1
+!
+!REAL :: ZATA,ZRO2,ZT2,ZXMI0,ZYMI0
+REAL :: ZATA,ZRO2,ZXMI0,ZYMI0,ZJD3
+REAL(KIND=8) :: ZT2,ZJD1
+!!!! JDJDJD
+!
+!--------------------------------------------------------------------------------
+!
+!* 1. PRELIMINARY CALCULATIONS FOR ALL PROJECTIONS
+! --------------------------------------------
+!
+ZRDSDG = XPI/180. ! Degree to radian conversion factor
+ZEPSI = 10.*EPSILON(1.) ! A small number
+!
+! By definition, (PLONOR,PLATOR) are the geographical
+! coordinates, and (ZXBM0,ZYBM0) the conformal cartesian
+!! coordinates of the (1,1) point of the "mass" grid.
+! coordinates x=0, y=0 of the grid.
+!
+ZXBM0 = 0.
+ZYBM0 = 0.
+
+!
+!--------------------------------------------------------------------------------
+!
+!* 2. POLAR STEREOGRAPHIC AND LAMBERT CONFORMAL CASES
+! -----------------------------------------------
+! (XRPK=1 P-stereo, 0<XRPK<1 Lambert)
+!
+IF (XRPK /= 0.) THEN
+!
+ IF (XRPK<0.) THEN ! projection from north pole
+ ZRPK=-XRPK
+ ZBETA=-XBETA
+ ZLAT0=-XLAT0
+ ZLON0=XLON0+180.
+ ZLATOR=-PLATOR
+ ZLONOR=PLONOR+180.
+ ZYHATM=-PYHATM
+ ZYBM0=-ZYBM0
+ ELSE ! projection from south pole
+ ZRPK=XRPK
+ ZBETA=XBETA
+ ZLAT0=XLAT0
+ ZLON0=XLON0
+ ZLATOR=PLATOR
+ ZLONOR=PLONOR
+ ZYHATM=PYHATM
+ ENDIF
+!
+!
+!* 2.1 Preliminary calculations
+!
+ ZCLAT0 = COS(ZRDSDG*ZLAT0)
+ ZSLAT0 = SIN(ZRDSDG*ZLAT0)
+ ZCLATOR = COS(ZRDSDG*ZLATOR)
+ ZSLATOR = SIN(ZRDSDG*ZLATOR)
+ ZRO0 = (XRADIUS/ZRPK)*(ABS(ZCLAT0))**(1.-ZRPK) &
+ * ((1.+ZSLAT0)*ABS(ZCLATOR)/(1.+ZSLATOR))**ZRPK
+ ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG
+ ZXP = ZXBM0-ZRO0*SIN(ZGA0)
+ ZYP = ZYBM0+ZRO0*COS(ZGA0)
+!
+!* 2.2 Longitude
+!
+ IF(ABS(ZYHATM-ZYP) < ZEPSI.AND.ABS(PXHATM-ZXP) < ZEPSI)THEN
+ ZATA = 0.
+ ELSE
+ ZATA = ATAN2(-(ZXP-PXHATM),(ZYP-ZYHATM))/ZRDSDG
+ ENDIF
+ !
+ PLON = (ZBETA+ZATA)/ZRPK+ZLON0
+!
+!* 2.3 Latitude
+!
+ ZRO2 = (PXHATM-ZXP)**2+(ZYHATM-ZYP)**2
+!! JDJDJDJDJD Modif pour supporter des calculs intermediaires de capacite>32bits
+ ZJD1 = XRADIUS*(ABS(ZCLAT0))**(1.-ZRPK)
+ ZT1 = (ZJD1)**(2./ZRPK) &
+ * (1+ZSLAT0)**2
+! ZT1 = (XRADIUS*(ABS(ZCLAT0))**(1.-ZRPK))**(2./ZRPK) &
+! * (1+ZSLAT0)**2
+ ZJD3 = (ZRPK**2*ZRO2)
+ ZT2 = ZJD3
+ ZT2 = ZT2**(1./ZRPK)
+! ZT2 = (ZRPK**2*ZRO2)**(1./ZRPK)
+ !
+ ZJD1 = (ZT1-ZT2)/(ZT1+ZT2)
+ ZJD1 = ACOS(ZJD1)
+ ZJD3 = ZJD1
+ PLAT = (XPI/2.-ZJD3)/ZRDSDG
+! PLAT = (XPI/2.-ACOS((ZT1-ZT2)/(ZT1+ZT2)))/ZRDSDG
+!! JDJDJDJDJD
+!
+ IF (XRPK<0.) THEN ! projection from north pole
+ PLAT=-PLAT
+ PLON=PLON-180.
+ ENDIF
+!
+!---------------------------------------------------------------------------------
+!
+!* 3. MERCATOR PROJECTION WITH ROTATION
+! ---------------------------------
+! (XRPK=0)
+!
+ELSE
+!
+!* 3.1 Preliminary calculations
+!
+ ZCGAM = COS(-ZRDSDG*XBETA)
+ ZSGAM = SIN(-ZRDSDG*XBETA)
+ ZRACLAT0 = XRADIUS*COS(ZRDSDG*XLAT0)
+!
+!* 3.2 Longitude
+!
+ ZXMI0 = PXHATM-ZXBM0
+ ZYMI0 = PYHATM-ZYBM0
+ !
+ PLON = (ZXMI0*ZCGAM+ZYMI0*ZSGAM)/(ZRACLAT0*ZRDSDG)+PLONOR
+!
+!* 3.3 Latitude
+!
+ ZT1 = LOG(TAN(XPI/4.+PLATOR*ZRDSDG/2.))
+ ZT2 = (-ZXMI0*ZSGAM+ZYMI0*ZCGAM)/ZRACLAT0
+ !
+ PLAT = (-XPI/2.+2.*ATAN(EXP(ZT1+ZT2)))/ZRDSDG
+!
+!---------------------------------------------------------------------------------
+!
+!* 4. EXIT
+! ----
+!
+END IF
+PLON=PLON+NINT((XLON0-PLON)/360.)*360.
+RETURN
+!--------------------------------------------------------------------------------
+END SUBROUTINE SM_LATLON_S
+!-------------------------------------------------------------------------------
+!
+!---------------------------------------------------------------------------------
+!
+!* 3. ROUTINE SM_LATLON_A (Array Version )
+! -------------------
+!--------------------------------------------------------------------------------
+! ###################################################
+ SUBROUTINE SM_LATLON_A(PLATOR,PLONOR, &
+ PXHATM,PYHATM,PLAT,PLON)
+! ###################################################
+!
+!!**** *SM_LATLON_A * - Routine to compute geographical coordinates
+!!
+!! PURPOSE
+!! -------
+! This routine computes the latitude and longitude of
+! an array given in cartesian conformal coordinates
+! Five map projections are available:
+! - polar-stereographic from south pole (XRPK=1),
+! - lambert conformal from south pole (0<XRPK<1),
+! - mercator (XRPK=0),
+! - lambert conformal from north pole (-1<XRPK<0),
+! - polar-stereographic from north pole (XRPK=-1).
+!
+!
+!!** METHOD
+!! ------
+!! Spherical earth approximation is used. Longitude origin is
+!! set in Greenwich, and is positive eastwards. An anticlockwise
+!! rotation of XBETA degrees is applied to the conformal frame
+!! with respect to the geographical directions.
+!!
+!! WARNING: ALL INPUT AND OUTPUT ANGLES ARE IN DEGREES...
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! EXPLICIT ARGUMENTS
+!! ------------------
+!! PXHAT,PYHAT(:) : 1D arrays of the "velocity" gridpoints
+!! cartesian conformal coordinates (meters,input).
+!! PLATOR : Latitude of the (1,1) point of the "mass" grid
+!! (degrees,input);
+!! PLONOR : Longitude of the (1,1) point of the "mass" grid
+!! (degrees,input);
+!! PXHATM : conformal coordinate x (meters, mass-grid, input)
+!! PYHATM : conformal coordinate y (meters, mass-grid, input)
+!! PLAT : latitude (degrees, mass-grid, output)
+!! PLON : longitude (degrees, mass-grid, output)
+!!
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST : contains Physical constants
+!! XPI : Pi;
+!! XRADIUS : Earth radius (meters);
+!!
+!! Module MODD_GRID : contains spatial grid variables
+!! XLON0,XLAT0 : Reference latitude and longitude for
+!! the conformal projection (degrees);
+!! XBETA : Rotation angle of the conformal frame
+!! with respect to the geographical
+!! north (degrees);
+!! XRPK : Projection constant (0 Mercator,
+!! 0<XRPK<1 Lambert, 1 Polar-stereographic);
+!!
+!! REFERENCE
+!! ---------
+!! Asencio N. et al., 1994, "Le projet de modele non-hydrostatique
+!! commun CNRM-LA, specifications techniques",
+!! Note CNRM/GMME, 26, 139p, (Chapter 2).
+!! Ducrocq V., 1994, "Generation de la grille dans le modele",
+!! Note interne MNH, 5 mai, 3p.
+!! Joly A., 1992, "Geographic parameters for ARPEGE/ALADIN",
+!! Internal note ARPEGE/ALADIN, february 27,28p.
+!! Levallois J., 1970, "Geodesie generale", Tome 2, Collection
+!! de l'IGN, Eyrolles, Paris, 408p.
+!!
+!! AUTHOR
+!! ------
+!! P.M. *LA*
+!!
+!! MODIFICATION
+!! ------------
+!! Original PM 24/05/94
+!! Updated PM 27/07/94
+!! Updated VD 23/08/94
+!! Updated VM 24/10/95 projection from north pole (XRPK<0) and
+!! longitudes set between XLON0-180. and XLON0+180.
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CST
+USE MODD_GRID
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments and results
+!
+REAL, INTENT(IN) :: PLATOR ! Latitude of the origine point
+REAL, INTENT(IN) :: PLONOR ! Longitude of the origine point
+REAL, DIMENSION(:,:), INTENT(IN) :: PXHATM,PYHATM
+ ! given conformal coordinates of the
+ ! processed points (meters);
+REAL, DIMENSION(:,:), INTENT(OUT):: PLAT,PLON
+ ! returned geographic latitudes and
+ ! longitudes of the processed points
+ ! (degrees).
+!
+!* 0.2 Declarations of local variables
+!
+REAL, DIMENSION(SIZE(PYHATM,1),SIZE(PYHATM,2)) :: ZYHATM
+REAL :: ZRPK,ZBETA,ZLAT0,ZLON0,ZLATOR,ZLONOR
+REAL :: ZRDSDG,ZCLAT0,ZSLAT0,ZCLATOR,ZSLATOR
+REAL :: ZXBM0,ZYBM0,ZRO0,ZGA0
+!! JDJDJDJDJD Modif pour supporter des calculs intermediaires de capacite>32bits
+!REAL :: ZXP,ZYP,ZEPSI,ZT1,ZCGAM,ZSGAM,ZRACLAT0
+REAL :: ZXP,ZYP,ZEPSI,ZCGAM,ZSGAM,ZRACLAT0
+REAL(KIND=8) :: ZT1,ZJD4,ZJD5
+REAL :: ZRPK2
+!!! JDJDJDJDJD
+!
+!! JDJDJDJDJD Modif pour supporter des calculs intermediaires de capacite>32bits
+!REAL, DIMENSION(SIZE(PXHATM,1),SIZE(PXHATM,2)) :: ZATA,ZRO2,ZT2,ZXMI0,ZYMI0
+REAL, DIMENSION(SIZE(PXHATM,1),SIZE(PXHATM,2)) :: ZATA,ZRO2,ZXMI0,ZYMI0,ZJD3
+REAL(KIND=8), DIMENSION(SIZE(PXHATM,1),SIZE(PXHATM,2)) :: ZT2,ZJD1,ZJD2
+!!! JDJDJDJDJD
+!
+!--------------------------------------------------------------------------------
+!
+!* 1. Preliminary calculations for all projections
+! --------------------------------------------
+!
+ZRDSDG = XPI/180. ! Degree to radian conversion factor
+ZEPSI = 10.*EPSILON(1.) ! A small number
+!
+! By definition, (PLONOR,PLATOR) are the geographical
+! coordinates, and (ZXBM0,ZYBM0) the conformal cartesian
+! coordinates x=0, y=0 of the grid.
+!! coordinates of the (1,1) point of the "mass" grid.
+!
+ZXBM0 = 0.
+ZYBM0 = 0.
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. POLAR STEREOGRAPHIC AND LAMBERT CONFORMAL CASES
+! -----------------------------------------------
+! (XRPK=1 P-stereo, 0<XRPK<1 Lambert)
+!
+IF(XRPK /= 0.) THEN
+!
+ IF (XRPK<0.) THEN ! projection from north pole
+ ZRPK=-XRPK
+ ZBETA=-XBETA
+ ZLAT0=-XLAT0
+ ZLON0=XLON0+180.
+ ZLATOR=-PLATOR
+ ZLONOR=PLONOR+180.
+ ZYHATM(:,:)=-PYHATM(:,:)
+ ZYBM0=-ZYBM0
+ ELSE ! projection from south pole
+ ZRPK=XRPK
+ ZBETA=XBETA
+ ZLAT0=XLAT0
+ ZLON0=XLON0
+ ZLATOR=PLATOR
+ ZLONOR=PLONOR
+ ZYHATM(:,:)=PYHATM(:,:)
+ ENDIF
+!
+!* 2.1 Preliminary calculations
+!
+ ZCLAT0 = COS(ZRDSDG*ZLAT0)
+ ZSLAT0 = SIN(ZRDSDG*ZLAT0)
+ ZCLATOR = COS(ZRDSDG*ZLATOR)
+ ZSLATOR = SIN(ZRDSDG*ZLATOR)
+ ZRO0 = (XRADIUS/ZRPK)*(ABS(ZCLAT0))**(1.-ZRPK) &
+ * ((1.+ZSLAT0)*ABS(ZCLATOR)/(1.+ZSLATOR))**ZRPK
+ ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG
+ ZXP = ZXBM0-ZRO0*SIN(ZGA0)
+ ZYP = ZYBM0+ZRO0*COS(ZGA0)
+!
+!* 2.2 Longitude
+!
+ WHERE (ABS(ZYHATM(:,:)-ZYP) < ZEPSI &
+ .AND.ABS(PXHATM(:,:)-ZXP) < ZEPSI)
+ ZATA(:,:) = 0.
+ ELSEWHERE
+ ZATA(:,:) = ATAN2(-(ZXP-PXHATM(:,:)),(ZYP-ZYHATM(:,:)))/ZRDSDG
+ END WHERE
+ !
+ PLON(:,:) = (ZBETA+ZATA(:,:))/ZRPK+ZLON0
+!
+!* 2.3 Latitude
+!
+ ZRO2(:,:) = (PXHATM(:,:)-ZXP)**2+(ZYHATM(:,:)-ZYP)**2
+ ZJD4 = (XRADIUS*(ABS(ZCLAT0))**(1.-ZRPK))
+ ZJD5 = ZJD4**(2./ZRPK)
+ ZT1 = ZJD5 * (1+ZSLAT0)**2
+! ZT1 = (XRADIUS*(ABS(ZCLAT0))**(1.-ZRPK))**(2./ZRPK) &
+! * (1+ZSLAT0)**2
+ ZRPK2 = ZRPK**2
+ ZJD3(:,:) = (ZRPK2*ZRO2(:,:))
+ ZT2(:,:) = ZJD3(:,:)
+ ZT2(:,:) = ZT2(:,:)**(1./ZRPK)
+! ZT2(:,:) = (ZRPK**2*ZRO2(:,:))**(1./ZRPK)
+!
+!! JDJDJDJDJD Modif pour supporter des calculs intermediaires de capacite>32bits
+ ZJD1(:,:) = (ZT1-ZT2(:,:))
+ ZJD2(:,:) = (ZT1+ZT2(:,:))
+ ZJD1(:,:) = ZJD1(:,:)/ZJD2(:,:)
+ ZJD1(:,:) = ACOS(ZJD1(:,:))
+ ZJD3(:,:) = ZJD1(:,:)
+ PLAT(:,:) = (XPI/2.-ZJD3(:,:))/ZRDSDG
+! PLAT(:,:) = (XPI/2.-ACOS((ZT1-ZT2(:,:))/(ZT1+ZT2(:,:))))/ZRDSDG
+!! JDJDJDJDJD
+!
+ IF (XRPK<0.) THEN ! projection from north pole
+ PLAT(:,:)=-PLAT(:,:)
+ PLON(:,:)=PLON(:,:)+180.
+ ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. MERCATOR PROJECTION WITH ROTATION
+! ---------------------------------
+! (XRPK=0)
+!
+ELSE
+!
+!* 3.1 Preliminary calculations
+!
+ ZCGAM = COS(-ZRDSDG*XBETA)
+ ZSGAM = SIN(-ZRDSDG*XBETA)
+ ZRACLAT0 = XRADIUS*COS(ZRDSDG*XLAT0)
+!
+!* 3.2 Longitude
+!
+ ZXMI0(:,:) = PXHATM(:,:)-ZXBM0
+ ZYMI0(:,:) = PYHATM(:,:)-ZYBM0
+ !
+ PLON(:,:) = (ZXMI0(:,:)*ZCGAM+ZYMI0(:,:)*ZSGAM) &
+ / (ZRACLAT0*ZRDSDG)+PLONOR
+!
+!* 3.3 Latitude
+!
+ ZT1 = ALOG(TAN(XPI/4.+PLATOR*ZRDSDG/2.))
+ ZT2(:,:) = (-ZXMI0(:,:)*ZSGAM+ZYMI0(:,:)*ZCGAM)/ZRACLAT0
+ !
+ PLAT(:,:) = (-XPI/2.+2.*ATAN(EXP(ZT1+ZT2(:,:))))/ZRDSDG
+!
+!---------------------------------------------------------------------------------
+!
+!* 4. EXIT
+! ----
+!
+END IF
+PLON(:,:)=PLON(:,:)+NINT((XLON0-PLON(:,:))/360.)*360.
+RETURN
+!---------------------------------------------------------------------------------
+END SUBROUTINE SM_LATLON_A
+!---------------------------------------------------------------------------------
+!
+!---------------------------------------------------------------------------------
+!
+!* 4. ROUTINE SM_XYHAT_S (Scalar Version )
+! ------------------
+!--------------------------------------------------------------------------------
+! ##################################################
+ SUBROUTINE SM_XYHAT_S(PLATOR,PLONOR, &
+ PLAT,PLON,PXHATM,PYHATM)
+! ##################################################
+!
+!!**** *SM_XYHAT_S * - Routine to compute conformal coordinates
+!!
+!! PURPOSE
+!! -------
+! This routine computes the cartesian conformal coordinates
+! of a single point from its latitude and longitude
+! Five map projections are available:
+! - polar-stereographic from south pole (XRPK=1),
+! - lambert conformal from south pole (0<XRPK<1),
+! - mercator (XRPK=0),
+! - lambert conformal from north pole (-1<XRPK<0),
+! - polar-stereographic from north pole (XRPK=-1).
+!
+!
+!!** METHOD
+!! ------
+!! Spherical earth approximation is used. Longitude origin is
+!! set in Greenwich, and is positive eastwards. An anticlockwise
+!! rotation of XBETA degrees is applied to the conformal frame
+!! with respect to the geographical directions.
+!!
+!! WARNING: ALL INPUT AND OUTPUT ANGLES ARE IN DEGREES...
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! EXPLICIT ARGUMENTS
+!! ------------------
+!! PLATOR : Latitude of the (1,1) point of the "mass" grid
+!! (degrees,input);
+!! PLONOR : Longitude of the (1,1) point of the "mass" grid
+!! (degrees,input);
+!! PXHATM : conformal coordinate x (meters, mass-grid, input)
+!! PYHATM : conformal coordinate y (meters, mass-grid, input)
+!! PLAT : latitude (degrees, mass-grid, output)
+!! PLON : longitude (degrees, mass-grid, output)
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST : contains Physical constants
+!! XPI : Pi;
+!! XRADIUS : Earth radius (meters);
+!!
+!! Module MODD_GRID : contains spatial grid variables
+!! XLON0,XLAT0 : Reference latitude and longitude for
+!! the conformal projection (degrees);
+!! XBETA : Rotation angle of the conformal frame
+!! with respect to the geographical
+!! north (degrees);
+!! XRPK : Projection constant (0 Mercator,
+!! 0<XRPK<1 Lambert, 1 Polar-stereographic);
+!!
+!! REFERENCE
+!! ---------
+!! Asencio N. et al., 1994, "Le projet de modele non-hydrostatique
+!! commun CNRM-LA, specifications techniques",
+!! Note CNRM/GMME, 26, 139p, (Chapter 2).
+!! Ducrocq V., 1994, "Generation de la grille dans le modele",
+!! Note interne MNH, 5 mai, 3p.
+!! Joly A., 1992, "Geographic parameters for ARPEGE/ALADIN",
+!! Internal note ARPEGE/ALADIN, february 27,28p.
+!! Levallois J., 1970, "Geodesie generale", Tome 2, Collection
+!! de l'IGN, Eyrolles, Paris, 408p.
+!!
+!! AUTHOR
+!! ------
+!! P.M. *LA*
+!!
+!! MODIFICATION
+!! ------------
+!! Original PM 24/05/94
+!! Updated PM 27/07/94
+!! Updated VD 23/08/94
+!! Updated VM 24/10/95 projection from north pole (XRPK<0) and
+!! longitudes set between XLON0-180. and XLON0+180.
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CST
+USE MODD_GRID
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments and results
+!
+REAL, INTENT(IN) :: PLATOR ! Latitude of the origine point
+REAL, INTENT(IN) :: PLONOR ! Longitude of the origine point
+REAL, INTENT(IN) :: PLAT,PLON
+ ! given geographic latitude and
+ ! longitude of the processed point
+ ! (degrees).
+REAL, INTENT(OUT):: PXHATM,PYHATM
+ ! returned conformal coordinates of
+ ! the processed point (meters);
+!
+!* 0.2 Declarations of local variables
+!
+REAL :: ZRPK,ZBETA,ZLAT0,ZLON0,ZLATOR,ZLONOR
+REAL :: ZLAT,ZLON
+REAL :: ZRDSDG,ZCLAT0,ZSLAT0,ZCLATOR,ZSLATOR
+REAL :: ZXBM0,ZYBM0,ZRO0,ZGA0
+REAL :: ZXP,ZYP,ZCGAM,ZSGAM,ZRACLAT0,ZXE,ZYE
+!
+REAL :: ZCLAT,ZSLAT,ZRO,ZGA,ZXPR,ZYPR
+!
+!--------------------------------------------------------------------------------
+!
+!* 1. PRELIMINARY CALCULATION FOR ALL PROJECTIONS
+! -------------------------------------------
+!
+ZRDSDG = XPI/180. ! Degree to radian conversion factor
+!
+! By definition, (PLONOR,PLATOR) are the geographical
+! coordinates of the x=0, y=0 point.
+!
+ZXBM0 = 0.
+ZYBM0 = 0.
+!
+ZLON=PLON
+ZLON=ZLON+NINT((XLON0-ZLON)/360.)*360.
+!
+ZLONOR=PLONOR
+ZLONOR=ZLONOR+NINT((XLON0-ZLONOR)/360.)*360.
+!---------------------------------------------------------------------------------
+!
+!* 2. POLAR STEREOGRAPHIC AND LAMBERT CONFORMAL CASES
+! -----------------------------------------------
+! (XRPK=1 P-stereo, 0<XRPK<1 Lambert)
+!
+IF(XRPK /= 0.) THEN
+!
+ IF (XRPK<0.) THEN ! projection from north pole
+ ZRPK=-XRPK
+ ZBETA=-XBETA
+ ZLAT0=-XLAT0
+ ZLON0=XLON0+180.
+ ZLATOR=-PLATOR
+ ZLONOR=ZLONOR+180.
+ ZLAT=-PLAT
+ ZLON=ZLON+180.
+ ZYBM0=-ZYBM0
+ ELSE ! projection from south pole
+ ZRPK=XRPK
+ ZBETA=XBETA
+ ZLAT0=XLAT0
+ ZLON0=XLON0
+ ZLATOR=PLATOR
+ ZLONOR=ZLONOR
+ ZLAT=PLAT
+ ZLON=ZLON
+ ENDIF
+!
+!* 2.1 Preliminary calculations
+!
+ ZCLAT0 = COS(ZRDSDG*ZLAT0)
+ ZSLAT0 = SIN(ZRDSDG*ZLAT0)
+ ZCLATOR = COS(ZRDSDG*ZLATOR)
+ ZSLATOR = SIN(ZRDSDG*ZLATOR)
+ ZRO0 = (XRADIUS/ZRPK)*(ABS(ZCLAT0))**(1.-ZRPK) &
+ * ((1.+ZSLAT0)*ABS(ZCLATOR)/(1.+ZSLATOR))**ZRPK
+ ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG
+ ZXP = ZXBM0-ZRO0*SIN(ZGA0)
+ ZYP = ZYBM0+ZRO0*COS(ZGA0)
+!
+!* 2.2 Conformal coordinates in meters
+!
+ ZCLAT = COS(ZRDSDG*ZLAT)
+ ZSLAT = SIN(ZRDSDG*ZLAT)
+ ZRO = (XRADIUS/ZRPK)*(ABS(ZCLAT0))**(1.-ZRPK) &
+ * ((1.+ZSLAT0)*ABS(ZCLAT)/(1.+ZSLAT))**ZRPK
+ ZGA = (ZRPK*(ZLON-ZLON0)-ZBETA)*ZRDSDG
+!
+ PXHATM = ZXP+ZRO*SIN(ZGA)
+ PYHATM = ZYP-ZRO*COS(ZGA)
+!
+ IF (XRPK<0.) THEN ! projection from north pole
+ PYHATM=-PYHATM
+ ENDIF
+!
+!
+!------------------------------------------------------------------------------
+!
+!* 3. MERCATOR PROJECTION WITH ROTATION
+! ---------------------------------
+! (XRPK=0)
+!
+ELSE
+!
+!* 3.1 Preliminary calculations
+!
+ ZCGAM = COS(-ZRDSDG*XBETA)
+ ZSGAM = SIN(-ZRDSDG*XBETA)
+ ZRACLAT0 = XRADIUS*COS(ZRDSDG*XLAT0)
+ ZXE = ZXBM0*ZCGAM+ZYBM0*ZSGAM &
+ - ZRACLAT0*(PLONOR-XLON0)*ZRDSDG
+ ZYE =-ZXBM0*ZSGAM+ZYBM0*ZCGAM &
+ - ZRACLAT0*LOG(TAN(XPI/4.+PLATOR*ZRDSDG/2.))
+!
+!* 3.2 Conformal coordinates
+!
+ ZXPR = ZRACLAT0*(ZLON-XLON0)*ZRDSDG+ZXE
+ ZYPR = ZRACLAT0*LOG(TAN(XPI/4.+PLAT*ZRDSDG/2.))+ZYE
+ !
+ PXHATM = ZXPR*ZCGAM-ZYPR*ZSGAM
+ PYHATM = ZXPR*ZSGAM+ZYPR*ZCGAM
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. EXIT
+! ----
+!
+END IF
+RETURN
+!-------------------------------------------------------------------------------
+END SUBROUTINE SM_XYHAT_S
+!-------------------------------------------------------------------------------
+!
+!-------------------------------------------------------------------------------
+!
+!* 5. ROUTINE SM_XYHAT_A (Array Version )
+! ------------------
+!-------------------------------------------------------------------------------
+! ################################################
+ SUBROUTINE SM_XYHAT_A(PLATOR,PLONOR, &
+ PLAT,PLON,PXHATM,PYHATM)
+! ################################################
+!
+!!**** *SM_XYHAT_A * - Routine to compute conformal coordinates
+!!
+!!
+!! PURPOSE
+!! -------
+! This routine computes the cartesian conformal coordinates
+! of an array given in latitude-longitude coordinates
+! Three map projections are available:
+! - polar-stereographic (XRPK=1),
+! - lambert conformal (0<XRPK<1),
+! - mercator (XRPK=0).
+!
+!
+!!** METHOD
+!! ------
+!! Spherical earth approximation is used. Longitude origin is
+!! set in Greenwich, and is positive eastwards. An anticlockwise
+!! rotation of XBETA degrees is applied to the conformal frame
+!! with respect to the geographical directions.
+!!
+!! WARNING: ALL INPUT AND OUTPUT ANGLES ARE IN DEGREES...
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! EXPLICIT ARGUMENTS
+!! ------------------
+!! PLATOR : Latitude of the (1,1) point of the "mass" grid
+!! (degrees,input);
+!! PLONOR : Longitude of the (1,1) point of the "mass" grid
+!! (degrees,input);
+!! PXHATM : conformal coordinate x (meters, mass-grid, input)
+!! PYHATM : conformal coordinate y (meters, mass-grid, input)
+!! PLAT : latitude (degrees, mass-grid, output)
+!! PLON : longitude (degrees, mass-grid, output)
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST : contains Physical constants
+!! XPI : Pi;
+!! XRADIUS : Earth radius (meters);
+!!
+!! Module MODD_GRID : contains spatial grid variables
+!! XLON0,XLAT0 : Reference latitude and longitude for
+!! the conformal projection (degrees);
+!! XBETA : Rotation angle of the conformal frame
+!! with respect to the geographical
+!! north (degrees);
+!! XRPK : Projection constant (0 Mercator,
+!! 0<XRPK<1 Lambert, 1 Polar-stereographic);
+!!
+!! REFERENCE
+!! ---------
+!! Asencio N. et al., 1994, "Le projet de modele non-hydrostatique
+!! commun CNRM-LA, specifications techniques",
+!! Note CNRM/GMME, 26, 139p, (Chapter 2).
+!! Ducrocq V., 1994, "Generation de la grille dans le modele",
+!! Note interne MNH, 5 mai, 3p.
+!! Joly A., 1992, "Geographic parameters for ARPEGE/ALADIN",
+!! Internal note ARPEGE/ALADIN, february 27,28p.
+!! Levallois J., 1970, "Geodesie generale", Tome 2, Collection
+!! de l'IGN, Eyrolles, Paris, 408p.
+!!
+!! AUTHOR
+!! ------
+!! P.M. *LA*
+!!
+!! MODIFICATION
+!! ------------
+!! Original PM 24/05/94
+!! Updated PM 27/07/94
+!! Updated VD 23/08/94
+!! Updated VM 24/10/95 projection from north pole (XRPK<0) and
+!! longitudes set between XLON0-180. and XLON0+180.
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CST
+USE MODD_GRID
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments and results
+!
+REAL, INTENT(IN) :: PLATOR ! Latitude of the origine point
+REAL, INTENT(IN) :: PLONOR ! Longitude of the origine point
+REAL, DIMENSION(:,:), INTENT(IN):: PLAT,PLON
+ ! given geographic latitude and
+ ! longitude of the processed
+ ! array (degrees).
+REAL, DIMENSION(:,:), INTENT(OUT):: PXHATM,PYHATM
+ ! returned conformal coordinates of
+ ! the processed array (meters);
+!
+!* 0.2 Declarations of local variables
+!
+REAL,DIMENSION(SIZE(PLAT,1),SIZE(PLAT,2)) :: ZLAT,ZLON
+REAL :: ZRPK,ZBETA,ZLAT0,ZLON0,ZLATOR,ZLONOR
+REAL :: ZRDSDG,ZCLAT0,ZSLAT0,ZCLATOR,ZSLATOR
+REAL :: ZXBM0,ZYBM0,ZRO0,ZGA0
+REAL :: ZXP,ZYP,ZCGAM,ZSGAM,ZRACLAT0,ZXE,ZYE
+!
+REAL,DIMENSION(SIZE(PLAT,1),SIZE(PLAT,2)) :: ZCLAT,ZSLAT,ZRO,ZGA,ZXPR,ZYPR
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. PRELIMINARY CALCULATION FOR ALL PROJECTIONS
+! -------------------------------------------
+!
+ZRDSDG = XPI/180. ! Degree to radian conversion factor
+!
+! By definition, (PLONOR,PLATOR) are the geographical
+! coordinates of the x=0, y=0 point.
+!
+ZXBM0 = 0.
+ZYBM0 = 0.
+!
+ZLON(:,:)=PLON(:,:)
+ZLON(:,:)=ZLON(:,:)+NINT((XLON0-ZLON(:,:))/360.)*360.
+!
+ZLONOR=PLONOR
+ZLONOR=ZLONOR+NINT((XLON0-ZLONOR)/360.)*360.
+!------------------------------------------------------------------------------
+!
+!* 2. POLAR SEREOGRAPHIC AND LAMBERT CONFORMAL CASES
+! ----------------------------------------------
+! (XRPK=1 P-stereo, 0<XRPK<1 Lambert)
+!
+IF(XRPK /= 0.) THEN
+!
+ IF (XRPK<0.) THEN ! projection from north pole
+ ZRPK=-XRPK
+ ZBETA=-XBETA
+ ZLAT0=-XLAT0
+ ZLON0=XLON0+180.
+ ZLATOR=-PLATOR
+ ZLONOR=ZLONOR+180.
+ ZLAT(:,:)=-PLAT(:,:)
+ ZLON(:,:)=ZLON(:,:)+180.
+ ZYBM0=-ZYBM0
+ ELSE ! projection from south pole
+ ZRPK=XRPK
+ ZBETA=XBETA
+ ZLAT0=XLAT0
+ ZLON0=XLON0
+ ZLATOR=PLATOR
+ ZLONOR=ZLONOR
+ ZLAT(:,:)=PLAT(:,:)
+ ZLON(:,:)=ZLON(:,:)
+ ENDIF
+!
+!* 2.1 Preliminary calculations
+!
+ ZCLAT0 = COS(ZRDSDG*ZLAT0)
+ ZSLAT0 = SIN(ZRDSDG*ZLAT0)
+ ZCLATOR = COS(ZRDSDG*ZLATOR)
+ ZSLATOR = SIN(ZRDSDG*ZLATOR)
+ ZRO0 = (XRADIUS/ZRPK)*(ABS(ZCLAT0))**(1.-ZRPK) &
+ * ((1.+ZSLAT0)*ABS(ZCLATOR)/(1.+ZSLATOR))**ZRPK
+ ZGA0 = (ZRPK*(ZLONOR-ZLON0)-ZBETA)*ZRDSDG
+ ZXP = ZXBM0-ZRO0*SIN(ZGA0)
+ ZYP = ZYBM0+ZRO0*COS(ZGA0)
+!
+!* 2.2 Conformal coordinates in meters
+!
+ ZCLAT(:,:) = COS(ZRDSDG*ZLAT(:,:))
+ ZSLAT(:,:) = SIN(ZRDSDG*ZLAT(:,:))
+ ZRO(:,:) = (XRADIUS/ZRPK)*(ABS(ZCLAT0))**(1.-ZRPK) &
+ * ((1.+ZSLAT0)*ABS(ZCLAT(:,:))/(1.+ZSLAT(:,:)))**ZRPK
+ ZGA(:,:) = (ZRPK*(ZLON(:,:)-ZLON0)-ZBETA)*ZRDSDG
+!
+ PXHATM(:,:) = ZXP+ZRO(:,:)*SIN(ZGA(:,:))
+ PYHATM(:,:) = ZYP-ZRO(:,:)*COS(ZGA(:,:))
+!
+ IF (XRPK<0.) THEN ! projection from north pole
+ PYHATM(:,:)=-PYHATM(:,:)
+ ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. MERCATOR PROJECTION WITH ROTATION
+! ---------------------------------
+! (XRPK=0)
+!
+ELSE
+!
+!* 3.1 Preliminary calculations
+!
+ ZCGAM = COS(-ZRDSDG*XBETA)
+ ZSGAM = SIN(-ZRDSDG*XBETA)
+ ZRACLAT0 = XRADIUS*COS(ZRDSDG*XLAT0)
+ ZXE = ZXBM0*ZCGAM+ZYBM0*ZSGAM &
+ - ZRACLAT0*(PLONOR-XLON0)*ZRDSDG
+ ZYE =-ZXBM0*ZSGAM+ZYBM0*ZCGAM &
+ - ZRACLAT0*LOG(TAN(XPI/4.+PLATOR*ZRDSDG/2.))
+!
+!* 3.2 Conformal coordinates
+!
+ ZXPR(:,:) = ZRACLAT0*(ZLON(:,:)-XLON0)*ZRDSDG+ZXE
+ ZYPR(:,:) = ZRACLAT0*LOG(TAN(XPI/4.+PLAT(:,:)*ZRDSDG/2.))+ZYE
+ !
+ PXHATM(:,:) = ZXPR(:,:)*ZCGAM-ZYPR(:,:)*ZSGAM
+ PYHATM(:,:) = ZXPR(:,:)*ZSGAM+ZYPR(:,:)*ZCGAM
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. EXIT
+! ----
+!
+END IF
+RETURN
+!-------------------------------------------------------------------------------
+END SUBROUTINE SM_XYHAT_A
+!-------------------------------------------------------------------------------
+!
+!
+!-------------------------------------------------------------------------------
+!
+!* 6. FUNCTION LATREF2
+! -----------------
+!-------------------------------------------------------------------------------
+! #############################
+ FUNCTION LATREF2(PLAT0,PRPK)
+! #############################
+!
+!!**** *LATREF2 * - returns the Lambert second reference latitude
+!!
+!! PURPOSE
+!! -------
+! This routine computes the second reference latitude
+! of a Lambert conformal projection for given projection
+! parameter PRPK and primary reference latitude PLAT0.
+! This second latitude is used in US and UK to define
+! the secant Lambert projection (as a substitute for the
+! cone constant PRPK used in France by IGN).
+! This latitude is required to call the NCAR map projection
+! package with the Lambert option.
+!
+!!** METHOD
+!! ------
+!! The so-called "constant of the cone" equation is solved
+!! using a simple Newton-Raphson iteration. The spherical earth
+!! approximation is used.
+!!
+!! WARNING: ALL INPUT AND OUTPUT ANGLES ARE IN DEGREES...
+!!
+!! EXTERNAL
+!! --------
+!! None
+!!
+!! EXPLICIT ARGUMENTS
+!! -------------------
+!! PRPK : projection factor (no-unit, input)
+!! PLAT0 : map reference latitude (degrees, input)
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_CST : contains Physical constants
+!! XPI : Pi;
+!!
+!! Module MODD_LUNIT : contains logical unit names
+!! CLUOUT0 : Output listing file name
+!!
+!! REFERENCE
+!! ---------
+!! Joly A., 1992, "Geographic parameters for ARPEGE/ALADIN",
+!! Internal note ARPEGE/ALADIN, february 27,28p.
+!! Levallois J., 1970, "Geodesie generale", Tome 2, Collection
+!! de l'IGN, Eyrolles, Paris, 408p.
+!! Pearson F. II, 1990,"Map projections: theory and applications",
+!! CRC Press, Boca Raton, Florida, 372p. (Chapter 5).
+!!
+!! AUTHOR
+!! ------
+!! P.M. *LA*
+!!
+!! MODIFICATION
+!! ------------
+!! Original PM 24/05/94
+!! Updated PM 27/07/94
+!! Updated VD 25/08/94
+!! Updated VM 24/10/95 projection from north pole (XRPK<0)
+!! Updated VM 08/10/96 output-listing choice
+!! Updated IM 27/11/03 special case if projection plane is tangent
+!!
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_CST
+USE MODD_LUNIT1
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments and results
+!
+REAL,INTENT(IN):: PLAT0,PRPK ! Given first standard latitude (degrees)
+ ! and projection parameter (cone
+ ! constant) for the Lambert conformal
+ ! projection used.
+REAL :: LATREF2 ! Returned latitude of the second
+ ! reference (or standard) parallel
+ ! of the projection.
+!
+!* 0.2 Declarations of local variables
+!
+REAL :: ZRPK
+REAL :: ZRDSDG,ZEPSI,ZLAT0,ZLAT,ZDLAT,ZGLAT,ZGPRSG
+INTEGER :: ITER,ITERMAX
+INTEGER :: ILUOUT,IRESP
+!
+!-------------------------------------------------------------------------------
+!
+!* 1. PRELIMINARY CALCULATIONS
+! ------------------------
+!
+ZRDSDG = XPI/180. ! Degree to radian conversion factor
+ZEPSI = 10.*EPSILON(1.) ! a small number
+ITERMAX = 10 ! number of iteration allowed
+!
+IF (PRPK ==SIN(ZLAT0*ZRDSDG)) THEN ! projection plane tangent to the sphere
+ LATREF2 = ZLAT0
+ELSE ! " intersect the sphere
+!
+ ZLAT0 = PLAT0*ZRDSDG ! Switch to radians
+!
+ ZLAT = XPI-4.*ATAN(SQRT((1.-PRPK)/(1.+PRPK)))-ZLAT0
+ ITER = 0 ! Choose the side of the nice root
+ ZDLAT = 0. ! and sets up for the loop
+!
+
+!
+ IF (PRPK<0.) THEN ! projection from north pole
+ ZRPK=-PRPK
+ ZLAT0=-ZLAT0
+ ZLAT=-ZLAT
+ ELSE ! projection from south pole
+ ZRPK=PRPK
+ ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. NEWTON-RAPHSON LOOP
+! -------------------
+ DO
+ ITER = ITER+1
+ ZLAT = ZLAT+ZDLAT
+ ZGLAT =(COS(ZLAT)/COS(ZLAT0))* &
+ (((1.+SIN(ZLAT))/(1.+SIN(ZLAT0)))**(ZRPK/(1.-ZRPK)))
+ ZGPRSG = ((ZRPK/(1.-ZRPK))*(COS(ZLAT)/(1.+SIN(ZLAT))) &
+ - (SIN(ZLAT)/COS(ZLAT)))*ZGLAT
+ ZDLAT = (1.-ZGLAT)/ZGPRSG
+ !
+ IF((ABS(ZGLAT-1.) <= ZEPSI).OR.(ITER >= ITERMAX)) EXIT
+ END DO
+!
+ IF (PRPK<0.) ZLAT=-ZLAT
+ LATREF2 = ZLAT/ZRDSDG ! Degrees restored
+!
+ENDIF
+!-------------------------------------------------------------------------------
+!
+!* 3. EXIT
+! ----
+!
+IF(ITER <= ITERMAX) RETURN
+!
+CALL FMLOOK(CLUOUT,CLUOUT,ILUOUT,IRESP)
+!
+WRITE(ILUOUT,*) ' Error in function LATREF2 (module MODE_GRIDPROJ)'
+WRITE(ILUOUT,*) ' Function fails to converge after ',ITER,' iterations.'
+WRITE(ILUOUT,*) ' LATREF2=',LATREF2,' Residual=',ZGLAT-1., &
+ ' ZEPSI=',ZEPSI,' Last increment=',ZDLAT/ZRDSDG
+WRITE(ILUOUT,*) ' JOB ABORTS...'
+STOP
+!-------------------------------------------------------------------------------
+END FUNCTION LATREF2
+!-------------------------------------------------------------------------------
+!
+END MODULE MODE_GRIDPROJ
diff --git a/LIBTOOLS/tools/diachro/src/mesonh_MOD/mode_time.f90 b/LIBTOOLS/tools/diachro/src/mesonh_MOD/mode_time.f90
new file mode 100644
index 0000000000000000000000000000000000000000..4d016650c7de7581e3f2839f9b14e898880fe121
--- /dev/null
+++ b/LIBTOOLS/tools/diachro/src/mesonh_MOD/mode_time.f90
@@ -0,0 +1,161 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for SCCS information
+!--------------- C. Fischer 30/09/94
+! @(#) Lib:/opt/local/MESONH/sources/mode/s.mode_time.f90, Version:1.9, Date:98/10/01, Last modified:98/06/04
+!-----------------------------------------------------------------
+! ####################
+ MODULE MODE_TIME
+! ####################
+!
+!!**** *MODE_TIME* - module for time routines
+!!
+!! PURPOSE
+!! -------
+! The purpose of this executive module is to package
+! the routines SM_PRINT_TIME
+!
+!
+!
+!!
+!!** IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_TIME : contains definition of types for time variables
+!! and time variable for all model
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/07/94
+!--------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+USE MODD_TIME
+!
+IMPLICIT NONE
+!-------------------------------------------------------------------------------
+!
+CONTAINS
+!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!
+!* 1. ROUTINE SM_PRINT_TIME
+! ---------------------
+!-------------------------------------------------------------------------------
+! #################################################
+ SUBROUTINE SM_PRINT_TIME(TPDATETIME,HLUOUT,HTITLE)
+! ################################################
+!
+!!**** *SM_PRINT_TIME * - routine to print a variable of type DATE_TIME
+!!
+!! PURPOSE
+!! -------
+! The purpose of this routine is to print a variable of type DATE_TIME
+!
+!
+!!** METHOD
+!! ------
+!! The logical unit number of output-listing file is retrieved (by FMLOOK)
+!! If a logical unit number have never been attributed to this output-listing
+!! file, a logical unit number is attributed (by FMATTR) and this file is
+!! opened
+!! Then the date and time are printed with or without a title.
+!! If it is an idealized case, no date is printed (only time).
+!!
+!! EXTERNAL
+!! --------
+!! FMLOOK : to retrieve a logical unit number for a file
+!! FMATTR : to associate a logical unit number to a file name
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!! Module MODD_TYPE_TIME : contains definition of types for time variables
+!!
+!! REFERENCE
+!! ---------
+!!
+!!
+!! AUTHOR
+!! ------
+!! V. Ducrocq * Meteo France *
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 07/07/94
+!! updated V. Ducrocq 23/08/94
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+! -------------------------
+!
+TYPE (DATE_TIME), INTENT(IN) :: TPDATETIME ! Date and time variable
+CHARACTER (LEN=*), INTENT(IN) :: HLUOUT ! Name of output listing
+CHARACTER (LEN=*), INTENT(IN), OPTIONAL :: HTITLE ! Title for Date and time
+ ! variable
+!
+!* 0.2 Declarations of local variables
+! -------------------------------
+!
+INTEGER :: IHOUR,IMINUTE
+REAL :: ZSECOND,ZREMAIN
+REAL :: ZTEMP
+INTEGER :: ILUOUT,IRESP
+!-------------------------------------------------------------------------------
+!
+!* 1. CONVERT TIME IN HOURS,MINUTES AND SECONDS :
+! ------------------------------------------
+!
+IHOUR = INT(TPDATETIME%TIME/3600.)
+ZTEMP=TPDATETIME%TIME
+ZREMAIN = MOD(ZTEMP,3600.)
+IMINUTE = INT(ZREMAIN/60.)
+ZSECOND = MOD(ZREMAIN,60.)
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. PRINT ON OUTPUT-LISTING
+! -----------------------
+!
+CALL FMLOOK(HLUOUT,HLUOUT,ILUOUT,IRESP)
+IF (IRESP /= 0) THEN
+ CALL FMATTR(HLUOUT,HLUOUT,ILUOUT,IRESP)
+ OPEN(UNIT=ILUOUT,FILE=HLUOUT)
+END IF
+IF (PRESENT(HTITLE)) THEN
+ IF ((TPDATETIME%TDATE%YEAR < 0).OR.(TPDATETIME%TDATE%MONTH < 0).OR. &
+ (TPDATETIME%TDATE%DAY < 0) ) THEN
+ WRITE(UNIT=ILUOUT,FMT='(1X,A," :",2X,I2.2,"H",I2.2,"M", &
+ & F5.2,"S")') HTITLE, IHOUR,IMINUTE,ZSECOND
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT='(1X,A," :",I4.4,I2.2,I2.2,2X,I2.2,"H",I2.2,"M", &
+ & F5.2,"S")') HTITLE, TPDATETIME%TDATE, IHOUR,IMINUTE,ZSECOND
+ END IF
+ELSE
+ IF ((TPDATETIME%TDATE%YEAR < 0).OR.(TPDATETIME%TDATE%MONTH < 0).OR. &
+ (TPDATETIME%TDATE%DAY < 0) ) THEN
+ WRITE(UNIT=ILUOUT,FMT='(1X,2X,I2.2,"H",I2.2,"M", &
+ & F5.2,"S")') IHOUR,IMINUTE,ZSECOND
+ ELSE
+ WRITE(UNIT=ILUOUT,FMT='(1X,I4.4,I2.2,I2.2,2X,I2.2,"H",I2.2,"M", &
+ & F5.2,"S")') TPDATETIME%TDATE, IHOUR,IMINUTE,ZSECOND
+ END IF
+END IF
+!-------------------------------------------------------------------------------
+!
+END SUBROUTINE SM_PRINT_TIME
+!-------------------------------------------------------------------------------
+!
+END MODULE MODE_TIME
diff --git a/LIBTOOLS/tools/fmmore/Makefile b/LIBTOOLS/tools/fmmore/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..e2448c45490bb31f851fa445ce30f8546d207e9a
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/Makefile
@@ -0,0 +1,45 @@
+B = 64
+DIR_OBJ=./$(ARCH)_$(B)
+
+ifeq ($(origin MNH_LIBTOOLS), undefined)
+include ../where.Libs
+else
+include $(MNH_LIBTOOLS)/tools/where.Libs
+endif
+
+VPATH=src:$(DIR_DIA)/$(DIR_OBJ)
+
+#INC = -I $(DIR_OBJ)
+INC = -I $(DIR_OBJ) -I $(DIR_DIA)/$(DIR_OBJ)
+
+PROG = fmmore
+
+OBJS = readuntouch.o
+
+include $(DIR_CONF)/config.$(ARCH)
+include Rules.$(ARCH)
+
+%.o:%.f90 $(DIR_OBJ)/.dummy
+ $(CPP) $(INC) $(CPPFLAGS) $< > $(DIR_OBJ)/cpp_$(*F).f90
+ $(F90) $(INC) -c $(F90FLAGS) $(DIR_OBJ)/cpp_$(*F).f90 -o $(DIR_OBJ)/$(*F).o
+
+$(PROG): $(PROG).o $(OBJS) $(LIBDIA) $(LIBLFI) $(LIBCOMP)
+ cd $(DIR_OBJ); $(F90) $(LDFLAGS) -o $@ $^ $(LIBS)
+ @echo executable $(PROG) available under $(DIR_OBJ)
+
+$(DIR_OBJ)/.dummy :
+ mkdir $(DIR_OBJ)
+ @touch $(DIR_OBJ)/.dummy
+
+$(LIBLFI):
+ $(MAKE) -C $(DIR_LFI)
+
+$(LIBCOMP):
+ $(MAKE) -C $(DIR_COMP)
+
+clean:
+ (if [ -d $(DIR_OBJ) ] ; then cd $(DIR_OBJ); rm -f cpp_*.f90 *.o ; fi)
+
+distclean:
+ (if [ -d $(DIR_OBJ) ] ; then rm -rf $(DIR_OBJ) ;fi)
+
diff --git a/LIBTOOLS/tools/fmmore/Rules.AIX b/LIBTOOLS/tools/fmmore/Rules.AIX
new file mode 100644
index 0000000000000000000000000000000000000000..73534c13e51072627e43fa4fbfc3eb08a4582577
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/Rules.AIX
@@ -0,0 +1,2 @@
+
+LIBS += -L$(MESONH)/binaries -lbidon
diff --git a/LIBTOOLS/tools/fmmore/Rules.HPf90 b/LIBTOOLS/tools/fmmore/Rules.HPf90
new file mode 100644
index 0000000000000000000000000000000000000000..3d999f06a213453d2748afac8de08ae4596da0c5
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/Rules.HPf90
@@ -0,0 +1,10 @@
+
+CPPFLAGS += -DHP -DF90HP
+F77FLAGS += -O2 +Oinfo +Olimit
+F90FLAGS += -O2 +Oinfo +Olimit
+ifeq ($(B),64)
+F90FLAGS += +r8
+endif
+LDFLAGS +=
+OBJS2=
+
diff --git a/LIBTOOLS/tools/fmmore/Rules.LXNAGf95 b/LIBTOOLS/tools/fmmore/Rules.LXNAGf95
new file mode 100644
index 0000000000000000000000000000000000000000..b1ed23e610d6aafa61f9bc21f87e89c12eb741b2
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/Rules.LXNAGf95
@@ -0,0 +1,13 @@
+LIBEXT = -L/usr/X11R6/lib -lX11 -lg2c
+
+#############################################################################
+
+CPPFLAGS += -DLINUX -DNAGf95
+F77FLAGS +=
+F90FLAGS +=
+# F90FLAGS += -target=pentium
+ifeq ($(B),64)
+F90FLAGS += -r8
+endif
+LDFLAGS += -Wl,-Xlinker,-noinhibit-exec -Wl,-Xlinker,-warn-once
+OBJS2=
diff --git a/LIBTOOLS/tools/fmmore/Rules.LXg95 b/LIBTOOLS/tools/fmmore/Rules.LXg95
new file mode 100644
index 0000000000000000000000000000000000000000..7e05572f7cdb864a24397ea81e8e7eaf990bda03
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/Rules.LXg95
@@ -0,0 +1,13 @@
+LIBEXT = -L/usr/X11R6/lib -lX11 -lg2c
+
+#############################################################################
+
+CPPFLAGS += -DLINUX -DG95
+F77FLAGS +=
+F90FLAGS +=
+# F90FLAGS += -target=pentium
+ifeq ($(B),64)
+F90FLAGS += -r8
+endif
+LDFLAGS += -Wl,-noinhibit-exec -Wl,-warn-once
+OBJS2=
diff --git a/LIBTOOLS/tools/fmmore/Rules.LXgfortran b/LIBTOOLS/tools/fmmore/Rules.LXgfortran
new file mode 100644
index 0000000000000000000000000000000000000000..f2ac41d4e4824b1e2eb943b3d29fc2aabf1783ce
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/Rules.LXgfortran
@@ -0,0 +1,11 @@
+
+#############################################################################
+
+CPPFLAGS += -DLINUX
+F77FLAGS +=
+F90FLAGS +=
+ifeq ($(B),64)
+F90FLAGS += -fdefault-real-8
+endif
+LDFLAGS +=
+OBJS2=
diff --git a/LIBTOOLS/tools/fmmore/Rules.LXpgf90 b/LIBTOOLS/tools/fmmore/Rules.LXpgf90
new file mode 100644
index 0000000000000000000000000000000000000000..e420f1ef36ed2629c81aab400984ce2467e25613
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/Rules.LXpgf90
@@ -0,0 +1,12 @@
+LIBEXT =
+
+#############################################################################
+
+CPPFLAGS += -DLINUX
+F77FLAGS +=
+F90FLAGS +=
+ifeq ($(B),64)
+F90FLAGS += -r8
+endif
+LDFLAGS +=
+OBJS2=
diff --git a/LIBTOOLS/tools/fmmore/Rules.SGI32 b/LIBTOOLS/tools/fmmore/Rules.SGI32
new file mode 100644
index 0000000000000000000000000000000000000000..fa18bba6a87eb9e48e84d18abd5f6dcf40d78049
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/Rules.SGI32
@@ -0,0 +1,4 @@
+CPPFLAGS +=
+F77FLAGS +=
+F90FLAGS += -r8
+LDFLAGS +=
diff --git a/LIBTOOLS/tools/fmmore/Rules.SGI64 b/LIBTOOLS/tools/fmmore/Rules.SGI64
new file mode 100644
index 0000000000000000000000000000000000000000..fa18bba6a87eb9e48e84d18abd5f6dcf40d78049
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/Rules.SGI64
@@ -0,0 +1,4 @@
+CPPFLAGS +=
+F77FLAGS +=
+F90FLAGS += -r8
+LDFLAGS +=
diff --git a/LIBTOOLS/tools/fmmore/Rules.SX8 b/LIBTOOLS/tools/fmmore/Rules.SX8
new file mode 100644
index 0000000000000000000000000000000000000000..28c7855aadadc313a07275f6a86bb7d1097844be
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/Rules.SX8
@@ -0,0 +1,6 @@
+ifeq ($(B),64)
+F90FLAGS += -dw -Wf, ' -A dbl4 '
+endif
+CPPFLAGS += -DNEC
+LDFLAGS +=
+
diff --git a/LIBTOOLS/tools/fmmore/Rules.VPP b/LIBTOOLS/tools/fmmore/Rules.VPP
new file mode 100644
index 0000000000000000000000000000000000000000..8653c32beef66ea579c66fad919c52e8caefc436
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/Rules.VPP
@@ -0,0 +1,6 @@
+ifeq ($(B),64)
+F90FLAGS += -Ad
+endif
+CPPFLAGS += -DFUJI
+LDFLAGS +=
+
diff --git a/LIBTOOLS/tools/fmmore/src/fmmore.f90 b/LIBTOOLS/tools/fmmore/src/fmmore.f90
new file mode 100644
index 0000000000000000000000000000000000000000..37cfc7118d854d90c572dfa3965aa9b13384a4b2
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/src/fmmore.f90
@@ -0,0 +1,153 @@
+! ############
+ PROGRAM FMMORE
+! ############
+!
+!!**** *FMMORE* - routine to list the content of a LFI file
+!!
+!! PURPOSE
+!! -------
+!
+! The purpose of FMMORE is to list the content of a LFI file
+!
+!!** METHOD
+!! ------
+!!
+!! The FM and LFI routines are used to open, list and close the LFI file
+!! This routine is embedded in a Unix shell script to mimic the "more"
+!! function.
+!!
+!! EXTERNAL
+!! --------
+!!
+!! FMOPEN, FMLOOK, LFINAF, LFILAF, FMCLOS
+!!
+!! calls: READUNTOUCH containing FMREAD
+!!
+!! REFERENCE
+!! ---------
+!!
+!! The structure and content of the Meso-NH files (C. Fischer)
+!!
+!! AUTHOR
+!! ------
+!!
+!! C. FISCHER *METEO-FRANCE*
+!!
+!! MODIFICATIONS
+!! -------------
+!!
+!! original 03/95
+!! new I/O (Mallet) 03/02
+!!
+!----------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+#ifdef NAGf95
+ USE F90_UNIX
+#endif
+!
+! en attendant une Surcouche officielle...
+!USE MODE_FM
+!
+IMPLICIT NONE
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: krep
+INTEGER :: KNPRAR, KFTYPE,KVERB,KNINAR,KNUMBR
+INTEGER :: KNALDO, KNTROU, KNARES, KNAMAX
+LOGICAL :: LDTOUT
+CHARACTER(LEN=32) :: CLUOUT,YLFINAME
+CHARACTER(LEN=28) :: CFNAME
+! reading of filename as input argument
+#ifndef NAGf95
+INTEGER :: IARGC
+! CRAY specific
+INTEGER :: arglen
+!!!!!!!!!!!!!!!!!
+#endif
+INTEGER :: inarg,iresp
+CHARACTER(LEN=50) :: yexe
+!
+!* 1. INITIALIZATION
+! --------------
+!
+KFTYPE=2 ! pas de transfert dans fmclos
+KVERB=0
+!
+CLUOUT='output_listing'
+!
+knaldo=0 ; kntrou=0 ; knares=0 ; knamax=0
+LDTOUT=.TRUE.
+!
+!* 2. READING FILENAME
+! ----------------
+!READ(5,FMT='(A28)') CFNAME
+INARG = IARGC()
+
+#if defined(F90HP)
+#define HPINCR 1
+#else
+#define HPINCR 0
+#endif
+
+#if defined(FUJI) || defined(NAGf95) || defined(NEC) || defined(HP) || defined(pgf) || defined(G95) || defined(GFORTRAN)
+CALL GETARG(0+HPINCR,yexe)
+IF (LEN_TRIM(yexe) == 0) THEN
+ PRINT *, 'FATAL ERROR : Recompiler avec la macro -DF90HP'
+ STOP
+END IF
+#else
+CALL PXFGETARG(0,yexe,arglen,iresp)
+#endif
+! PRINT *,yexe, ' avec ',INARG,' arguments.'
+IF (INARG == 1) THEN
+#if defined(FUJI) || defined(NAGf95) || defined(NEC) || defined(HP) || defined(pgf) || defined(G95) || defined(GFORTRAN)
+ CALL GETARG(1+HPINCR,CFNAME)
+#else
+ CALL PXFGETARG(1,CFNAME,arglen,iresp)
+#endif
+ELSE
+ PRINT *,'Usage : ', TRIM(yexe), ' [fichier fm]'
+ STOP
+END IF
+!
+!* 3. OPENING FILE
+! ------------
+
+! en attendant une Surcouche officielle...
+!CALL FMOPEN_ll(CFNAME,'READ',CLUOUT,KNPRAR,KFTYPE,KVERB,&
+CALL FMOPEN(CFNAME,'OLD',CLUOUT,KNPRAR,KFTYPE,KVERB,&
+ KNINAR,krep)
+IF (krep.NE.0) GOTO 1000
+!
+!* 4.
+!
+YLFINAME=ADJUSTL(ADJUSTR(CFNAME)//'.lfi')
+! en attendant une Surcouche officielle...
+!CALL FMLOOK_ll(YLFINAME,CLUOUT,knumbr,krep)
+CALL FMLOOK(YLFINAME,CLUOUT,knumbr,krep)
+IF (krep.NE.0) GOTO 1000
+CALL LFINAF(krep,knumbr,knaldo,kntrou,knares,knamax)
+IF (krep.NE.0) GOTO 1000
+!WRITE(6,*) knaldo,kntrou,knares,knamax
+IF (krep.NE.0) GOTO 1000
+CALL LFILAF(krep,knumbr,LDTOUT)
+!
+CALL READUNTOUCH(CFNAME,CLUOUT)
+!
+! en attendant une Surcouche officielle...
+!CALL FMCLOS_ll(CFNAME,'KEEP',CLUOUT,krep)
+CALL FMCLOS(CFNAME,'KEEP',CLUOUT,krep)
+IF (krep.NE.0) THEN
+ GOTO 1000
+ELSE
+ GOTO 1010
+ENDIF
+!
+1000 WRITE (0,*) ' exit in FMMORE with :',krep
+1010 CONTINUE
+!
+END PROGRAM
diff --git a/LIBTOOLS/tools/fmmore/src/readuntouch.f90 b/LIBTOOLS/tools/fmmore/src/readuntouch.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8e256504dc79391102038ebb146077c45e0fe32a
--- /dev/null
+++ b/LIBTOOLS/tools/fmmore/src/readuntouch.f90
@@ -0,0 +1,439 @@
+! ######################################
+ SUBROUTINE READUNTOUCH(HFMFILE,HLUOUT)
+! ######################################
+!
+!! add LTHINSHELL, XXHAT, XYHAT, XZHAT, CMY_NAME,
+!! CDAD_NAME and CSTORAGE_TYPE (V. Masson) 31/01/97
+!! update FMREAD calls, add MASDEV (I. Mallet) 19/04/02
+!!---------------------------------------------------------------------------
+!
+!
+!USE MODD_TYPE_DATE
+! en attendant une surcouche officielle...
+!USE MODE_FMREAD
+USE MODI_FMREAD
+USE MODE_GRIDPROJ
+!
+!IMPLICIT NONE
+!
+!* 0.1 Declarations of arguments
+!
+CHARACTER(LEN=*),INTENT(IN) :: HFMFILE,HLUOUT
+!
+!* 0.2 Declarations of local variables
+!
+INTEGER :: IGRID,ILENCH,IRESP,NIMAX,NJMAX,NKMAX,IXOR,IYOR,JPHEXT
+INTEGER :: ILENG ! en attendant une surcouche officielle...
+INTEGER :: NMASDEV,NBUGFIX,NVERSION_SURFEX,NBUGFIX_SURFEX
+CHARACTER(LEN=100) :: YCOMMENT
+CHARACTER(LEN=16) :: YRECFM
+CHARACTER(LEN=10) :: CBIBUSER
+CHARACTER(LEN=6) :: CPROGRAM
+CHARACTER(LEN=4) :: CSURF
+CHARACTER(LEN=40) :: CPHOTO
+CHARACTER(LEN=28) :: CDAD_NAME, CMY_NAME
+CHARACTER(LEN=2) :: CSTORAGE_TYPE
+LOGICAL :: LCARTESIAN, LTHINSHELL, L1D, L2D, LPACK, LSLEVE, LECOCLIMAP
+REAL :: XLON0,XRPK,XLAT0,XBETA,XLATORI,XLONORI,XLEN1,XLEN2
+REAL, DIMENSION(:), ALLOCATABLE :: XXHAT,XYHAT,XZHAT
+INTEGER :: JLOOP
+!
+INTEGER, DIMENSION(3) :: ITDATE ! date array
+REAL :: ZTDATE ! seconds
+! evite le USE MODD_TYPE_DATE
+!TYPE (DATE_TIME) :: TDTEXP ! Time and Date of Experiment beginning
+!TYPE (DATE_TIME) :: TDTSEG ! Time and Date of the segment beginning
+!TYPE (DATE_TIME) :: TDTMOD ! Time and Date of the model beginning
+!TYPE (DATE_TIME) :: TDTCUR ! Current Time and Date in the model
+!
+!---------------------------------------------------------------------------
+!
+!* 1.0 Header
+!
+WRITE(6,*) '################################################################'
+WRITE(6,*) '################ COMMENTS ##########################'
+WRITE(6,*) '################################################################'
+WRITE(6,*) '################################################################'
+!
+
+YRECFM='MASDEV'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',NMASDEV,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,NMASDEV,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### MASDEV = ',NMASDEV
+ WRITE(6,*) '####'
+END IF
+!
+YRECFM='BUGFIX'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',NBUGFIX,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,NBUGFIX,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### BUGFIX = ',NBUGFIX
+ WRITE(6,*) '####'
+END IF
+!
+YRECFM='BIBUSER'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',CBIBUSER,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,CBIBUSER,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### BIBUSER = ',CBIBUSER
+ WRITE(6,*) '####'
+END IF
+!
+YRECFM='PROGRAM'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',CPROGRAM,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,CPROGRAM,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### PROGRAM = ',CPROGRAM
+ WRITE(6,*) '####'
+END IF
+!
+YRECFM='STORAGE_TYPE'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',CSTORAGE_TYPE,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,CSTORAGE_TYPE,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### STORAGE_TYPE = ',CSTORAGE_TYPE
+ WRITE(6,*) '####'
+END IF
+!
+IF (NMASDEV>=52) THEN
+ YRECFM='JPHEXT'
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,JPHEXT,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### JPHEXT = ',JPHEXT
+ WRITE(6,*) '####'
+ END IF
+ELSE
+ JPHEXT=1
+ WRITE(6,*) '#### JPHEXT = ',JPHEXT
+ WRITE(6,*) '####'
+END IF
+!
+YRECFM='SURF'
+IF (NMASDEV>=46) THEN
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,CSURF,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### SURF = ',CSURF
+ WRITE(6,*) '####'
+ END IF
+
+ IF (CSURF=="EXTE") THEN
+ YRECFM='VERSION'
+ ! en attendant une surcouche officielle...
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,NVERSION_SURFEX,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### SURFEX VERSION = ',NVERSION_SURFEX
+ WRITE(6,*) '####'
+ END IF
+
+ YRECFM='BUG'
+ ! en attendant une surcouche officielle...
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,NBUGFIX_SURFEX,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### SURFEX BUGFIX = ',NBUGFIX_SURFEX
+ WRITE(6,*) '####'
+ END IF
+ CALL FMREAD(HFMFILE,'DIM_FULL',HLUOUT,ILENG,IXOR,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### DIM_FULL = ',IXOR
+ END IF
+! CALL FMREAD(HFMFILE,'DIM_NATURE',HLUOUT,ILENG,IXOR,IGRID,ILENCH,YCOMMENT,IRESP)
+! IF (IRESP.EQ.0) THEN
+! WRITE(6,*) '#### DIM_NATURE = ',IXOR
+! END IF
+! CALL FMREAD(HFMFILE,'DIM_SEA',HLUOUT,ILENG,IXOR,IGRID,ILENCH,YCOMMENT,IRESP)
+! IF (IRESP.EQ.0) THEN
+! WRITE(6,*) '#### DIM_SEA = ',IXOR
+! END IF
+! CALL FMREAD(HFMFILE,'DIM_TOWN',HLUOUT,ILENG,IXOR,IGRID,ILENCH,YCOMMENT,IRESP)
+! IF (IRESP.EQ.0) THEN
+! WRITE(6,*) '#### DIM_TOWN = ',IXOR
+! END IF
+! CALL FMREAD(HFMFILE,'DIM_WATER',HLUOUT,ILENG,IXOR,IGRID,ILENCH,YCOMMENT,IRESP)
+! IF (IRESP.EQ.0) THEN
+! WRITE(6,*) '#### DIM_WATER = ',IXOR
+! WRITE(6,*) '####'
+! END IF
+! CALL FMREAD(HFMFILE,'ECOCLIMAP',HLUOUT,ILENG,LECOCLIMAP,IGRID,ILENCH,YCOMMENT,IRESP)
+! IF (IRESP.EQ.0) THEN
+! WRITE(6,*) '#### ECOCLIMAP = ',LECOCLIMAP
+! WRITE(6,*) '####'
+! END IF
+ END IF
+END IF
+!
+IF (NMASDEV>=46) THEN
+ YRECFM='L1D'
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,L1D,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='L2D'
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,L2D,IGRID,ILENCH,YCOMMENT,IRESP)
+ !
+ YRECFM='PACK'
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,LPACK,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### L1D = ',L1D,' L2D = ',L2D,' PACK = ',LPACK
+ WRITE(6,*) '####'
+ END IF
+END IF
+!
+YRECFM='MY_NAME'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',CMY_NAME,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,CMY_NAME,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### MY_NAME = ',CMY_NAME
+ WRITE(6,*) '####'
+END IF
+!
+YRECFM='DAD_NAME'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',CDAD_NAME,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,CDAD_NAME,IGRID,ILENCH,YCOMMENT,IRESP)
+IF (IRESP.EQ.0) THEN
+ WRITE(6,*) '#### DAD_NAME= ',CDAD_NAME
+ WRITE(6,*) '####'
+END IF
+!
+!* 1.1 Dimensions :
+!
+YRECFM='IMAX'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',NIMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,NIMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='JMAX'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',NJMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,NJMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+YRECFM='KMAX'
+IF (CSTORAGE_TYPE /='PG' .AND. CSTORAGE_TYPE/='SU') &
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',NKMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,NKMAX,IGRID,ILENCH,YCOMMENT,IRESP)
+!
+IF (CSTORAGE_TYPE /='PG' .AND. CSTORAGE_TYPE/='SU') THEN
+ WRITE(6,*) '#### NIMAX = ',NIMAX,' NJMAX = ',NJMAX,' NKMAX = ',NKMAX
+ WRITE(6,*) '####'
+ELSE
+ WRITE(6,*) '#### NIMAX = ',NIMAX,' NJMAX = ',NJMAX
+ WRITE(6,*) '####'
+END IF
+!
+! gridnesting case
+IF (LEN_TRIM(CDAD_NAME)>0) THEN
+! en attendant une surcouche officielle...
+! CALL FMREAD(HFMFILE,'DXRATIO',HLUOUT,'--',IXOR,IGRID,ILENCH,YCOMMENT,IRESP)
+ CALL FMREAD(HFMFILE,'DXRATIO',HLUOUT,ILENG,IXOR,IGRID,ILENCH,YCOMMENT,IRESP)
+ WRITE(6,*) '#### DXRATIO= ',IXOR
+! en attendant une surcouche officielle...
+! CALL FMREAD(HFMFILE,'DYRATIO',HLUOUT,'--',IYOR,IGRID,ILENCH,YCOMMENT,IRESP)
+ CALL FMREAD(HFMFILE,'DYRATIO',HLUOUT,ILENG,IYOR,IGRID,ILENCH,YCOMMENT,IRESP)
+ WRITE(6,*) '#### DYRATIO= ',IYOR
+ WRITE(6,*) '####'
+! en attendant une surcouche officielle...
+! CALL FMREAD(HFMFILE,'XOR',HLUOUT,'--',IXOR,IGRID,ILENCH,YCOMMENT,IRESP)
+ CALL FMREAD(HFMFILE,'XOR',HLUOUT,ILENG,IXOR,IGRID,ILENCH,YCOMMENT,IRESP)
+ WRITE(6,*) '#### XOR= ',IXOR
+! en attendant une surcouche officielle...
+! CALL FMREAD(HFMFILE,'YOR',HLUOUT,'--',IYOR,IGRID,ILENCH,YCOMMENT,IRESP)
+ CALL FMREAD(HFMFILE,'YOR',HLUOUT,ILENG,IYOR,IGRID,ILENCH,YCOMMENT,IRESP)
+ WRITE(6,*) '#### YOR= ',IYOR
+ WRITE(6,*) '####'
+END IF
+!
+!* 1.2 Configuration variables :
+!
+YRECFM='CARTESIAN'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',LCARTESIAN,IGRID,ILENCH,YCOMMENT,IRESP)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,LCARTESIAN,IGRID,ILENCH,YCOMMENT,IRESP)
+WRITE(6,*) '#### LCARTESIAN = ',LCARTESIAN
+!
+YRECFM='THINSHELL'
+IF (CSTORAGE_TYPE /='PG' .AND. CSTORAGE_TYPE/='SU') THEN
+! en attendant une surcouche officielle...
+! CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',LTHINSHELL,IGRID,ILENCH,YCOMMENT,IRESP)
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,LTHINSHELL,IGRID,ILENCH,YCOMMENT,IRESP)
+ WRITE(6,*) '#### LTHINSHELL = ',LTHINSHELL
+END IF
+!
+!* 1.3 Grid variables :
+!
+YRECFM='BETA'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',XBETA,IGRID,ILENCH,YCOMMENT,IRESP)
+ILENG=1
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,XBETA,IGRID,ILENCH,YCOMMENT,IRESP)
+WRITE(6,*) '#### XBETA = ',XBETA
+!
+YRECFM='LAT0'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',XLAT0,IGRID,ILENCH,YCOMMENT,IRESP)
+ILENG=1
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,XLAT0,IGRID,ILENCH,YCOMMENT,IRESP)
+WRITE(6,*) '#### XLAT0 = ',XLAT0
+!
+YRECFM='LON0'
+! en attendant une surcouche officielle...
+! CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',XLON0,IGRID,ILENCH,YCOMMENT,IRESP)
+ILENG=1
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,XLON0,IGRID,ILENCH,YCOMMENT,IRESP)
+WRITE(6,*) '#### XLON0 = ',XLON0
+!
+IF (.NOT.LCARTESIAN) THEN
+ YRECFM='RPK'
+! en attendant une surcouche officielle...
+! CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',XRPK,IGRID,ILENCH,YCOMMENT,IRESP)
+ ILENG=1
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,XRPK,IGRID,ILENCH,YCOMMENT,IRESP)
+ WRITE(6,*) '#### XRPK = ',XRPK
+!
+ YRECFM='LONORI'
+ XLONORI=999.
+! en attendant une surcouche officielle...
+! CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',XLONOR,IGRID,ILENCH,YCOMMENT,IRESP)
+ ILENG=1
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,XLONORI,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF (IRESP==0) WRITE(6,*) '#### XLONORI = ',XLONORI
+
+!
+ YRECFM='LATORI'
+ XLATORI=999.
+! en attendant une surcouche officielle...
+! CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',XLATOR,IGRID,ILENCH,YCOMMENT,IRESP)
+ ILENG=1
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,XLATORI,IGRID,ILENCH,YCOMMENT,IRESP)
+ IF (IRESP==0) WRITE(6,*) '#### XLATORI = ',XLATORI
+!
+ WRITE(6,*) '####'
+!
+END IF
+!
+YRECFM='XHAT'
+ALLOCATE(XXHAT(NIMAX+2*JPHEXT))
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',XXHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+ILENG=SIZE(XXHAT)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,XXHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+WRITE(6,*) '#### X mesh = ',XXHAT(2)-XXHAT(1)
+WRITE(6,*) '#### XHAT(1:2) = ',XXHAT(1),XXHAT(2)
+!
+YRECFM='YHAT'
+ALLOCATE(XYHAT(NJMAX+2*JPHEXT))
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',XYHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+ILENG=SIZE(XYHAT)
+CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,XYHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+WRITE(6,*) '#### Y mesh = ',XYHAT(2)-XYHAT(1)
+WRITE(6,*) '#### YHAT(1:2) = ',XYHAT(1),XYHAT(2)
+!
+IF (.NOT.LCARTESIAN) THEN
+ IF (XLONORI == 999. .AND. XRPK/=0.) THEN
+ ILENG=1
+! CALL FMREAD(HFMFILE,'LATOR',HLUOUT,'--',XLATORI,IGRID,ILENCH,YCOMMENT,IRESP)
+ CALL FMREAD(HFMFILE,'LATOR',HLUOUT,ILENG,XLATORI,IGRID,ILENCH,YCOMMENT,IRESP)
+! CALL FMREAD(HFMFILE,'LONOR',HLUOUT,'--',XLONORI,IGRID,ILENCH,YCOMMENT,IRESP)
+ CALL FMREAD(HFMFILE,'LONOR',HLUOUT,ILENG,XLONORI,IGRID,ILENCH,YCOMMENT,IRESP)
+ ZXHATM = - 0.5 * (XXHAT(1)+XXHAT(2))
+ ZYHATM = - 0.5 * (XYHAT(1)+XYHAT(2))
+ ZPI= 2.*ASIN(1.) ; ZRADIUS= 6371229.
+ CALL SM_LATLON(XLATORI,XLONORI,ZXHATM,ZYHATM,ZLATOR,ZLONOR)
+ XLATORI = ZLATOR
+ XLONORI = ZLONOR
+ END IF
+END IF
+
+
+
+IF (CSTORAGE_TYPE /='PG' .AND. CSTORAGE_TYPE/='SU') THEN
+ YRECFM='ZHAT'
+ ALLOCATE(XZHAT(NKMAX+2))
+! en attendant une surcouche officielle...
+! CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',XZHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+ ILENG=SIZE(XZHAT)
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,XZHAT,IGRID,ILENCH,YCOMMENT,IRESP)
+ DO JLOOP=1,NKMAX+2
+ WRITE(6,'(A13,I3,A4,F12.5)') ' #### XZHAT(',JLOOP,') = ',XZHAT(JLOOP)
+ END DO
+ WRITE(6,*) '####'
+ !
+ IF (NMASDEV<=46) THEN
+ LSLEVE = .FALSE.
+ ELSE
+ YRECFM='SLEVE'
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,LSLEVE,IGRID,ILENCH,YCOMMENT,IRESP)
+ WRITE(6,*) '#### LSLEVE = ',LSLEVE
+ END IF
+ !
+ IF (LSLEVE) THEN
+ YRECFM='LEN1'
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,XLEN1,IGRID,ILENCH,YCOMMENT,IRESP)
+ WRITE(6,*) '#### XLEN1 = ',XLEN1
+ !
+ YRECFM='LEN2'
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,XLEN2,IGRID,ILENCH,YCOMMENT,IRESP)
+ WRITE(6,*) '#### XLEN2 = ',XLEN2
+ WRITE(6,*) '####'
+ END IF
+END IF
+!
+
+IF (CSTORAGE_TYPE /='PG' .AND. CSTORAGE_TYPE/='SU') THEN
+!
+ !YRECFM='DTEXP'
+ YRECFM='DTEXP%TDATE'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',TDTEXP,IGRID,ILENCH,YCOMMENT,IRESP)
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+ YRECFM='DTEXP%TIME'
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,ZTDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+ !WRITE(6,*) '#### DTEXP = ',TDTEXP%TDATE%YEAR,TDTEXP%TDATE%MONTH, &
+ ! TDTEXP%TDATE%DAY, TDTEXP%TIME
+ WRITE(6,*) '#### DTEXP = ',ITDATE(1),ITDATE(2),ITDATE(3),ZTDATE
+!
+ !YRECFM='DTMOD'
+ YRECFM='DTMOD%TDATE'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',TDTMOD,IGRID,ILENCH,YCOMMENT,IRESP)
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+ YRECFM='DTMOD%TIME'
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,ZTDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+ !WRITE(6,*) '#### DTMOD = ',TDTMOD%TDATE%YEAR,TDTMOD%TDATE%MONTH, &
+ ! TDTMOD%TDATE%DAY, TDTMOD%TIME
+ WRITE(6,*) '#### DTMOD = ',ITDATE(1),ITDATE(2),ITDATE(3),ZTDATE
+!
+ !YRECFM='DTSEG'
+ YRECFM='DTSEG%TDATE'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',TDTSEG,IGRID,ILENCH,YCOMMENT,IRESP)
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+ YRECFM='DTSEG%TIME'
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,ZTDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+ !WRITE(6,*) '#### DTSEG = ',TDTSEG%TDATE%YEAR,TDTSEG%TDATE%MONTH, &
+ ! TDTSEG%TDATE%DAY, TDTSEG%TIME
+ WRITE(6,*) '#### DTSEG = ',ITDATE(1),ITDATE(2),ITDATE(3),ZTDATE
+END IF
+!
+!
+IF (CSTORAGE_TYPE /='PG') THEN
+ !YRECFM='DTCUR'
+ YRECFM='DTCUR%TDATE'
+! en attendant une surcouche officielle...
+!CALL FMREAD(HFMFILE,YRECFM,HLUOUT,'--',TDTCUR,IGRID,ILENCH,YCOMMENT,IRESP)
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,ITDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+ YRECFM='DTCUR%TIME'
+ CALL FMREAD(HFMFILE,YRECFM,HLUOUT,ILENG,ZTDATE,IGRID,ILENCH,YCOMMENT,IRESP)
+ !WRITE(6,*) '#### DTCUR = ',TDTCUR%TDATE%YEAR,TDTCUR%TDATE%MONTH, &
+ ! TDTCUR%TDATE%DAY, TDTCUR%TIME
+ WRITE(6,*) '#### DTCUR = ',ITDATE(1),ITDATE(2),ITDATE(3),ZTDATE
+END IF
+!
+!---------------------------------------------------------------------------
+END SUBROUTINE READUNTOUCH
diff --git a/LIBTOOLS/tools/foldown/fold.c b/LIBTOOLS/tools/foldown/fold.c
new file mode 100644
index 0000000000000000000000000000000000000000..815642a87df77f4e3703c9f6a1ca761999b8041d
--- /dev/null
+++ b/LIBTOOLS/tools/foldown/fold.c
@@ -0,0 +1,70 @@
+/*
+ * foldonw
+ * -------
+ *
+ */
+
+#include <stdio.h>
+
+#define MAX_LINE_LENGTH 60
+
+void foldonw ( FILE *fp, int csp, char *ssp, int pos )
+{
+ int c;
+ int l = 0;
+ int split = 0;
+
+ while ( (c=getc(fp)) != EOF )
+ {
+ if ( c == '\n' )
+ l = split = 0;
+ else
+ {
+ l++;
+ if ( l > pos )
+ split = 1;
+ if ( split && c == csp )
+ split = 2;
+ }
+ putchar(c);
+ if ( split == 2 )
+ {
+ printf("\n%s", ssp);
+ l = split = 0;
+ }
+ }
+
+ return;
+}
+
+int main ( int argc, char **argv )
+{
+ int iarg = 0;
+ char *sf = NULL;
+ char *ssp = "";
+ FILE *fp = stdin;
+ int csp = ',';
+ int pos = MAX_LINE_LENGTH;
+
+ while ( ++iarg < argc && *(argv[iarg]++) == '-' )
+ switch ( *argv[iarg] )
+ {
+ case 'f' : sf = argv[++iarg]; break;
+ case 'p' : pos = atoi(argv[++iarg]); break;
+ case 'c' : csp = *argv[++iarg]; break;
+ case 's' : ssp = argv[++iarg]; break;
+ default :
+ fprintf(stderr, "Usage: foldonw [-f filename] [-p pos] [-c char] [-s begin-string]\n");
+ exit(1);
+ }
+
+ if ( sf != NULL && (fp=fopen(sf,"r")) == NULL )
+ {
+ fprintf(stderr, "%s: no such file or directory\n", sf);
+ exit(1);
+ }
+
+ foldonw(fp, csp, ssp, pos);
+
+ return 0;
+}
diff --git a/LIBTOOLS/tools/lfi2cdf/Makefile b/LIBTOOLS/tools/lfi2cdf/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..1fd60ec33f38fe6c86793b580e4ab790efbaf629
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/Makefile
@@ -0,0 +1,86 @@
+VPATH = src:$(DIR_OBJ)
+#######################################
+DIR_OBJ = ./$(ARCH)
+
+ifeq ($(origin SRC_MESONH), undefined)
+SRC_MESONH := $(shell pwd|sed -e 's/\/tools\/.*//')
+endif
+
+ifeq ($(origin DIR_LIB), undefined)
+DIR_LIB := $(SRC_MESONH)/lib
+endif
+
+DIR_LFI = $(DIR_LIB)/NEWLFI
+LIBLFI = $(DIR_LFI)/$(ARCH)/libNEWLFI_ALL.a
+
+DIR_COMP = $(DIR_LIB)/COMPRESS
+LIBCOMP = $(DIR_COMP)/$(ARCH)/liblficomp.a
+
+
+OBJS = mode_options.o lfi2cdf.o modd_ncparam.o mode_dimlist.o fieldtype.o mode_util.o
+PROGS = lfi2cdf
+
+INC = -I$(DIR_OBJ) -DLFI_INT=$(LFI_INT)
+
+DIR_CONF:=$(SRC_MESONH)/conf
+
+include $(DIR_CONF)/config.$(ARCH)
+include Rules.$(ARCH)
+
+%.o:%.f90 $(DIR_OBJ)/.dummy
+ $(CPP) $(INC) $(CPPFLAGS) $< > $(DIR_OBJ)/cpp_$(*F).f90
+ $(F90) $(INC) -c $(F90FLAGS) $(DIR_OBJ)/cpp_$(*F).f90 -o $(DIR_OBJ)/$(*F).o
+ -@mv *.mod $(DIR_OBJ)/. 2> /dev/null || echo pas de module dans $*.f90
+
+%.o:%.c $(DIR_OBJ)/.dummy
+ $(CC) $(INC) $(CFLAGS) $(CPPFLAGS) -c $< -o $(DIR_OBJ)/$(*F).o
+
+all : $(PROGS) cdf2cdf cdf2lfi
+
+cdf2cdf: $(PROGS)
+ cd $(DIR_OBJ); rm -f cdf2cdf; ln -s $(PROGS) cdf2cdf
+
+cdf2lfi: $(PROGS)
+ cd $(DIR_OBJ); rm -f cdf2lfi; ln -s $(PROGS) cdf2lfi
+
+$(PROGS): $(OBJS) $(LIBLFI) $(LIBCOMP)
+ cd $(DIR_OBJ); $(F90) $(LDFLAGS) -o $@ $(OBJS) $(LIBLFI) $(LIBCOMP) $(LIBCDF)
+
+#$(OBJS): $(LIBCDF)
+$(OBJS):
+
+$(DIR_OBJ)/.dummy :
+ mkdir -p $(DIR_OBJ)
+ @touch $(DIR_OBJ)/.dummy
+
+$(LIBLFI): $(DIR_LFI)
+ $(MAKE) -C $(DIR_LFI)
+
+$(LIBCOMP): $(DIR_COMP)
+ $(MAKE) -C $(DIR_COMP)
+
+$(DIR_LFI):
+ @echo "ERROR : NEWLFI directory can't be found"
+ @echo " from root directory DIR_LIB = $(DIR_LIB)";echo
+ @echo "please check SRC_MESONH or DIR_LIB (= \$$SRC_MESONH/lib) env. variable"
+ @echo "and try again...";exit 1
+
+$(LIBCDF):
+ @echo "************* NETCDF library not found ***************";\
+ echo "Please, give NETCDFHOME variable in Rules.$(ARCH) the right path !";\
+ echo "******************************************************************";\
+ exit 1
+
+clean:
+ (if [ -d $(DIR_OBJ) ] ; then cd $(DIR_OBJ); rm -f cpp_*.f90 cpp_*.f *.o *.mod ; fi)
+
+distclean:
+ rm -rf $(DIR_OBJ)
+
+
+lfi2cdf.o: lfi2cdf.f90 mode_util.o
+modd_ncparam.o: modd_ncparam.f90
+mode_dimlist.o: mode_dimlist.f90
+mode_util.o: mode_util.f90 modd_ncparam.o fieldtype.o mode_dimlist.o
+fieldtype.o: fieldtype.f90 modd_ncparam.o
+
diff --git a/LIBTOOLS/tools/lfi2cdf/Rules.HPNAGf95 b/LIBTOOLS/tools/lfi2cdf/Rules.HPNAGf95
new file mode 100644
index 0000000000000000000000000000000000000000..68211e25c21da0593b01ccd2e380a3722e164bb9
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/Rules.HPNAGf95
@@ -0,0 +1,9 @@
+NETCDFHOME=/free
+DIR_CDF = $(NETCDFHOME)/lib
+LIBCDF = $(DIR_CDF)/libnetcdf.a
+###################################
+CPPFLAGS += -DNAGf95 -DLOWMEM
+INC += -I$(NETCDFHOME)/include
+F90FLAGS += -r8 -g
+LDFLAGS += -f77 -w
+
diff --git a/LIBTOOLS/tools/lfi2cdf/Rules.HPf90 b/LIBTOOLS/tools/lfi2cdf/Rules.HPf90
new file mode 100644
index 0000000000000000000000000000000000000000..db140c60b7b25fb6ca9a62bd0355b1e546ae7f8f
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/Rules.HPf90
@@ -0,0 +1,9 @@
+NETCDFHOME=/free
+DIR_CDF = $(NETCDFHOME)/lib
+LIBCDF = $(DIR_CDF)/libnetcdf.a
+###################################
+CPPFLAGS += -DHP -DLOWMEM -DF90HP
+INC += -I$(NETCDFHOME)/include
+F90FLAGS += -g
+
+
diff --git a/LIBTOOLS/tools/lfi2cdf/Rules.LXNAGf95 b/LIBTOOLS/tools/lfi2cdf/Rules.LXNAGf95
new file mode 100644
index 0000000000000000000000000000000000000000..52ba6f8921a8c13f5280c99f33d804d552e0cda8
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/Rules.LXNAGf95
@@ -0,0 +1,11 @@
+# version de Didier recompilée pour LinuX avec un seul _
+NETCDFHOME=/mesonh/MAKE/lib/netcdf-3.5.0.LX
+DIR_CDF = $(NETCDFHOME)/lib
+LIBCDF = $(DIR_CDF)/libnetcdf.a
+
+###################################
+
+CPPFLAGS += -DNAGf95 -DLOWMEM
+INC += -I$(NETCDFHOME)/include
+F90FLAGS += -r8 -O2
+LDFLAGS +=
diff --git a/LIBTOOLS/tools/lfi2cdf/Rules.LXg95 b/LIBTOOLS/tools/lfi2cdf/Rules.LXg95
new file mode 100644
index 0000000000000000000000000000000000000000..5d6bc61740ff0c14e28fa6c8c5cb2cde8a251ecf
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/Rules.LXg95
@@ -0,0 +1,19 @@
+# version de Didier recompilée pour LinuX avec un seul _
+#NETCDFHOME=/mesonh/MAKE/lib/netcdf-3.5.0.LX
+#NETCDFHOME=/usr/local/netcdf-3.5.0
+#
+
+#NETCDFHOME=/opt/netcdf-g95
+#DIR_CDF = $(NETCDFHOME)/lib
+#LIBCDF = $(DIR_CDF)/libnetcdf.a
+NETCDFHOME = /usr
+DIR_CDF = $(NETCDFHOME)/lib64
+LIBCDF = $(DIR_CDF)/libnetcdff.a $(DIR_CDF)/libnetcdf.a
+
+###################################
+
+CPPFLAGS += -DG95 -DLOWMEM
+INC += -I$(NETCDFHOME)/include
+#F90FLAGS += -fsecond-underscore -r8 -O2
+F90FLAGS += -r8 -O2
+LDFLAGS +=
diff --git a/LIBTOOLS/tools/lfi2cdf/Rules.LXgfortran b/LIBTOOLS/tools/lfi2cdf/Rules.LXgfortran
new file mode 100644
index 0000000000000000000000000000000000000000..09bb4e4f91a8280ef3f337e729e0cce7b59cd656
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/Rules.LXgfortran
@@ -0,0 +1,31 @@
+# version de Didier recompilée pour LinuX avec un seul _
+#NETCDFHOME=/mesonh/MAKE/lib/netcdf-3.5.0.LX
+#NETCDFHOME=/usr/local/netcdf-3.5.0
+#
+
+NETCDFHOME = /usr
+DIR_CDF = $(NETCDFHOME)/lib64
+LIBCDF = $(DIR_CDF)/libnetcdff.so $(DIR_CDF)/libnetcdf.so
+
+NETCDFHOME = /usr/local/netcdf4-tools
+DIR_CDF = $(NETCDFHOME)/lib64
+LIBCDF = -L$(DIR_CDF) -lnetcdff
+
+NETCDFHOME = /workdir/MESONH/MNH-V5-1-3/src/LIB/netcdf-4.1.3-LXgfortranI4
+DIR_CDF = $(NETCDFHOME)/lib64
+LIBCDF = -L$(DIR_CDF) -lnetcdff -lnetcdf -lhdf5_hl -lhdf5
+
+NETCDFCHOME = /home/waup/installations/libraries/netcdf-c/4.3.3.1_ser
+NETCDFFHOME = /home/waup/installations/libraries/netcdf-fortran/4.4.2_ser
+DIR_CDFC = $(NETCDFCHOME)/lib64
+DIR_CDFF = $(NETCDFFHOME)/lib64
+DIR_HDF5 = /home/waup/installations/libraries/HDF5/1.8.15p1_ser/lib64
+LIBCDF = -L$(DIR_CDFC) -L$(DIR_CDFF) -L$(DIR_HDF5) -lnetcdff -lnetcdf -lhdf5_hl -lhdf5
+
+###################################
+
+#PW: to test!!!! CPPFLAGS += -DLOWMEM
+INC += -I$(NETCDFFHOME)/include
+F90FLAGS += -fdefault-real-8 -O2
+LDFLAGS +=
+LFI_INT=4
diff --git a/LIBTOOLS/tools/lfi2cdf/Rules.LXifort b/LIBTOOLS/tools/lfi2cdf/Rules.LXifort
new file mode 100644
index 0000000000000000000000000000000000000000..ed759677c9e30f7eadc592c2f2394394d65d864b
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/Rules.LXifort
@@ -0,0 +1,30 @@
+# version de Didier recompilée pour LinuX avec un seul _
+#NETCDFHOME=/mesonh/MAKE/lib/netcdf-3.5.0.LX
+#NETCDFHOME=/usr/local/netcdf-3.5.0
+#
+
+#NETCDFHOME = /workdir/NETCDF_LIB
+#DIR_CDF = $(NETCDFHOME)/lib
+#LIBCDF = $(DIR_CDF)/libnetcdf.a
+
+#NETCDFHOME = /usr/local/netcdf4-tools
+#DIR_CDF = $(NETCDFHOME)/lib64
+#LIBCDF = -L$(DIR_CDF) -lnetcdff
+
+#NETCDFHOME = /workdir/MESONH/MNH-V5-1-3/src/LIB/netcdf-4.1.3-LXgfortranI4
+#DIR_CDF = $(NETCDFHOME)/lib64
+#LIBCDF = -L$(DIR_CDF) -lnetcdff -lnetcdf -lhdf5_hl -lhdf5
+
+NETCDFCHOME = /home/waup/installations/libraries/netcdf-c/4.3.3.1_ser
+NETCDFFHOME = /home/waup/installations/libraries/netcdf-fortran/4.4.2_ser
+DIR_CDFC = $(NETCDFCHOME)/lib64
+DIR_CDFF = $(NETCDFFHOME)/lib64
+DIR_HDF5 = /home/waup/installations/libraries/HDF5/1.8.15p1_ser/lib64
+LIBCDF = -L$(DIR_CDFC) -L$(DIR_CDFF) -L$(DIR_HDF5) -lnetcdff -lnetcdf -lhdf5_hl -lhdf5
+
+###################################
+
+INC += -I$(NETCDFFHOME)/include
+F90FLAGS += -O2
+LDFLAGS +=
+LFI_INT=4
diff --git a/LIBTOOLS/tools/lfi2cdf/Rules.LXpgf90 b/LIBTOOLS/tools/lfi2cdf/Rules.LXpgf90
new file mode 100644
index 0000000000000000000000000000000000000000..94b5a7044bb064f8e82f6a1613ebcc0177f47a31
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/Rules.LXpgf90
@@ -0,0 +1,12 @@
+# version de Didier recompilée pour LinuX avec un seul _
+NETCDFHOME=/mesonh/MAKE/lib/netcdf-3.5.0.LX
+#NETCDFHOME=/usr
+DIR_CDF = $(NETCDFHOME)/lib
+LIBCDF = $(DIR_CDF)/libnetcdf.a
+
+###################################
+
+CPPFLAGS += -DLOWMEM
+INC += -I$(NETCDFHOME)/include
+F90FLAGS += -r8 -O2
+LDFLAGS +=
diff --git a/LIBTOOLS/tools/lfi2cdf/Rules.SGI32 b/LIBTOOLS/tools/lfi2cdf/Rules.SGI32
new file mode 100644
index 0000000000000000000000000000000000000000..5d21ba6c9db984338cdeca220caf73adb2c6a039
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/Rules.SGI32
@@ -0,0 +1,8 @@
+NETCDFHOME=/usr/local/pub
+DIR_CDF = $(NETCDFHOME)/lib32
+LIBCDF = $(DIR_CDF)/libnetcdf.a
+###################################
+CPPFLAGS += -DLOWMEM
+INC += -I$(NETCDFHOME)/include
+F90FLAGS += -r8 -O2
+LDFLAGS +=
diff --git a/LIBTOOLS/tools/lfi2cdf/Rules.SGI64 b/LIBTOOLS/tools/lfi2cdf/Rules.SGI64
new file mode 100644
index 0000000000000000000000000000000000000000..67eb74dee68333e25675cd77a5ae579be3021122
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/Rules.SGI64
@@ -0,0 +1,8 @@
+NETCDFHOME=/usr/local/pub
+DIR_CDF = $(NETCDFHOME)/lib64
+LIBCDF = $(DIR_CDF)/libnetcdf.a
+###################################
+
+CPPFLAGS += -DLOWMEM
+INC += -I$(NETCDFHOME)/include
+F90FLAGS += -r8 -O2
diff --git a/LIBTOOLS/tools/lfi2cdf/Rules.SX5 b/LIBTOOLS/tools/lfi2cdf/Rules.SX5
new file mode 100644
index 0000000000000000000000000000000000000000..1c3cfc0746dd1b05652a206d9e7dd505b5248883
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/Rules.SX5
@@ -0,0 +1,9 @@
+NETCDFHOME=/SX/usr/local
+DIR_CDF = $(NETCDFHOME)/lib
+LIBCDF = $(DIR_CDF)/libnetcdf_i4r8.a
+###################################
+CPPFLAGS += -DFUJI # -DLOWMEM
+INC += -I$(NETCDFHOME)/include/netcdf
+F90FLAGS +=
+LDFLAGS +=
+
diff --git a/LIBTOOLS/tools/lfi2cdf/Rules.VPP b/LIBTOOLS/tools/lfi2cdf/Rules.VPP
new file mode 100644
index 0000000000000000000000000000000000000000..9fe1f8666cf409f18e495569a0e3eedaf73a84be
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/Rules.VPP
@@ -0,0 +1,9 @@
+NETCDFHOME=/usr/local
+DIR_CDF = $(NETCDFHOME)/lib
+LIBCDF = $(DIR_CDF)/libnetcdf.a
+###################################
+CPPFLAGS += -DFUJI # -DLOWMEM
+INC += -I$(NETCDFHOME)/include
+F90FLAGS +=
+LDFLAGS += -X9 -Wg,-c
+
diff --git a/LIBTOOLS/tools/lfi2cdf/scripts/lfi2cdfregex.sh b/LIBTOOLS/tools/lfi2cdf/scripts/lfi2cdfregex.sh
new file mode 100755
index 0000000000000000000000000000000000000000..75a1e988162c51f43b4b2cd1ca4cba5fa003c61a
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/scripts/lfi2cdfregex.sh
@@ -0,0 +1,31 @@
+#!/bin/sh
+#
+#
+usage(){
+ cat >&2 <<EOF
+Usage :
+
+ ${0##*/} '~/pattern/' infile.lfi : select articles that match regex 'pattern'.
+ ${0##*/} '!~/pattern/' infile.lfi : select articles that doesn't match regex 'pattern'.
+
+Example :
+ - Select all COVER articles :
+ ${0##*/} '~/^COVER/' infile.lfi
+
+EOF
+ exit 1
+}
+
+[ -z "$2" ] && usage
+
+REGEXP=$1
+INFILE=$2
+
+
+VARLIST=$(lfi2cdf -l $INFILE | awk -F\" '$2 && gsub("[[:space:]]+","",$2)+1 && $2 '$REGEXP' {printf("%s,",$2)}')
+[ -n "$VARLIST" ] && VARLIST="-v$VARLIST"
+CMD="lfi2cdf $VARLIST $INFILE"
+echo $CMD
+#$CMD
+
+
diff --git a/LIBTOOLS/tools/lfi2cdf/src/fieldtype.f90 b/LIBTOOLS/tools/lfi2cdf/src/fieldtype.f90
new file mode 100644
index 0000000000000000000000000000000000000000..62a1b73a8b1cf119f9bf5335d12f8221658de10f
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/src/fieldtype.f90
@@ -0,0 +1,368 @@
+MODULE MODE_FIELDTYPE
+ USE MODD_PARAM
+
+ IMPLICIT NONE
+
+ PRIVATE
+
+
+ TYPE field
+ CHARACTER(LEN=FM_FIELD_SIZE) :: name ! Le nom de l'article LFI
+ INTEGER :: TYPE ! Type :entier(INT) ou reel(FLOAT)
+ INTEGER :: dim ! Dimension de l'article
+ END TYPE field
+
+ TYPE(field), DIMENSION(:), ALLOCATABLE :: userfield
+
+ ! Les champs contenant %TDATE et %TIME sont traites en dur
+ ! dans la routine de recherche de type
+ TYPE(field), DIMENSION(2), PARAMETER :: datefield = (/&
+ field('%TDA', INT, D0), &
+ field('%TIM', FLOAT, D0) &
+ /)
+
+ TYPE(field), DIMENSION(219), SAVE :: sysfield
+
+ PUBLIC :: get_ftype, init_sysfield
+
+CONTAINS
+SUBROUTINE init_sysfield()
+sysfield(1) = field('LBXSVMxxx', FLOAT , D0)
+sysfield(2) = field('LBYSVMxxx', FLOAT , D0)
+sysfield(3) = field('LBXUM', FLOAT, D0)
+sysfield(4) = field('LBYUM', FLOAT, D0)
+sysfield(5) = field('LBXVM', FLOAT, D0)
+sysfield(6) = field('LBYVM', FLOAT, D0)
+sysfield(7) = field('LBXWM', FLOAT, D0)
+sysfield(8) = field('LBYWM', FLOAT, D0)
+sysfield(9) = field('LBXTHM', FLOAT, D0)
+sysfield(10) = field('LBYTHM', FLOAT, D0)
+sysfield(11) = field('LBXRVM', FLOAT, D0)
+sysfield(12) = field('LBYRVM', FLOAT, D0)
+sysfield(13) = field('AVG_ZS', FLOAT, D0)
+sysfield(14) = field('SIL_ZS', FLOAT, D0)
+sysfield(15) = field('AOSIP', FLOAT, D0)
+sysfield(16) = field('AOSIM', FLOAT, D0)
+sysfield(17) = field('AOSJP', FLOAT, D0)
+sysfield(18) = field('AOSJM', FLOAT, D0)
+sysfield(19) = field('HO2IP', FLOAT, D0)
+sysfield(20) = field('HO2IM', FLOAT, D0)
+sysfield(21) = field('HO2JP', FLOAT, D0)
+sysfield(22) = field('HO2JM', FLOAT, D0)
+sysfield(23) = field('RIMX',INT, D0)
+sysfield(24) = field('RIMY',INT, D0)
+sysfield(25) = field('HORELAX_UVWTH',BOOL, D0)
+sysfield(26) = field('HORELAX_R',BOOL, D0)
+sysfield(27) = field('I2D_XY', INT, D0)
+sysfield(28) = field('MENU_BUDGET',TEXT, D0)
+sysfield(29) = field('IE', INT, D0)
+sysfield(30) = field('ZR', FLOAT, D0)
+sysfield(31) = field('GOK', BOOL, D0)
+sysfield(32) = field('YTEXT', TEXT, D0)
+sysfield(33) = field('X1D', FLOAT, D0)
+sysfield(34) = field('I1D', INT, D0)
+sysfield(35) = field('DEB', INT, D0)
+sysfield(36) = field('3D1', FLOAT, D0)
+sysfield(37) = field('3D2', FLOAT, D0)
+sysfield(38) = field('3D3', FLOAT, D0)
+sysfield(39) = field('3D4', FLOAT, D0)
+sysfield(40) = field('3D5', FLOAT, D0)
+sysfield(41) = field('RHODREFZ', FLOAT, D0)
+sysfield(42) = field('RSVS', FLOAT, D0)
+sysfield(43) = field('RUS', FLOAT, D0)
+sysfield(44) = field('MY_NAME', TEXT, D0)
+sysfield(45) = field('DAD_NAME', TEXT, D0)
+sysfield(46) = field('STORAGE_TYPE', TEXT, D0)
+sysfield(47) = field('IMAX', INT, D0)
+sysfield(48) = field('JMAX', INT, D0)
+sysfield(49) = field('KMAX', INT, D0)
+sysfield(50) = field('RPK', FLOAT, D0)
+sysfield(51) = field('NEB', FLOAT , D0)
+sysfield(52) = field('LONOR', FLOAT, D0)
+sysfield(53) = field('LATOR', FLOAT, D0)
+sysfield(54) = field('THINSHELL', BOOL, D0)
+sysfield(55) = field('LAT0', FLOAT, D0)
+sysfield(56) = field('LON0', FLOAT, D0)
+sysfield(57) = field('BETA', FLOAT, D0)
+sysfield(58) = field('XHAT', FLOAT, D0)
+sysfield(59) = field('YHAT', FLOAT, D0)
+sysfield(60) = field('ZHAT', FLOAT, D0)
+sysfield(61) = field('ZS', FLOAT, D0)
+sysfield(62) = field('CARTESIAN', BOOL, D0)
+sysfield(63) = field('UM', FLOAT, D0)
+sysfield(64) = field('VM', FLOAT, D0)
+sysfield(65) = field('WM', FLOAT, D0)
+sysfield(66) = field('THM', FLOAT, D0)
+sysfield(67) = field('TKEM', FLOAT, D0)
+sysfield(68) = field('EPSM', FLOAT, D0)
+sysfield(69) = field('PABSM',FLOAT, D0)
+sysfield(70) = field('RVM', FLOAT, D0)
+sysfield(71) = field('RCM', FLOAT, D0)
+sysfield(72) = field('RRM', FLOAT, D0)
+sysfield(73) = field('RIM', FLOAT, D0)
+sysfield(74) = field('RSM', FLOAT, D0)
+sysfield(75) = field('RGM', FLOAT, D0)
+sysfield(76) = field('RHM', FLOAT, D0)
+sysfield(77) = field('SVMxxx', FLOAT, D0)
+sysfield(78) = field('LSUM', FLOAT, D0)
+sysfield(79) = field('LSVM', FLOAT, D0)
+sysfield(80) = field('LSWM',FLOAT , D0)
+sysfield(81) = field('LSTHM',FLOAT, D0)
+sysfield(82) = field('LSRVM',FLOAT, D0)
+sysfield(83) = field('LSXTKEM',FLOAT, D0)
+sysfield(84) = field('LSYTKEM',FLOAT, D0)
+sysfield(85) = field('LSXEPSM',FLOAT, D0)
+sysfield(86) = field('LSYEPSM',FLOAT, D0)
+sysfield(87) = field('LSXRCM',FLOAT , D0)
+sysfield(88) = field('LSYRCM', FLOAT, D0)
+sysfield(89) = field('LSXRRM', FLOAT, D0)
+sysfield(90) = field('LSYRRM', FLOAT, D0)
+sysfield(91) = field('LSXRIM', FLOAT, D0)
+sysfield(92) = field('LSYRIM', FLOAT, D0)
+sysfield(93) = field('LSXRSM', FLOAT, D0)
+sysfield(94) = field('LSYRSM', FLOAT, D0)
+sysfield(95) = field('LSXRGM', FLOAT, D0)
+sysfield(96) = field('LSYRGM', FLOAT, D0)
+sysfield(97) = field('LSXRHM', FLOAT, D0)
+sysfield(98) = field('LSYRHM', FLOAT, D0)
+sysfield(99) = field('LSXSVMxxx', FLOAT, D0)
+sysfield(100) = field('LSYSVMxxx', FLOAT, D0)
+sysfield(101) = field('UT',FLOAT, D0)
+sysfield(102) = field('VT',FLOAT, D0)
+sysfield(103) = field('WT',FLOAT, D0)
+sysfield(104) = field('THT',FLOAT, D0)
+sysfield(105) = field('TKET',FLOAT, D0)
+sysfield(106) = field('EPST',FLOAT, D0)
+sysfield(107) = field('PABST',FLOAT, D0)
+sysfield(108) = field('RVT',FLOAT, D0)
+sysfield(109) = field('RCT',FLOAT, D0)
+sysfield(110) = field('RRT',FLOAT, D0)
+sysfield(111) = field('RIT',FLOAT, D0)
+sysfield(112) = field('CIT',FLOAT, D0)
+sysfield(113) = field('RST',FLOAT, D0)
+sysfield(114) = field('RGT',FLOAT, D0)
+sysfield(115) = field('RHT',FLOAT, D0)
+sysfield(116) = field('SVTxxx',FLOAT, D0)
+sysfield(117) = field('DRYMASST',FLOAT, D0)
+sysfield(118) = field('SRCM',FLOAT, D0)
+sysfield(119) = field('SRCT',FLOAT, D0)
+sysfield(120) = field('SIGS',FLOAT, D0)
+sysfield(121) = field('RHOREFZ',FLOAT, D0)
+sysfield(122) = field('THVREFZ',FLOAT, D0)
+sysfield(123) = field('EXNTOP',FLOAT, D0)
+sysfield(124) = field('RESA', FLOAT , D0)
+sysfield(125) = field('Z0SEA', FLOAT , D0)
+sysfield(126) = field('TS', FLOAT , D0)
+sysfield(127) = field('WG', FLOAT , D0)
+sysfield(128) = field('SST', FLOAT , D0)
+sysfield(129) = field('T2', FLOAT , D0)
+sysfield(130) = field('W2', FLOAT , D0)
+sysfield(131) = field('WR', FLOAT , D0)
+sysfield(132) = field('WS', FLOAT , D0)
+sysfield(133) = field('ALBS', FLOAT , D0)
+sysfield(134) = field('RHOS', FLOAT , D0)
+sysfield(135) = field('LAND', FLOAT , D0)
+sysfield(136) = field('SEA', FLOAT , D0)
+sysfield(137) = field('Z0VEG', FLOAT , D0)
+sysfield(138) = field('Z0HVEG', FLOAT , D0)
+sysfield(139) = field('Z0REL', FLOAT , D0)
+sysfield(140) = field('Z0EFFIP', FLOAT , D0)
+sysfield(141) = field('Z0EFFIM', FLOAT , D0)
+sysfield(142) = field('Z0EFFJP', FLOAT , D0)
+sysfield(143) = field('Z0EFFJM', FLOAT , D0)
+sysfield(144) = field('SSO_STDEV', FLOAT , D0)
+sysfield(145) = field('SSO_ANIS', FLOAT , D0)
+sysfield(146) = field('SSO_DIRECTION', FLOAT , D0)
+sysfield(147) = field('SSO_SLOPE', FLOAT , D0)
+sysfield(148) = field('ALBVIS', FLOAT , D0)
+sysfield(149) = field('ALBNIR', FLOAT , D0)
+sysfield(150) = field('EMIS', FLOAT , D0)
+sysfield(151) = field('CLAY', FLOAT , D0)
+sysfield(152) = field('SAND', FLOAT , D0)
+sysfield(153) = field('D2', FLOAT , D0)
+sysfield(154) = field('VEG', FLOAT , D0)
+sysfield(155) = field('LAI', FLOAT , D0)
+sysfield(156) = field('RSMIN', FLOAT , D0)
+sysfield(157) = field('GAMMA', FLOAT , D0)
+sysfield(158) = field('RGL', FLOAT , D0)
+sysfield(159) = field('CV', FLOAT , D0)
+sysfield(160) = field('SFTHT', FLOAT , D0)
+sysfield(161) = field('SFTHP', FLOAT , D0)
+sysfield(162) = field('SFRT', FLOAT , D0)
+sysfield(163) = field('SFRP', FLOAT , D0)
+sysfield(164) = field('SFSVT', FLOAT , D0)
+sysfield(165) = field('SFSVP', FLOAT , D0)
+sysfield(166) = field('DTHRAD', FLOAT , D0)
+sysfield(167) = field('SRFLWD', FLOAT , D0)
+sysfield(168) = field('SRFSWD', FLOAT , D0)
+sysfield(169) = field('CLDFR', FLOAT , D0)
+sysfield(170) = field('COUNTCONV', INT , D0)
+sysfield(171) = field('DTHCONV', FLOAT , D0)
+sysfield(172) = field('DRVCONV', FLOAT , D0)
+sysfield(173) = field('DRCCONV', FLOAT , D0)
+sysfield(174) = field('DRICONV', FLOAT , D0)
+sysfield(175) = field('PRCONV', FLOAT , D0)
+sysfield(176) = field('PACCONV', FLOAT , D0)
+sysfield(177) = field('WSUBCONV', FLOAT , D0)
+sysfield(178) = field('INPRR', FLOAT , D0)
+sysfield(179) = field('ACPRR', FLOAT , D0)
+sysfield(180) = field('INPRS', FLOAT , D0)
+sysfield(181) = field('ACPRS', FLOAT , D0)
+sysfield(182) = field('INPRG', FLOAT , D0)
+sysfield(183) = field('ACPRG', FLOAT , D0)
+sysfield(184) = field('INPRT', FLOAT , D0)
+sysfield(185) = field('ACPRT', FLOAT , D0)
+sysfield(186) = field('FRC', INT, D0)
+sysfield(187) = field('UFRCxx', FLOAT , D0)
+sysfield(188) = field('VFRCxx', FLOAT , D0)
+sysfield(189) = field('WFRCxx', FLOAT , D0)
+sysfield(190) = field('THFRCxx', FLOAT , D0)
+sysfield(191) = field('RVFRCxx', FLOAT , D0)
+sysfield(192) = field('GXRVFRCxx', FLOAT , D0)
+sysfield(193) = field('GYRVFRCxx', FLOAT , D0)
+sysfield(194) = field('GXTHFRCxx', FLOAT , D0)
+sysfield(195) = field('GYTHFRCxx', FLOAT , D0)
+sysfield(196) = field('DUMMY_GRxxx', FLOAT , D0)
+sysfield(197) = field('MASDEV', INT , D0)
+sysfield(198) = field('EMISFILE_GR_NBR', INT , D0)
+sysfield(199) = field('EMISPEC_GR_NBR', INT , D0)
+sysfield(200) = field('EMISNAMExxx', TEXT , D0)
+sysfield(201) = field('EMISTIMESxxx', INT , D0)
+sysfield(202) = field('DUMMY_GR_NBR', INT , D0)
+sysfield(203) = field('COVERxxx', FLOAT , D0)
+sysfield(204) = field('TGx', FLOAT, D0)
+sysfield(205) = field('T_ROOFx', FLOAT, D0)
+sysfield(206) = field('T_ROADx', FLOAT, D0)
+sysfield(207) = field('T_WALLx', FLOAT, D0)
+sysfield(208) = field('WGx', FLOAT, D0)
+sysfield(209) = field('WGIx', FLOAT, D0)
+sysfield(210) = field('MAX_ZS', FLOAT, D0)
+sysfield(211) = field('MIN_ZS', FLOAT, D0)
+sysfield(212) = field('XOR', INT, D0)
+sysfield(213) = field('YOR', INT, D0)
+sysfield(214) = field('DXRATIO', INT, D0)
+sysfield(215) = field('DYRATIO', INT, D0)
+sysfield(216) = field('PATCH_NUMBER', INT, D0)
+sysfield(217) = field('BUGFIX', INT, D0)
+sysfield(218) = field('BIBUSER', TEXT, D0)
+sysfield(219) = field('LFI_COMPRESSED', INT, D0)
+END SUBROUTINE init_sysfield
+
+ FUNCTION get_ftype(hfname,level)
+ CHARACTER(LEN=*) :: hfname
+ INTEGER :: get_ftype
+ INTEGER,INTENT(IN) :: level
+
+ TYPE(field) :: tzf
+
+ ! Is this a diachronic field ?
+ IF (INDEX(hfname,".TY",.TRUE.) /=0 .OR.&
+ & INDEX(hfname,".TI",.TRUE.) /=0 .OR.&
+ & INDEX(hfname,".UN",.TRUE.) /=0 .OR.&
+ & INDEX(hfname,".CO",.TRUE.)/=0) THEN
+ get_ftype = TEXT
+ ELSE IF (INDEX(hfname,".DI",.TRUE.) /= 0) THEN
+ get_ftype = INT
+ ELSE IF (INDEX(hfname,".PR",.TRUE.)/= 0 .OR.&
+ & INDEX(hfname,".TR",.TRUE.)/= 0 .OR.&
+ & INDEX(hfname,".DA",.TRUE.)/= 0) THEN
+ get_ftype = FLOAT
+ ELSE IF (searchfield(hfname,tzf,level)) THEN
+ ! search in databases
+ get_ftype = tzf%TYPE
+ ELSE
+ get_ftype = -1
+ END IF
+
+ END FUNCTION get_ftype
+
+ FUNCTION searchfield(hfname, tpf, level)
+ CHARACTER(LEN=*), INTENT(IN) :: hfname
+ TYPE(field), INTENT(OUT) :: tpf
+ INTEGER,INTENT(IN) :: level
+ LOGICAL :: searchfield
+
+ INTEGER :: ji,iposx
+ LOGICAL :: found
+ CHARACTER(LEN=4) :: clevel
+
+ found = .FALSE.
+
+ ! First is this a date field ?
+ DO ji=1,SIZE(datefield)
+ IF (INDEX(hfname,TRIM(datefield(ji)%name)) /= 0) THEN
+ found = .TRUE.
+ tpf = datefield(ji)
+ EXIT
+ END IF
+ END DO
+
+ IF (.NOT. found) THEN
+ ! Next, search in user field tab
+ IF (ALLOCATED(userfield)) THEN
+ DO ji=1,SIZE(userfield)
+ IF (hfname==userfield(ji)%name) THEN
+ found = .TRUE.
+ tpf = userfield(ji)
+ EXIT
+ END IF
+ END DO
+ END IF
+
+ IF (.NOT. found) THEN
+ ! then search in system field tab
+ DO ji=1,SIZE(sysfield)
+ IF (hfname==sysfield(ji)%name) THEN
+ found = .TRUE.
+ tpf = sysfield(ji)
+ EXIT
+ ELSE
+ iposx = INDEX(sysfield(ji)%name,'x')
+ IF (iposx /= 0) THEN
+ IF (isnumeric(hfname(iposx:LEN_TRIM(sysfield(ji)%name))) .AND. &
+ sysfield(ji)%name(1:iposx-1)//&
+ hfname(iposx:LEN_TRIM(sysfield(ji)%name))==hfname) THEN
+ found = .TRUE.
+ tpf = sysfield(ji)
+ EXIT
+ END IF
+ ELSE IF (level>-1) THEN
+ !Maybe it is a z-level splitted field
+ !Warning: false positives are possible (but should be rare)
+ write(clevel,'(I4.4)') level
+ iposx = INDEX(hfname,clevel)
+ IF (iposx /= 0) THEN
+ IF (hfname(:iposx-1)==sysfield(ji)%name) THEN
+ found = .TRUE.
+ tpf = sysfield(ji)
+ EXIT
+ END IF
+ END IF
+ END IF
+ END IF
+ END DO
+ END IF
+ END IF
+
+ searchfield = found
+
+ END FUNCTION searchfield
+
+ FUNCTION isnumeric(hname)
+ CHARACTER(LEN=*) :: hname
+ LOGICAL :: isnumeric
+
+ INTEGER :: ji
+
+ isnumeric = .TRUE.
+
+ DO ji = 1,LEN(hname)
+ IF (hname(ji:ji) > '9' .OR. hname(ji:ji) < '0') THEN
+ isnumeric = .FALSE.
+ EXIT
+ END IF
+ END DO
+
+ END FUNCTION isnumeric
+
+END MODULE MODE_FIELDTYPE
diff --git a/LIBTOOLS/tools/lfi2cdf/src/lfi2cdf.f90 b/LIBTOOLS/tools/lfi2cdf/src/lfi2cdf.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a66cc2cf4f36caec4e25ca9cdcfaefd32a5693c1
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/src/lfi2cdf.f90
@@ -0,0 +1,134 @@
+program LFI2CDF
+ USE mode_options
+ USE mode_util
+ IMPLICIT NONE
+
+ INTEGER :: ibuflen
+ INTEGER :: ji
+ INTEGER :: nbvar_infile ! number of variables available in the input file
+ INTEGER :: nbvar_tbr ! number of variables to be read
+ INTEGER :: nbvar_calc ! number of variables to be computed from others
+ INTEGER :: nbvar_tbw ! number of variables to be written
+ INTEGER :: nbvar ! number of defined variables
+ INTEGER :: first_level, current_level, last_level, nb_levels
+ CHARACTER(LEN=:),allocatable :: hvarlist
+ TYPE(filelist_struct) :: infiles, outfiles
+ TYPE(workfield), DIMENSION(:), POINTER :: tzreclist
+
+ type(option),dimension(:),allocatable :: options
+ character(len=:),allocatable :: hinfile, houtfile
+ integer :: runmode
+
+
+ call read_commandline(options,hinfile,houtfile,runmode)
+
+ CALL OPEN_FILES(infiles, outfiles, hinfile, houtfile, nbvar_infile, options, runmode)
+ IF (options(OPTLIST)%set) return
+
+ IF (runmode == MODELFI2CDF .OR. runmode == MODECDF2CDF) THEN
+ IF (options(OPTVAR)%set) THEN
+ ! nbvar_tbr is computed from number of requested variables
+ ! by counting commas, = and +
+ nbvar_tbr = 0
+ nbvar_calc = 0
+ nbvar_tbw = 0
+ hvarlist = options(OPTVAR)%cvalue
+ DO ji=1,len(hvarlist)
+ IF (hvarlist(ji:ji) == ',' .OR.hvarlist(ji:ji) == '+') THEN
+ nbvar_tbr = nbvar_tbr+1
+ END IF
+ IF (hvarlist(ji:ji) == ',') THEN
+ nbvar_tbw = nbvar_tbw+1
+ END IF
+ IF (hvarlist(ji:ji) == '=') THEN
+ nbvar_calc = nbvar_calc+1
+ END IF
+ END DO
+ nbvar = nbvar_calc + nbvar_tbr
+ ELSE
+ nbvar = nbvar_infile
+ END IF
+ END IF
+
+ IF (runmode == MODELFI2CDF) THEN
+ ! Conversion LFI -> NetCDF
+
+ !Standard treatment (one LFI file only)
+ IF (.not.options(OPTMERGE)%set) THEN
+ CALL parse_infiles(infiles,nbvar_infile,nbvar_tbr,nbvar_calc,nbvar_tbw,tzreclist,ibuflen,options)
+ IF (options(OPTSPLIT)%set) call open_split_ncfiles_out(outfiles,houtfile,nbvar,tzreclist,options)
+ CALL def_ncdf(outfiles,tzreclist,nbvar,options)
+ CALL fill_ncdf(infiles,outfiles,tzreclist,nbvar,ibuflen,options)
+
+ ELSE
+ !Treat several LFI files and merge into 1 NC file
+
+ !Determine first level (eg needed to find suffix of the variable name)
+ read( hinfile(len(hinfile)-6:len(hinfile)-4) , "(I3)" ) first_level
+ nb_levels = options(OPTMERGE)%ivalue
+ current_level = first_level
+ last_level = first_level + nb_levels - 1
+
+ !Read 1st LFI file
+ CALL parse_infiles(infiles,nbvar_infile,nbvar_tbr,nbvar_calc,nbvar_tbw,tzreclist,ibuflen,options,current_level)
+ IF (options(OPTSPLIT)%set) call open_split_ncfiles_out(outfiles,houtfile,nbvar,tzreclist,options)
+ !Define NC variables
+ CALL def_ncdf(outfiles,tzreclist,nbvar,options)
+
+ DO current_level = first_level,last_level
+ print *,'Treating level ',current_level
+ IF (current_level/=first_level) THEN
+ CALL open_split_lfifile_in(infiles,hinfile,current_level)
+ CALL read_data_lfi(infiles,nbvar,tzreclist,ibuflen,current_level)
+ END IF
+ CALL fill_ncdf(infiles,outfiles,tzreclist,nbvar,ibuflen,options,current_level)
+ IF (current_level/=last_level) CALL close_files(infiles)
+ END DO
+ END IF
+
+ ELSE IF (runmode == MODECDF2CDF) THEN
+ ! Conversion netCDF -> netCDF
+
+ !Standard treatment (one netCDF file only)
+ IF (.not.options(OPTMERGE)%set) THEN
+ CALL parse_infiles(infiles,nbvar_infile,nbvar_tbr,nbvar_calc,nbvar_tbw,tzreclist,ibuflen,options,current_level)
+ IF (options(OPTSPLIT)%set) call open_split_ncfiles_out(outfiles,houtfile,nbvar,tzreclist,options)
+ CALL def_ncdf(outfiles,tzreclist,nbvar,options)
+ CALL fill_ncdf(infiles,outfiles,tzreclist,nbvar,ibuflen,options)
+
+ ELSE
+ !Treat several NC files and merge into 1 NC file
+
+ !Determine first level (eg needed to find suffix of the variable name)
+ read( hinfile(len(hinfile)-5:len(hinfile)-3) , "(I3)" ) first_level
+ nb_levels = options(OPTMERGE)%ivalue
+ current_level = first_level
+ last_level = first_level + nb_levels - 1
+
+ !Read 1st NC file
+ CALL parse_infiles(infiles,nbvar_infile,nbvar_tbr,nbvar_calc,nbvar_tbw,tzreclist,ibuflen,options,current_level)
+ IF (options(OPTSPLIT)%set) call open_split_ncfiles_out(outfiles,houtfile,nbvar,tzreclist,options)
+ !Define NC variables
+ CALL def_ncdf(outfiles,tzreclist,nbvar,options)
+
+ DO current_level = first_level,last_level
+ print *,'Treating level ',current_level
+ IF (current_level/=first_level) THEN
+ CALL open_split_ncfile_in(infiles,hinfile,current_level)
+ CALL update_varid_in(infiles,hinfile,tzreclist,nbvar,current_level)
+ END IF
+ CALL fill_ncdf(infiles,outfiles,tzreclist,nbvar,ibuflen,options,current_level)
+ IF (current_level/=last_level) CALL close_files(infiles)
+ END DO
+ END IF
+
+ ELSE
+ ! Conversion NetCDF -> LFI
+ CALL parse_infiles(infiles,nbvar_infile,nbvar_tbr,nbvar_calc,nbvar_tbw,tzreclist,ibuflen,options,current_level)
+ CALL build_lfi(infiles,outfiles,tzreclist,ibuflen)
+ END IF
+
+ CALL CLOSE_FILES(infiles)
+ CALL CLOSE_FILES(outfiles)
+
+end program LFI2CDF
diff --git a/LIBTOOLS/tools/lfi2cdf/src/modd_ncparam.f90 b/LIBTOOLS/tools/lfi2cdf/src/modd_ncparam.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b357682f2eaa651cd5d7ce6f0d2883d4cc97afbe
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/src/modd_ncparam.f90
@@ -0,0 +1,19 @@
+MODULE MODD_PARAM
+ IMPLICIT NONE
+
+ CHARACTER(LEN=*), PARAMETER :: VERSION_ID='lfi2cdf Ver. Alpha'
+ INTEGER, PARAMETER :: INT = 1
+ INTEGER, PARAMETER :: FLOAT = 2
+ INTEGER, PARAMETER :: TEXT = 3
+ INTEGER, PARAMETER :: BOOL = 4
+
+ INTEGER, PARAMETER :: D0 = 100
+ INTEGER, PARAMETER :: D1 = 200
+ INTEGER, PARAMETER :: D2 = 300
+ INTEGER, PARAMETER :: D3 = 400
+
+ INTEGER, PARAMETER :: NOTFOUND = -1
+
+ INTEGER, PARAMETER :: FM_FIELD_SIZE = 32
+
+END MODULE MODD_PARAM
diff --git a/LIBTOOLS/tools/lfi2cdf/src/mode_dimlist.f90 b/LIBTOOLS/tools/lfi2cdf/src/mode_dimlist.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d4977136dfa01e0ac786a97a9d9704c61a7f032d
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/src/mode_dimlist.f90
@@ -0,0 +1,118 @@
+MODULE mode_dimlist
+ IMPLICIT NONE
+
+ TYPE dimCDF
+ CHARACTER(LEN=8) :: name
+ INTEGER :: len
+ INTEGER :: id
+ LOGICAL :: create
+ INTEGER :: ndims ! number of dim reference (when create=.FALSE.)
+ TYPE(dimCDF), POINTER :: next
+ END TYPE dimCDF
+
+ TYPE(dimCDF), POINTER, PRIVATE, SAVE :: dimlist
+ INTEGER, PRIVATE, SAVE :: nbelt = 0
+ INTEGER, SAVE :: IDIMX = 0
+ INTEGER, SAVE :: IDIMY = 0
+ INTEGER, SAVE :: IDIMZ = 0
+ LOGICAL, SAVE :: GUSEDIM = .FALSE.
+ TYPE(dimCDF), POINTER :: ptdimx, ptdimy, ptdimz
+
+CONTAINS
+
+ SUBROUTINE init_dimCDF()
+
+ NULLIFY(dimlist)
+ NULLIFY(ptdimx, ptdimy, ptdimz)
+ IF (GUSEDIM) THEN
+ ! reservation for DIMX,DIMY,DIMZ
+ ptdimx=>get_dimCDF(IDIMX,.TRUE.)
+ ptdimx%name = 'DIMX'
+ ptdimy=>get_dimCDF(IDIMY,.TRUE.)
+ ptdimy%name = 'DIMY'
+ ! PGD MesoNH files doesn't contain KMAX
+ IF (IDIMZ > 0) THEN
+ ptdimz=>get_dimCDF(IDIMZ,.TRUE.)
+ ptdimz%name = 'DIMZ'
+ END IF
+ END IF
+ END SUBROUTINE init_dimCDF
+
+ FUNCTION size_dimCDF()
+ INTEGER :: size_dimCDF
+
+ size_dimCDF = nbelt
+
+ END FUNCTION size_dimCDF
+
+ FUNCTION first_dimCDF()
+ TYPE(dimCDF), POINTER :: first_dimCDF
+
+ first_dimCDF=>dimlist
+
+ END FUNCTION first_dimCDF
+
+
+ FUNCTION get_dimCDF(len,ocreate)
+ INTEGER, INTENT(IN) :: len
+ LOGICAL, INTENT(IN), OPTIONAL :: ocreate ! when .TRUE. create a dim CELL
+ TYPE(dimCDF), POINTER :: get_dimCDF
+
+
+ TYPE(dimCDF), POINTER :: tmp
+ INTEGER :: count
+ CHARACTER(LEN=5) :: yndim
+ LOGICAL :: gforce
+
+ IF (PRESENT(ocreate)) THEN
+ gforce = ocreate
+ ELSE
+ gforce = .FALSE.
+ ENDIF
+ !
+ IF (len /= 1) THEN
+ IF (gforce) THEN
+ count = 0
+ NULLIFY(tmp)
+ ELSE
+ count = 1
+ tmp=>dimlist
+ DO WHILE(ASSOCIATED(tmp))
+ IF (tmp%len == len) EXIT
+ tmp=>tmp%next
+ count = count+1
+ END DO
+ END IF
+ IF (.NOT. ASSOCIATED(tmp)) THEN
+ ALLOCATE(tmp)
+ nbelt = nbelt+1
+ WRITE(yndim,'(i5)') count
+ tmp%name = 'DIM'//ADJUSTL(yndim)
+ tmp%len = len
+ tmp%id = 0
+ IF (GUSEDIM .AND. len == IDIMX*IDIMY) THEN
+ tmp%create = .FALSE.
+ tmp%ndims = 2
+ ELSEIF (GUSEDIM .AND. len == IDIMX*IDIMY*IDIMZ) THEN
+ tmp%ndims = 3
+ tmp%create = .FALSE.
+ ELSEIF (GUSEDIM .AND. IDIMY == 3 .AND. len == IDIMX*IDIMZ) THEN
+ tmp%ndims = 12 ! faux mais reconnu dans def_ncdf
+ tmp%create = .FALSE.
+ ELSE
+ tmp%ndims = 0
+ tmp%create = .TRUE.
+ END IF
+ tmp%next => dimlist
+ dimlist => tmp
+ END IF
+
+ get_dimCDF=>tmp
+
+ ELSE
+
+ NULLIFY(get_dimCDF)
+ END IF
+
+ END FUNCTION get_dimCDF
+END MODULE mode_dimlist
diff --git a/LIBTOOLS/tools/lfi2cdf/src/mode_options.f90 b/LIBTOOLS/tools/lfi2cdf/src/mode_options.f90
new file mode 100644
index 0000000000000000000000000000000000000000..eeded3e0f22c36becd78b61034416114784fcd95
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/src/mode_options.f90
@@ -0,0 +1,340 @@
+module mode_options
+ implicit none
+
+ integer,parameter :: nbavailoptions = 10
+ integer,parameter :: TYPEUNDEF = -1, TYPEINT = 1, TYPELOG = 2, TYPEREAL = 3, TYPECHAR = 4
+ integer,parameter :: MODEUNDEF = -11, MODECDF2CDF = 11, MODELFI2CDF = 12, MODECDF2LFI = 13
+
+ integer,parameter :: OPTCDF3 = 1, OPTCDF4 = 2, OPTCOMPRESS = 3
+ integer,parameter :: OPTHELP = 4, OPTLIST = 5, OPTMERGE = 6
+ integer,parameter :: OPTOUTPUT = 7, OPTREDUCE = 8, OPTSPLIT = 9
+ integer,parameter :: OPTVAR = 10
+
+ type option
+ logical :: set = .false.
+ character(len=:),allocatable :: long_name
+ character :: short_name
+ logical :: has_argument
+ integer :: type = TYPEUNDEF
+ integer :: ivalue
+ logical :: lvalue
+ real :: rvalue
+ character(len=:),allocatable :: cvalue
+ end type option
+
+contains
+subroutine read_commandline(options,hinfile,houtfile,runmode)
+ implicit none
+
+ type(option),dimension(:),allocatable,intent(out) :: options
+ character(len=:),allocatable,intent(out) :: hinfile
+ character(len=:),allocatable,intent(out) :: houtfile
+ integer,intent(out) :: runmode
+
+ integer :: idx, ji, nbargs, status, sz
+ logical :: finished
+ character(len=:),allocatable :: command, fullcommand
+
+
+ call GET_COMMAND_ARGUMENT(NUMBER=0,LENGTH=sz)
+ allocate(character(len=sz)::fullcommand)
+ call GET_COMMAND_ARGUMENT(NUMBER=0,VALUE=fullcommand)
+
+ idx = index(fullcommand,'/',back=.true.)
+ allocate(character(len=sz-idx)::command)
+ command=fullcommand(idx+1:)
+
+ select case (command)
+ case ('cdf2cdf')
+ runmode = MODECDF2CDF
+ case ('cdf2lfi')
+ runmode = MODECDF2LFI
+ case ('lfi2cdf')
+ runmode = MODELFI2CDF
+ case default
+ runmode = MODEUNDEF
+ print *,'Error: program started with unknown command: ',command
+ call help()
+ end select
+ deallocate(command,fullcommand)
+
+ call init_options(options)
+
+ nbargs = COMMAND_ARGUMENT_COUNT()
+
+ if (nbargs==0) then
+ print *,'Error: no input file given'
+ call help()
+ end if
+
+ if (nbargs>1) then
+ finished = .false.
+ do while(.not.finished)
+ call get_option(options,finished)
+ end do
+ end if
+
+ call GET_COMMAND_ARGUMENT(NUMBER=nbargs,LENGTH=sz)
+ allocate(character(len=sz)::hinfile)
+ call GET_COMMAND_ARGUMENT(NUMBER=COMMAND_ARGUMENT_COUNT(),VALUE=hinfile)
+
+ call check_options(options,hinfile,runmode)
+
+ houtfile = options(OPTOUTPUT)%cvalue
+
+ !Remove level in the filename if merging LFI splitted files
+ if (.NOT.options(OPTOUTPUT)%set) then
+ if (options(OPTMERGE)%set .AND. .NOT.options(OPTSPLIT)%set) then
+ houtfile=houtfile(1:len(houtfile)-9)//houtfile(len(houtfile)-3:)
+ end if
+ if (.NOT.options(OPTMERGE)%set .AND. options(OPTSPLIT)%set) then
+ if (options(OPTCDF4)%set) then
+ ji=4
+ else
+ ji=3
+ end if
+ houtfile=houtfile(1:len(houtfile)-ji)
+ end if
+ if (options(OPTMERGE)%set .AND. options(OPTSPLIT)%set) then
+ if (options(OPTCDF4)%set) then
+ ji=9
+ else
+ ji=8
+ end if
+ houtfile=houtfile(1:len(houtfile)-ji)
+ end if
+ end if
+
+end subroutine read_commandline
+
+subroutine init_options(options)
+ implicit none
+
+ type(option),dimension(:),allocatable,intent(out) :: options
+
+ allocate(options(nbavailoptions))
+
+ options(OPTCDF3)%long_name = "cdf3"
+ options(OPTCDF3)%short_name = '3'
+ options(OPTCDF3)%has_argument = .false.
+
+ options(OPTCDF4)%long_name = "cdf4"
+ options(OPTCDF4)%short_name = '4'
+ options(OPTCDF4)%has_argument = .false.
+
+ options(OPTCOMPRESS)%long_name = "compress"
+ options(OPTCOMPRESS)%short_name = 'c'
+ options(OPTCOMPRESS)%has_argument = .true.
+ options(OPTCOMPRESS)%type = TYPEINT
+
+ options(OPTHELP)%long_name = "help"
+ options(OPTHELP)%short_name = 'h'
+ options(OPTHELP)%has_argument = .false.
+
+ options(OPTLIST)%long_name = "list"
+ options(OPTLIST)%short_name = 'l'
+ options(OPTLIST)%has_argument = .false.
+
+ options(OPTMERGE)%long_name = "merge"
+ options(OPTMERGE)%short_name = 'm'
+ options(OPTMERGE)%has_argument = .true.
+ options(OPTMERGE)%type = TYPEINT
+
+ options(OPTOUTPUT)%long_name = "output"
+ options(OPTOUTPUT)%short_name = 'o'
+ options(OPTOUTPUT)%has_argument = .true.
+ options(OPTOUTPUT)%type = TYPECHAR
+
+ options(OPTREDUCE)%long_name = "reduce-precision"
+ options(OPTREDUCE)%short_name = 'r'
+ options(OPTREDUCE)%has_argument = .false.
+
+ options(OPTSPLIT)%long_name = "split"
+ options(OPTSPLIT)%short_name = 's'
+ options(OPTSPLIT)%has_argument = .false.
+
+ options(OPTVAR)%long_name = "var"
+ options(OPTVAR)%short_name = 'v'
+ options(OPTVAR)%has_argument = .true.
+ options(OPTVAR)%type = TYPECHAR
+
+end subroutine init_options
+
+subroutine get_option(options,finished)
+ implicit none
+
+ integer,parameter :: MAXARGSIZE=512
+
+ logical,intent(out) :: finished
+ type(option),dimension(:),intent(inout) :: options
+
+ integer,save :: argnum = 1
+ integer :: i, sz
+ logical :: found
+ character(len=MAXARGSIZE) :: arg
+
+ found = .false.
+ call GET_COMMAND_ARGUMENT(NUMBER=argnum,VALUE=arg,LENGTH=sz)
+ if(sz>MAXARGSIZE) print *,'Error: argument bigger than ',MAXARGSIZE
+ if ( INDEX(arg,'--')==1 .AND. sz>2) then
+ do i=1,nbavailoptions
+ if (options(i)%long_name == trim(arg(3:))) then
+ found = .true.
+ exit
+ end if
+ end do
+ else if ( INDEX(arg,'-')==1 ) then
+ do i=1,nbavailoptions
+ if (options(i)%short_name == trim(arg(2:))) then
+ found = .true.
+ exit
+ end if
+ end do
+ else
+ print *,'Error: ',trim(arg),' is not an option'
+ call help()
+ end if
+
+ if ( .not.found ) then
+ print *,'Error: unknown option: ',trim(arg)
+ call help()
+ end if
+
+ if (options(i)%set) then
+ print *,'Error: at least 1 option is set several times!'
+ call help()
+ end if
+
+ options(i)%set = .true.
+ if (options(i)%has_argument) then
+ argnum = argnum + 1
+ if (argnum >= COMMAND_ARGUMENT_COUNT()) then
+ print *,'Error: argument for option ',trim(arg),' not found'
+ call help()
+ end if
+ call GET_COMMAND_ARGUMENT(NUMBER=argnum,VALUE=arg,LENGTH=sz)
+ if(sz>MAXARGSIZE) print *,'Error: argument bigger than ',MAXARGSIZE
+ select case (options(i)%type)
+ case (TYPEINT)
+ read (arg,*) options(i)%ivalue
+ case (TYPELOG)
+ read (arg,*) options(i)%lvalue
+ case (TYPEREAL)
+ read (arg,*) options(i)%rvalue
+ case (TYPECHAR)
+ options(i)%cvalue = arg
+ case default
+ print *,'Error: unknown option type'
+ call help()
+ end select
+ end if
+
+ argnum = argnum + 1
+
+ if (argnum >= COMMAND_ARGUMENT_COUNT()) finished = .true.
+
+end subroutine get_option
+
+subroutine check_options(options,infile,runmode)
+ implicit none
+
+ type(option),dimension(:),intent(inout) :: options
+ character(len=:),allocatable,intent(in) :: infile
+ integer,intent(in) :: runmode
+
+ integer :: idx1, idx2
+
+
+ !Check if help has been asked
+ if (options(OPTHELP)%set) then
+ call help()
+ end if
+
+ !Use NetCF-4 by default
+ if (.NOT.options(OPTCDF3)%set) then
+ options(OPTCDF4)%set = .true.
+ else
+ if (options(OPTCDF4)%set) then
+ print *,'Warning: NetCDF-3 and NetCDF-4 options are not compatible'
+ print *,'NetCDF-4 is forced'
+ options(OPTCDF3)%set = .false.
+ end if
+ end if
+
+ !Check compression level
+ if (options(OPTCOMPRESS)%set) then
+ if (options(OPTCOMPRESS)%ivalue < 1 .OR. options(OPTCOMPRESS)%ivalue > 9 ) then
+ print *,'Error: compression level should in the 1 to 9 interval'
+ call help()
+ end if
+ end if
+
+ !Check list option
+ if (options(OPTLIST)%set .AND. runmode/=MODELFI2CDF) then
+ print *,'Error: list option is only valid for lfi2cdf'
+ call help()
+ end if
+
+ !Merge flag only supported if -v is set
+ if (options(OPTMERGE)%set .AND. .NOT.options(OPTVAR)%set) then
+ print *,'Error: merge option must be used with var option'
+ call help()
+ end if
+
+ !Split flag only supported if -v is set
+ if (options(OPTSPLIT)%set .AND. .NOT.options(OPTVAR)%set) then
+ options(OPTSPLIT)%set = .false.
+ print *,"Warning: split option is forced to disable"
+ end if
+
+ !Determine outfile name if not given
+ if (.NOT.options(OPTOUTPUT)%set) then
+ idx1 = index(infile,'/',back=.true.)
+ idx2 = index(infile,'.',back=.true.)
+ options(OPTOUTPUT)%cvalue = infile(idx1+1:idx2-1)
+ end if
+
+end subroutine check_options
+
+subroutine help()
+ implicit none
+
+!TODO: -l option for cdf2cdf and cdf2lfi
+ print *,"Usage : lfi2cdf [-h --help] [--cdf4 -4] [-l] [-v --var var1[,...]] [-r --reduce-precision]"
+ print *," [-m --merge number_of_z_levels] [-s --split] [-o --output output-file.nc]"
+ print *," [-c --compress compression_level] input-file.lfi"
+ print *," cdf2cdf [-h --help] [--cdf4 -4] [-v --var var1[,...]] [-r --reduce-precision]"
+ print *," [-m --merge number_of_z_levels] [-s --split] [-o --output output-file.nc]"
+ print *," [-c --compress compression_level] input-file.nc"
+ print *," cdf2lfi [-o --output output-file.lfi] input-file.nc"
+ print *,""
+ print *,"Options:"
+ print *," --cdf3, -3"
+ print *," Write netCDF file in netCDF-3 format (cdf2cdf and lfi2cdf only)"
+ print *," --cdf4, -4 (by default)"
+ print *," Write netCDF file in netCDF-4 format (HDF5 compatible) (cdf2cdf and lfi2cdf only)"
+ print *," --compress, -c compression_level"
+ print *," Compress data. The compression level should be in the 1 to 9 interval."
+ print *," Only supported with the netCDF-4 format (cdf2cdf and lfi2cdf only)"
+ print *," --help, -h"
+ print *," Print this text"
+ print *," --list, -l"
+ print *," List all the fields of the LFI file and returns (lfi2cdf only)"
+ print *," --merge, -m number_of_z_levels"
+ print *," Merge LFI files which are split by vertical level (cdf2cdf and lfi2cdf only)"
+ print *," --output, -o"
+ print *," Name of file for the output"
+ print *," --reduce-precision, -r"
+ print *," Reduce the precision of the floating point variables to single precision (cdf2cdf and lfi2cdf only)"
+ print *," --split, -s"
+ print *," Split variables specified with the -v option (one per file) (cdf2cdf and lfi2cdf only)"
+ print *," --var, -v var1[,...]"
+ print *," List of the variable to write in the output file. Variables names have to be separated by commas (,)."
+ print *," A variable can be computed from the sum of existing variables (format: new_var=var1+var2[+...])"
+ print *," (cdf2cdf and lfi2cdf only)"
+ print *,""
+ stop
+
+end subroutine help
+
+end module mode_options
diff --git a/LIBTOOLS/tools/lfi2cdf/src/mode_util.f90 b/LIBTOOLS/tools/lfi2cdf/src/mode_util.f90
new file mode 100644
index 0000000000000000000000000000000000000000..e82a477e99c3359ce850ef44f0b6584096cd7a1d
--- /dev/null
+++ b/LIBTOOLS/tools/lfi2cdf/src/mode_util.f90
@@ -0,0 +1,1386 @@
+MODULE mode_util
+ USE MODE_FIELDTYPE
+ USE mode_dimlist
+ USE mode_options
+ USE MODD_PARAM
+ USE netcdf
+
+ IMPLICIT NONE
+
+ INTEGER,PARAMETER :: MAXRAW=10
+ INTEGER,PARAMETER :: MAXLEN=512
+ INTEGER,PARAMETER :: MAXFILES=100
+
+ INTEGER,PARAMETER :: UNDEFINED = -1, READING = 1, WRITING = 2
+ INTEGER,PARAMETER :: UNKNOWN_FORMAT = -1, NETCDF_FORMAT = 1, LFI_FORMAT = 2
+
+ TYPE filestruct
+ INTEGER :: lun_id ! Logical ID of file
+ INTEGER :: format = UNKNOWN_FORMAT ! NETCDF, LFI
+ INTEGER :: status = UNDEFINED ! Opened for reading or writing
+ INTEGER :: var_id ! Position of the variable in the workfield structure
+ LOGICAL :: opened = .false.
+ END TYPE filestruct
+
+ TYPE filelist_struct
+ INTEGER :: nbfiles = 0
+! TYPE(filestruct),DIMENSION(:),ALLOCATABLE :: files
+ TYPE(filestruct),DIMENSION(MAXFILES) :: files
+ END TYPE filelist_struct
+
+
+ TYPE workfield
+ CHARACTER(LEN=FM_FIELD_SIZE) :: name ! nom du champ
+ INTEGER :: TYPE ! type (entier ou reel)
+ CHARACTER(LEN=:), POINTER :: comment
+ TYPE(dimCDF), POINTER :: dim
+ INTEGER :: id_in = -1, id_out = -1
+ INTEGER :: grid
+ LOGICAL :: found ! T if found in the input file
+ LOGICAL :: calc ! T if computed from other variables
+ LOGICAL :: tbw ! to be written or not
+ LOGICAL :: tbr ! to be read or not
+ INTEGER,DIMENSION(MAXRAW) :: src ! List of variables used to compute the variable (needed only if calc=.true.)
+ INTEGER :: tgt ! Target: id of the variable that use it (calc variable)
+ END TYPE workfield
+
+#ifndef LOWMEM
+ TYPE lfidata
+ INTEGER(KIND=8), DIMENSION(:), POINTER :: iwtab
+ END TYPE lfidata
+ TYPE(lfidata), DIMENSION(:), ALLOCATABLE :: lfiart
+#endif
+
+ LOGICAL(KIND=LFI_INT), PARAMETER :: ltrue = .TRUE.
+ LOGICAL(KIND=LFI_INT), PARAMETER :: lfalse = .FALSE.
+
+CONTAINS
+ FUNCTION str_replace(hstr, hold, hnew)
+ CHARACTER(LEN=*) :: hstr, hold, hnew
+ CHARACTER(LEN=LEN_TRIM(hstr)+MAX(0,LEN(hnew)-LEN(hold))) :: str_replace
+
+ INTEGER :: pos
+
+ pos = INDEX(hstr,hold)
+ IF (pos /= 0) THEN
+ str_replace = hstr(1:pos-1)//hnew//hstr(pos+LEN(hold):)
+ ELSE
+ str_replace = hstr
+ END IF
+
+ END FUNCTION str_replace
+
+ SUBROUTINE FMREADLFIN1(klu,hrecfm,kval,kresp)
+ INTEGER(KIND=LFI_INT), INTENT(IN) :: klu ! logical fortran unit au lfi file
+ CHARACTER(LEN=*),INTENT(IN) :: hrecfm ! article name to be read
+ INTEGER, INTENT(OUT) :: kval ! integer value for hrecfm article
+ INTEGER(KIND=LFI_INT), INTENT(OUT):: kresp! return code null if OK
+ !
+ INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE::iwork
+ INTEGER :: icomlen
+ INTEGER(KIND=LFI_INT) :: iresp,ilenga,iposex
+ !
+ CALL LFINFO(iresp,klu,hrecfm,ilenga,iposex)
+ IF (iresp /=0 .OR. ilenga == 0) THEN
+ kresp = -1
+ kval = 0
+ ELSE
+ ALLOCATE(IWORK(ilenga))
+ CALL LFILEC(iresp,klu,hrecfm,iwork,ilenga)
+ icomlen = iwork(2)
+ kval = iwork(3+icomlen)
+ kresp = iresp
+ DEALLOCATE(IWORK)
+ END IF
+ END SUBROUTINE FMREADLFIN1
+
+ SUBROUTINE parse_infiles(infiles, nbvar_infile, nbvar_tbr, nbvar_calc, nbvar_tbw, tpreclist, kbuflen, options, icurrent_level)
+ TYPE(filelist_struct), INTENT(IN) :: infiles
+ INTEGER, INTENT(IN) :: nbvar_infile, nbvar_tbr, nbvar_calc, nbvar_tbw
+ TYPE(workfield), DIMENSION(:), POINTER :: tpreclist
+ INTEGER, INTENT(OUT) :: kbuflen
+ TYPE(option),DIMENSION(:), INTENT(IN) :: options
+ INTEGER, INTENT(IN), OPTIONAL :: icurrent_level
+
+ INTEGER :: ji,jj, kcdf_id, itype
+ INTEGER :: ndb, nde, ndey, idx, idx_var, maxvar
+ INTEGER :: idims, idimtmp, jdim, status, var_id
+ LOGICAL :: ladvan
+ INTEGER :: ich, current_level, leng
+ INTEGER :: comment_size, fsize, sizemax
+ CHARACTER(LEN=FM_FIELD_SIZE) :: yrecfm
+ CHARACTER(LEN=4) :: suffix
+#ifdef LOWMEM
+ INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE :: iwork
+#endif
+ INTEGER(KIND=LFI_INT) :: iresp,ilu,ileng,ipos
+ CHARACTER(LEN=FM_FIELD_SIZE) :: var_calc
+ CHARACTER(LEN=FM_FIELD_SIZE),dimension(MAXRAW) :: var_raw
+ INTEGER, DIMENSION(10) :: idim_id
+ INTEGER :: JPHEXT
+
+ IF (infiles%files(1)%format == LFI_FORMAT) THEN
+ ilu = infiles%files(1)%lun_id
+
+ CALL FMREADLFIN1(ilu,'JPHEXT',JPHEXT,iresp)
+ IF (iresp /= 0) JPHEXT=1
+
+ ! First check if IMAX,JMAX,KMAX exist in LFI file
+ ! to handle 3D, 2D variables -> update IDIMX,IDIMY,IDIMZ
+ CALL FMREADLFIN1(ilu,'IMAX',IDIMX,iresp)
+ IF (iresp == 0) IDIMX = IDIMX+2*JPHEXT ! IMAX + 2*JPHEXT
+ !
+ CALL FMREADLFIN1(ilu,'JMAX',IDIMY,iresp)
+ IF (iresp == 0) IDIMY = IDIMY+2*JPHEXT ! JMAX + 2*JPHEXT
+ !
+ CALL FMREADLFIN1(ilu,'KMAX',IDIMZ,iresp)
+ IF (iresp == 0) IDIMZ = IDIMZ+2 ! KMAX + 2*JPVEXT
+ ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
+ kcdf_id = infiles%files(1)%lun_id
+
+ status = NF90_INQ_DIMID(kcdf_id, "DIMX", idim_id(1))
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ status = NF90_INQUIRE_DIMENSION(kcdf_id,idim_id(1),len = IDIMX)
+
+ status = NF90_INQ_DIMID(kcdf_id, "DIMY", idim_id(2))
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ status = NF90_INQUIRE_DIMENSION(kcdf_id,idim_id(2),len = IDIMY)
+
+ status = NF90_INQ_DIMID(kcdf_id, "DIMZ", idim_id(3))
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ status = NF90_INQUIRE_DIMENSION(kcdf_id,idim_id(3),len = IDIMZ)
+ END IF
+
+ GUSEDIM = (IDIMX*IDIMY > 0)
+ IF (GUSEDIM) THEN
+ PRINT *,'MESONH 3D, 2D articles DIMENSIONS used :'
+ PRINT *,'DIMX =',IDIMX
+ PRINT *,'DIMY =',IDIMY
+ PRINT *,'DIMZ =',IDIMZ ! IDIMZ may be equal to 0 (PGD files)
+ ELSE
+ PRINT *,'BEWARE : ALL MesoNH arrays are handled as 1D arrays !'
+ END IF
+
+ sizemax = 0
+
+ IF (present(icurrent_level)) THEN
+ write(suffix,'(I4.4)') icurrent_level
+ current_level = icurrent_level
+ ElSE
+ suffix=''
+ current_level = -1
+ END IF
+
+ ! Phase 1 : build articles list to convert.
+ !
+ ! Pour l'instant tous les articles du fichier LFI sont
+ ! convertis. On peut modifier cette phase pour prendre en
+ ! compte un sous-ensemble d'article (liste definie par
+ ! l'utilisateur par exemple)
+ !
+ IF (options(OPTVAR)%set) THEN
+#ifndef LOWMEM
+ IF(.NOT.ALLOCATED(lfiart) .AND. infiles%files(1)%format == LFI_FORMAT) ALLOCATE(lfiart(nbvar_tbr+nbvar_calc))
+#endif
+ ALLOCATE(tpreclist(nbvar_tbr+nbvar_calc))
+ DO ji=1,nbvar_tbr+nbvar_calc
+ tpreclist(ji)%found = .FALSE.
+ tpreclist(ji)%calc = .FALSE. !By default variables are not computed from others
+ tpreclist(ji)%tbw = .TRUE. !By default variables are written
+ tpreclist(ji)%tbr = .TRUE. !By default variables are written
+ tpreclist(ji)%src(:) = -1
+ tpreclist(ji)%tgt = -1
+ END DO
+
+ ! A variable list is provided with -v var1,...
+ ndb = 1
+ idx_var = 1
+ DO ji=1,nbvar_tbw
+ !crash compiler GCC 4.2.0: nde = INDEX(TRIM(options(OPTVAR)%cvalue(ndb:)),',')
+ nde = INDEX(TRIM(options(OPTVAR)%cvalue(ndb:len(trim(options(OPTVAR)%cvalue)))),',')
+ yrecfm = options(OPTVAR)%cvalue(ndb:ndb+nde-2)
+
+ !Detect operations on variables (only + is supported now)
+ ndey = INDEX(TRIM(yrecfm),'=')
+ idx = 1
+ IF (ndey /= 0) THEN
+ var_calc = yrecfm(1:ndey-1)
+ DO WHILE (ndey /= 0)
+ IF (idx>MAXRAW) THEN
+ print *,'Error: MAXRAW exceeded (too many raw variables for 1 computed one)'
+ STOP
+ END IF
+ yrecfm = yrecfm(ndey+1:)
+ ndey = INDEX(TRIM(yrecfm),'+')
+ IF (ndey /= 0) THEN
+ var_raw(idx) = yrecfm(1:ndey-1)
+ ELSE
+ var_raw(idx) = TRIM(yrecfm)
+ END IF
+ idx = idx + 1
+ END DO
+
+ tpreclist(idx_var)%name = trim(var_calc)
+ tpreclist(idx_var)%calc = .TRUE.
+ tpreclist(idx_var)%tbw = .TRUE.
+ tpreclist(idx_var)%tbr = .FALSE.
+ idx_var=idx_var+1
+ DO jj = 1, idx-1
+ tpreclist(idx_var-jj)%src(jj) = idx_var
+ tpreclist(idx_var)%name = trim(var_raw(jj))
+ tpreclist(idx_var)%calc = .FALSE.
+ tpreclist(idx_var)%tbw = .FALSE.
+ tpreclist(idx_var)%tbr = .TRUE.
+ tpreclist(idx_var)%tgt = idx_var-jj
+ idx_var=idx_var+1
+ END DO
+
+ ELSE
+ tpreclist(idx_var)%name = trim(yrecfm)
+ tpreclist(idx_var)%calc = .FALSE.
+ tpreclist(idx_var)%tbw = .TRUE.
+ idx_var=idx_var+1
+
+ END IF
+
+ ndb = nde+ndb
+ END DO
+
+ DO ji=1,nbvar_tbr+nbvar_calc
+ IF (tpreclist(ji)%calc) CYCLE
+
+ yrecfm = TRIM(tpreclist(ji)%name)
+ IF (infiles%files(1)%format == LFI_FORMAT) THEN
+ CALL LFINFO(iresp,ilu,trim(yrecfm)//trim(suffix),ileng,ipos)
+ IF (iresp == 0 .AND. ileng /= 0) tpreclist(ji)%found = .true.
+ leng = ileng
+ ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
+ status = NF90_INQ_VARID(kcdf_id,trim(yrecfm)//trim(suffix),tpreclist(ji)%id_in)
+ IF (status == NF90_NOERR) THEN
+ tpreclist(ji)%found = .true.
+ status = NF90_INQUIRE_VARIABLE(kcdf_id,tpreclist(ji)%id_in,ndims = idims,dimids = idim_id)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+!TODO:useful?
+!DUPLICATED
+ IF (idims == 0) THEN
+ ! variable scalaire
+ leng = 1
+ ELSE
+ ! infos sur dimensions
+ leng = 1
+ DO jdim=1,idims
+ status = NF90_INQUIRE_DIMENSION(kcdf_id,idim_id(jdim),len = idimtmp)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ leng = leng*idimtmp
+ END DO
+ END IF
+ END IF
+ END IF
+
+ IF (.NOT.tpreclist(ji)%found) THEN
+ PRINT *,'Article ',TRIM(yrecfm), ' not found!'
+ tpreclist(ji)%tbw = .FAlSE.
+ tpreclist(ji)%tbr = .FAlSE.
+ ELSE
+ ! PRINT *,'Article ',ji,' : ',TRIM(yrecfm),', longueur = ',ileng
+ IF (leng > sizemax) sizemax = leng
+#ifndef LOWMEM
+!TODO:useful for netcdf?
+ IF (infiles%files(1)%format == LFI_FORMAT) ALLOCATE(lfiart(ji)%iwtab(leng))
+#endif
+ END IF
+ END DO
+
+ maxvar = nbvar_tbr+nbvar_calc
+
+DO ji=1,nbvar_tbr+nbvar_calc
+ print *,ji,'name=',trim(tpreclist(ji)%name),' calc=',tpreclist(ji)%calc,' tbw=',tpreclist(ji)%tbw,&
+ ' tbr=',tpreclist(ji)%tbr,' found=',tpreclist(ji)%found
+END DO
+
+ ELSE
+ ! Entire file is converted
+#ifndef LOWMEM
+ IF(.NOT.ALLOCATED(lfiart) .AND. infiles%files(1)%format == LFI_FORMAT) ALLOCATE(lfiart(nbvar_infile))
+#endif
+ ALLOCATE(tpreclist(nbvar_infile))
+ DO ji=1,nbvar_infile
+ tpreclist(ji)%calc = .FALSE. !By default variables are not computed from others
+ tpreclist(ji)%tbw = .TRUE. !By default variables are written
+ tpreclist(ji)%src(:) = -1
+ END DO
+
+ IF (infiles%files(1)%format == LFI_FORMAT) THEN
+ CALL LFIPOS(iresp,ilu)
+ ladvan = .TRUE.
+
+ DO ji=1,nbvar_infile
+ CALL LFICAS(iresp,ilu,yrecfm,ileng,ipos,ladvan)
+ ! PRINT *,'Article ',ji,' : ',TRIM(yrecfm),', longueur = ',ileng
+ tpreclist(ji)%name = trim(yrecfm)
+ tpreclist(ji)%found = .TRUE.
+ IF (ileng > sizemax) sizemax = ileng
+#ifndef LOWMEM
+ ALLOCATE(lfiart(ji)%iwtab(ileng))
+#endif
+ END DO
+ ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
+ DO ji=1,nbvar_infile
+ tpreclist(ji)%id_in = ji
+ status = NF90_INQUIRE_VARIABLE(kcdf_id,tpreclist(ji)%id_in, name = tpreclist(ji)%name, ndims = idims, &
+ dimids = idim_id)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ ! PRINT *,'Article ',ji,' : ',TRIM(tpreclist(ji)%name),', longueur = ',ileng
+ tpreclist(ji)%found = .TRUE.
+!TODO:useful?
+!DUPLICATED
+ IF (idims == 0) THEN
+ ! variable scalaire
+ leng = 1
+ ELSE
+ ! infos sur dimensions
+ leng = 1
+ DO jdim=1,idims
+ status = NF90_INQUIRE_DIMENSION(kcdf_id,idim_id(jdim),len = idimtmp)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ leng = leng*idimtmp
+ END DO
+ END IF
+ IF (leng > sizemax) sizemax = leng
+ END DO
+ END IF
+
+ maxvar = nbvar_infile
+ END IF
+
+ kbuflen = sizemax
+
+#ifdef LOWMEM
+ WRITE(*,'("Taille maximale du buffer :",f10.3," Mio")') sizemax*8./1048576.
+ ALLOCATE(iwork(sizemax))
+#endif
+
+ ! Phase 2 : Extract comments and dimensions for valid articles.
+ ! Infos are put in tpreclist.
+ CALL init_dimCDF()
+ DO ji=1,maxvar
+ IF (tpreclist(ji)%calc .OR. .NOT.tpreclist(ji)%found) CYCLE
+
+ IF (infiles%files(1)%format == LFI_FORMAT) THEN
+ yrecfm = trim(tpreclist(ji)%name)//trim(suffix)
+ CALL LFINFO(iresp,ilu,yrecfm,ileng,ipos)
+#ifdef LOWMEM
+ CALL LFILEC(iresp,ilu,yrecfm,iwork,ileng)
+ tpreclist(ji)%grid = iwork(1)
+ comment_size = iwork(2)
+#else
+ CALL LFILEC(iresp,ilu,yrecfm,lfiart(ji)%iwtab,ileng)
+ tpreclist(ji)%grid = lfiart(ji)%iwtab(1)
+ comment_size = lfiart(ji)%iwtab(2)
+#endif
+ tpreclist(ji)%TYPE = get_ftype(yrecfm,current_level)
+
+ ALLOCATE(character(len=comment_size) :: tpreclist(ji)%comment)
+ DO jj=1,comment_size
+#ifdef LOWMEM
+ ich = iwork(2+jj)
+#else
+ ich = lfiart(ji)%iwtab(2+jj)
+#endif
+ tpreclist(ji)%comment(jj:jj) = CHAR(ich)
+ END DO
+
+ fsize = ileng-(2+comment_size)
+
+ ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
+ ! GRID attribute definition
+ status = NF90_GET_ATT(kcdf_id,tpreclist(ji)%id_in,'GRID',tpreclist(ji)%grid)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ ! COMMENT attribute definition
+ status = NF90_INQUIRE_ATTRIBUTE(kcdf_id,tpreclist(ji)%id_in,'COMMENT',len=comment_size)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ ALLOCATE(character(len=comment_size) :: tpreclist(ji)%comment)
+ status = NF90_GET_ATT(kcdf_id,tpreclist(ji)%id_in,'COMMENT',tpreclist(ji)%comment)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ status = NF90_INQUIRE_VARIABLE(kcdf_id,tpreclist(ji)%id_in, xtype = itype, ndims = idims, &
+ dimids = idim_id)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ SELECT CASE(itype)
+ CASE(NF90_CHAR)
+ tpreclist(ji)%TYPE = TEXT
+ CASE(NF90_INT)
+ tpreclist(ji)%TYPE = INT
+ CASE(NF90_FLOAT,NF90_DOUBLE)
+ tpreclist(ji)%TYPE = FLOAT
+ CASE default
+ PRINT *, 'Attention : variable ',TRIM(tpreclist(ji)%name), ' a un TYPE non reconnu par le convertisseur.'
+ PRINT *, '--> TYPE force a REAL(KIND 8) dans LFI !'
+ END SELECT
+
+!DUPLICATED
+ IF (idims == 0) THEN
+ ! variable scalaire
+ leng = 1
+ ELSE
+ ! infos sur dimensions
+ leng = 1
+ DO jdim=1,idims
+ status = NF90_INQUIRE_DIMENSION(kcdf_id,idim_id(jdim),len = idimtmp)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ leng = leng*idimtmp
+ END DO
+ END IF
+
+ fsize = leng
+ END IF
+
+ tpreclist(ji)%dim=>get_dimCDF(fsize)
+ END DO
+
+ !Complete info for calculated variables
+ IF (nbvar_calc>0) THEN
+ DO ji=1,maxvar
+ IF (.NOT.tpreclist(ji)%calc) CYCLE
+ tpreclist(ji)%TYPE = tpreclist(tpreclist(ji)%src(1))%TYPE
+ tpreclist(ji)%grid = tpreclist(tpreclist(ji)%src(1))%grid
+ tpreclist(ji)%dim => tpreclist(tpreclist(ji)%src(1))%dim
+
+!TODO: cleaner length!
+ ALLOCATE(character(len=256) :: tpreclist(ji)%comment)
+ tpreclist(ji)%comment='Constructed from'
+ jj = 1
+ DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
+ tpreclist(ji)%comment = trim(tpreclist(ji)%comment)//' '//trim(tpreclist(tpreclist(ji)%src(jj))%name)
+ IF (jj<MAXRAW .AND. tpreclist(ji)%src(jj+1)>0) THEN
+ tpreclist(ji)%comment = trim(tpreclist(ji)%comment)//' +'
+ END IF
+ jj=jj+1
+ END DO
+ END DO
+ END IF
+
+
+ PRINT *,'Nombre de dimensions = ', size_dimCDF()
+#ifdef LOWMEM
+ DEALLOCATE(iwork)
+#endif
+ END SUBROUTINE parse_infiles
+
+ SUBROUTINE read_data_lfi(infiles, nbvar, tpreclist, kbuflen, current_level)
+ TYPE(filelist_struct), INTENT(IN) :: infiles
+ INTEGER, INTENT(INOUT) :: nbvar
+ TYPE(workfield), DIMENSION(:), POINTER :: tpreclist
+ INTEGER, INTENT(IN) :: kbuflen
+ INTEGER, INTENT(IN), OPTIONAL :: current_level
+
+ INTEGER :: ji,jj
+ INTEGER :: ndb, nde
+ LOGICAL :: ladvan
+ INTEGER :: ich
+ INTEGER :: fsize,sizemax
+ CHARACTER(LEN=FM_FIELD_SIZE) :: yrecfm
+ CHARACTER(LEN=4) :: suffix
+#ifdef LOWMEM
+ INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE :: iwork
+#endif
+ INTEGER(KIND=LFI_INT) :: iresp,ilu,ileng,ipos
+ CHARACTER(LEN=FM_FIELD_SIZE) :: var_calc
+ CHARACTER(LEN=FM_FIELD_SIZE),dimension(MAXRAW) :: var_raw
+
+
+ ilu = infiles%files(1)%lun_id
+
+ IF (present(current_level)) THEN
+ write(suffix,'(I4.4)') current_level
+ ElSE
+ suffix=''
+ END IF
+
+#ifdef LOWMEM
+ ALLOCATE(iwork(kbuflen))
+#endif
+
+ DO ji=1,nbvar
+ IF (.NOT.tpreclist(ji)%tbr) CYCLE
+ yrecfm = trim(tpreclist(ji)%name)//trim(suffix)
+ CALL LFINFO(iresp,ilu,yrecfm,ileng,ipos)
+#ifdef LOWMEM
+ CALL LFILEC(iresp,ilu,yrecfm,iwork,ileng)
+ tpreclist(ji)%grid = iwork(1)
+#else
+ CALL LFILEC(iresp,ilu,yrecfm,lfiart(ji)%iwtab,ileng)
+ tpreclist(ji)%grid = lfiart(ji)%iwtab(1)
+#endif
+ END DO
+
+#ifdef LOWMEM
+ DEALLOCATE(iwork)
+#endif
+ END SUBROUTINE read_data_lfi
+
+ SUBROUTINE HANDLE_ERR(status,line)
+ INTEGER :: status,line
+
+ IF (status /= NF90_NOERR) THEN
+ PRINT *, 'line ',line,': ',NF90_STRERROR(status)
+ STOP
+ END IF
+ END SUBROUTINE HANDLE_ERR
+
+ SUBROUTINE def_ncdf(outfiles,tpreclist,nbvar,options)
+ TYPE(filelist_struct), INTENT(IN) :: outfiles
+ TYPE(workfield),DIMENSION(:),INTENT(INOUT) :: tpreclist
+ INTEGER, INTENT(IN) :: nbvar
+ TYPE(option),DIMENSION(:), INTENT(IN) :: options
+
+ INTEGER :: compress_level, status
+ INTEGER :: idx, ji, nbfiles
+ INTEGER:: kcdf_id
+ TYPE(dimCDF), POINTER :: tzdim
+ INTEGER :: invdims
+ INTEGER :: type_float
+ INTEGER, DIMENSION(10) :: ivdims
+ CHARACTER(LEN=20) :: ycdfvar
+
+
+ nbfiles = outfiles%nbfiles
+
+ IF (options(OPTREDUCE)%set) THEN
+ type_float = NF90_REAL
+ ELSE
+ type_float = NF90_DOUBLE
+ END IF
+
+ DO ji = 1,nbfiles
+ kcdf_id = outfiles%files(ji)%lun_id
+
+ ! global attributes
+ status = NF90_PUT_ATT(kcdf_id,NF90_GLOBAL,'Title',VERSION_ID)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ ! define DIMENSIONS
+ tzdim=>first_DimCDF()
+ DO WHILE(ASSOCIATED(tzdim))
+ IF (tzdim%create) THEN
+ status = NF90_DEF_DIM(kcdf_id,tzdim%name,tzdim%len,tzdim%id)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ END IF
+ tzdim=>tzdim%next
+ END DO
+ END DO
+
+ PRINT *,'------------- NetCDF DEFINITION ---------------'
+
+ ! define VARIABLES and ATTRIBUTES
+ idx = 1
+ DO ji=1,nbvar
+ IF (.NOT.tpreclist(ji)%tbw) CYCLE
+
+ IF (ASSOCIATED(tpreclist(ji)%dim)) THEN
+ IF (tpreclist(ji)%dim%create) THEN
+ invdims = 1
+ ivdims(1) = tpreclist(ji)%dim%id
+ ELSE
+ invdims = tpreclist(ji)%dim%ndims
+ IF(options(OPTMERGE)%set) invdims=invdims+1 !when merging variables from LFI splitted files
+ SELECT CASE(invdims)
+ CASE(2)
+ ivdims(1)=ptdimx%id
+ ivdims(2)=ptdimy%id
+ CASE(3)
+ ivdims(1)=ptdimx%id
+ ivdims(2)=ptdimy%id
+ ivdims(3)=ptdimz%id
+ CASE(12)
+ ivdims(1)=ptdimx%id
+ ivdims(2)=ptdimz%id
+ invdims = 2 ! on retablit la bonne valeur du nbre de dimension
+ CASE default
+ PRINT *,'Fatal error in NetCDF dimension definition'
+ STOP
+ END SELECT
+ END IF
+ ELSE
+ ! scalar variables
+ invdims = 0
+ ivdims(1) = 0 ! ignore dans ce cas
+ END IF
+
+ ! Variables definition
+
+ !! NetCDF n'aime pas les '%' dans le nom des variables
+ !! "%" remplaces par '__'
+ ycdfvar = str_replace(tpreclist(ji)%name,'%','__')
+ !! ni les '.' remplaces par '--'
+ ycdfvar = str_replace(ycdfvar,'.','--')
+
+ kcdf_id = outfiles%files(idx)%lun_id
+
+ SELECT CASE(tpreclist(ji)%TYPE)
+ CASE (TEXT)
+! PRINT *,'TEXT : ',tpreclist(ji)%name
+ status = NF90_DEF_VAR(kcdf_id,ycdfvar,NF90_CHAR,&
+ ivdims(:invdims),tpreclist(ji)%id_out)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ CASE (INT,BOOL)
+! PRINT *,'INT,BOOL : ',tpreclist(ji)%name
+ status = NF90_DEF_VAR(kcdf_id,ycdfvar,NF90_INT,&
+ ivdims(:invdims),tpreclist(ji)%id_out)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ CASE(FLOAT)
+! PRINT *,'FLOAT : ',tpreclist(ji)%name
+ status = NF90_DEF_VAR(kcdf_id,ycdfvar,type_float,&
+ ivdims(:invdims),tpreclist(ji)%id_out)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+
+ CASE default
+ PRINT *,'ATTENTION : ',TRIM(tpreclist(ji)%name),' est de&
+ & TYPE inconnu --> force a REAL'
+ status = NF90_DEF_VAR(kcdf_id,ycdfvar,type_float,&
+ ivdims(:invdims),tpreclist(ji)%id_out)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+
+ END SELECT
+
+ ! Compress data (costly operation for the CPU)
+ IF (options(OPTCOMPRESS)%set .AND. invdims>0) THEN
+ compress_level = options(OPTCOMPRESS)%ivalue
+ status = NF90_DEF_VAR_DEFLATE(kcdf_id,tpreclist(ji)%id_out,1,1,compress_level)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ END IF
+
+ ! GRID attribute definition
+ status = NF90_PUT_ATT(kcdf_id,tpreclist(ji)%id_out,'GRID',tpreclist(ji)%grid)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ ! COMMENT attribute definition
+ status = NF90_PUT_ATT(kcdf_id,tpreclist(ji)%id_out,'COMMENT',trim(tpreclist(ji)%comment))
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ IF (options(OPTSPLIT)%set) idx = idx + 1
+ END DO
+
+ DO ji = 1,nbfiles
+ kcdf_id = outfiles%files(ji)%lun_id
+ status = NF90_ENDDEF(kcdf_id)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ END DO
+
+ END SUBROUTINE def_ncdf
+
+ SUBROUTINE fill_ncdf(infiles,outfiles,tpreclist,knaf,kbuflen,options,current_level)
+ TYPE(filelist_struct), INTENT(IN):: infiles, outfiles
+ TYPE(workfield), DIMENSION(:),INTENT(IN):: tpreclist
+ INTEGER, INTENT(IN):: knaf
+ INTEGER, INTENT(IN):: kbuflen
+ TYPE(option),DIMENSION(:), INTENT(IN):: options
+ INTEGER, INTENT(IN), OPTIONAL :: current_level
+
+#ifdef LOWMEM
+ INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE :: iwork
+#endif
+ INTEGER :: idx, ji,jj
+ INTEGER :: kcdf_id
+ INTEGER :: status
+ INTEGER :: extent, ndims
+ INTEGER :: ich
+ INTEGER :: src
+ INTEGER :: level
+ INTEGER(KIND=LFI_INT) :: iresp,ilu,ileng,ipos
+ CHARACTER(LEN=4) :: suffix
+ INTEGER,DIMENSION(3) :: idims, start
+ INTEGER,DIMENSION(:),ALLOCATABLE :: itab
+ REAL(KIND=8),DIMENSION(:),ALLOCATABLE :: xtab
+ CHARACTER, DIMENSION(:), ALLOCATABLE :: ytab
+ REAL(KIND=8), DIMENSION(:,:,:), ALLOCATABLE :: xtab3d, xtab3d2
+ INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: itab3d, itab3d2
+
+
+ !
+ IF (infiles%files(1)%format == LFI_FORMAT) ilu = infiles%files(1)%lun_id
+ !
+
+ IF (present(current_level)) THEN
+ write(suffix,'(I4.4)') current_level
+ level = current_level
+ ElSE
+ suffix=''
+ level = 1
+ END IF
+
+#if LOWMEM
+ ALLOCATE(iwork(kbuflen))
+#endif
+ ALLOCATE(itab(kbuflen))
+ ALLOCATE(xtab(kbuflen))
+
+ idx = 1
+ DO ji=1,knaf
+ IF (.NOT.tpreclist(ji)%tbw) CYCLE
+
+ kcdf_id = outfiles%files(idx)%lun_id
+
+ IF (ASSOCIATED(tpreclist(ji)%dim)) THEN
+ extent = tpreclist(ji)%dim%len
+ ndims = tpreclist(ji)%dim%ndims
+ ELSE
+ extent = 1
+ ndims = 0
+ END IF
+
+ idims(:) = 1
+ if(ndims>0) idims(1) = ptdimx%len
+ if(ndims>1) idims(2) = ptdimy%len
+ if(ndims>2) idims(3) = ptdimz%len
+ if(ndims>3) then
+ PRINT *,'Too many dimensions'
+ STOP
+ endif
+
+ SELECT CASE(tpreclist(ji)%TYPE)
+ CASE (INT,BOOL)
+ IF (infiles%files(1)%format == LFI_FORMAT) THEN
+#if LOWMEM
+ IF (.NOT.tpreclist(ji)%calc) THEN
+ CALL LFINFO(iresp,ilu,trim(tpreclist(ji)%name)//trim(suffix),ileng,ipos)
+ CALL LFILEC(iresp,ilu,trim(tpreclist(ji)%name)//trim(suffix),iwork,ileng)
+ itab(1:extent) = iwork(3+iwork(2):)
+ ELSE
+ src=tpreclist(ji)%src(1)
+ CALL LFINFO(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),ileng,ipos)
+ CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),iwork,ileng)
+ itab(1:extent) = iwork(3+iwork(2):)
+ jj = 2
+ DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
+ src=tpreclist(ji)%src(jj)
+ CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),iwork,ileng)
+ itab(1:extent) = itab(1:extent) + iwork(3+iwork(2):)
+ jj=jj+1
+ END DO
+ ENDIF
+#else
+ IF (.NOT.tpreclist(ji)%calc) THEN
+ itab(1:extent) = lfiart(ji)%iwtab(3+lfiart(ji)%iwtab(2):)
+ ELSE
+ src=tpreclist(ji)%src(1)
+ itab(1:extent) = lfiart(src)%iwtab(3+lfiart(src)%iwtab(2):)
+ jj = 2
+ DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
+ src=tpreclist(ji)%src(jj)
+ itab(1:extent) = xtab(1:extent) + lfiart(src)%iwtab(3+lfiart(src)%iwtab(2):)
+ jj=jj+1
+ END DO
+ END IF
+#endif
+
+!TODO: works in all cases??? (X, Y, Z dimensions assumed to be ptdimx,y or z)
+ SELECT CASE(ndims)
+ CASE (0)
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,itab(1))
+ CASE (1)
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,itab(1:extent),count=(/extent/))
+ CASE (2)
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,reshape(itab,(/ptdimx%len,ptdimy%len/)), &
+ start = (/1,1,level/) )
+ CASE (3)
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,reshape(itab,(/ptdimx%len,ptdimy%len,ptdimz%len/)))
+ CASE DEFAULT
+ print *,'Error: arrays with ',tpreclist(ji)%dim%ndims,' dimensions are not supported'
+ END SELECT
+
+ ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
+ ALLOCATE( itab3d(idims(1),idims(2),idims(3)) )
+ IF (.NOT.tpreclist(ji)%calc) THEN
+ status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(ji)%id_in,itab3d)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ ELSE
+ ALLOCATE( itab3d2(idims(1),idims(2),idims(3)) )
+ src=tpreclist(ji)%src(1)
+ status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(src)%id_in,itab3d)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ jj = 2
+ DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
+ src=tpreclist(ji)%src(jj)
+ status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(src)%id_in,itab3d2)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ itab3d(:,:,:) = itab3d(:,:,:) + itab3d2(:,:,:)
+ jj=jj+1
+ END DO
+ DEALLOCATE(itab3d2)
+ END IF
+
+!TODO: not clean, should be done only if merging z-levels
+ IF (ndims == 2) THEN
+ start = (/1,1,level/)
+ ELSE
+ start = (/1,1,1/)
+ ENDIF
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,itab3d,start=start)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ DEALLOCATE(itab3d)
+ END IF
+
+
+ CASE (FLOAT)
+ IF (infiles%files(1)%format == LFI_FORMAT) THEN
+#if LOWMEM
+ IF (.NOT.tpreclist(ji)%calc) THEN
+ CALL LFINFO(iresp,ilu,trim(tpreclist(ji)%name)//trim(suffix),ileng,ipos)
+ CALL LFILEC(iresp,ilu,trim(tpreclist(ji)%name)//trim(suffix),iwork,ileng)
+ xtab(1:extent) = TRANSFER(iwork(3+iwork(2):),(/ 0.0_8 /))
+ ELSE
+ src=tpreclist(ji)%src(1)
+ CALL LFINFO(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),ileng,ipos)
+ CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),iwork,ileng)
+ xtab(1:extent) = TRANSFER(iwork(3+iwork(2):),(/ 0.0_8 /))
+ jj = 2
+ DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
+ src=tpreclist(ji)%src(jj)
+ CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),iwork,ileng)
+ xtab(1:extent) = xtab(1:extent) + TRANSFER(iwork(3+iwork(2):),(/ 0.0_8 /))
+ jj=jj+1
+ END DO
+ ENDIF
+#else
+ IF (.NOT.tpreclist(ji)%calc) THEN
+ xtab(1:extent) = TRANSFER(lfiart(ji)%iwtab(3+lfiart(ji)%iwtab(2):),(/ 0.0_8 /))
+ ELSE
+ src=tpreclist(ji)%src(1)
+ xtab(1:extent) = TRANSFER(lfiart(src)%iwtab(3+lfiart(src)%iwtab(2):),(/ 0.0_8 /))
+ jj = 2
+ DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
+ src=tpreclist(ji)%src(jj)
+ xtab(1:extent) = xtab(1:extent) + TRANSFER(lfiart(src)%iwtab(3+lfiart(src)%iwtab(2):),(/ 0.0_8 /))
+ jj=jj+1
+ END DO
+ END IF
+#endif
+!TODO: works in all cases??? (X, Y, Z dimensions assumed to be ptdimx,y or z)
+ SELECT CASE(ndims)
+ CASE (0)
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,xtab(1))
+ CASE (1)
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,xtab(1:extent),count=(/extent/))
+ CASE (2)
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,reshape(xtab,(/ptdimx%len,ptdimy%len/)), &
+ start = (/1,1,level/) )
+ CASE (3)
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,reshape(xtab,(/ptdimx%len,ptdimy%len,ptdimz%len/)))
+ CASE DEFAULT
+ print *,'Error: arrays with ',tpreclist(ji)%dim%ndims,' dimensions are not supported'
+ END SELECT
+
+ ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
+ ALLOCATE( xtab3d(idims(1),idims(2),idims(3)) )
+ IF (.NOT.tpreclist(ji)%calc) THEN
+ status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(ji)%id_in,xtab3d)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ ELSE
+ ALLOCATE( xtab3d2(idims(1),idims(2),idims(3)) )
+ src=tpreclist(ji)%src(1)
+ status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(src)%id_in,xtab3d)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ jj = 2
+ DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
+ src=tpreclist(ji)%src(jj)
+ status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(src)%id_in,xtab3d2)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ xtab3d(:,:,:) = xtab3d(:,:,:) + xtab3d2(:,:,:)
+ jj=jj+1
+ END DO
+ DEALLOCATE(xtab3d2)
+ END IF
+
+!TODO: not clean, should be done only if merging z-levels
+ IF (ndims == 2) THEN
+ start = (/1,1,level/)
+ ELSE
+ start = (/1,1,1/)
+ ENDIF
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,xtab3d,start=start)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ DEALLOCATE(xtab3d)
+ END IF
+
+ CASE (TEXT)
+ IF (infiles%files(1)%format == LFI_FORMAT) THEN
+ ALLOCATE(ytab(extent))
+ DO jj=1,extent
+#if LOWMEM
+ ich = iwork(2+iwork(2)+jj)
+#else
+ ich = lfiart(ji)%iwtab(2+lfiart(ji)%iwtab(2)+jj)
+#endif
+ ytab(jj) = CHAR(ich)
+ END DO
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,ytab,count=(/extent/))
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ DEALLOCATE(ytab)
+ ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
+ status = NF90_GET_VAR(infiles%files(1)%lun_id,tpreclist(ji)%id_in,ytab,count=(/extent/))
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,ytab,count=(/extent/))
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ END IF
+
+ CASE default
+ IF (infiles%files(1)%format == LFI_FORMAT) THEN
+#if LOWMEM
+ IF (.NOT.tpreclist(ji)%calc) THEN
+ CALL LFINFO(iresp,ilu,trim(tpreclist(ji)%name)//trim(suffix),ileng,ipos)
+ CALL LFILEC(iresp,ilu,trim(tpreclist(ji)%name)//trim(suffix),iwork,ileng)
+ xtab(1:extent) = TRANSFER(iwork(3+iwork(2):),(/ 0.0_8 /))
+ ELSE
+ src=tpreclist(ji)%src(1)
+ CALL LFINFO(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),ileng,ipos)
+ CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),iwork,ileng)
+ xtab(1:extent) = TRANSFER(iwork(3+iwork(2):),(/ 0.0_8 /))
+ jj = 2
+ DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
+ src=tpreclist(ji)%src(jj)
+ CALL LFILEC(iresp,ilu,trim(tpreclist(src)%name)//trim(suffix),iwork,ileng)
+ xtab(1:extent) = xtab(1:extent) + TRANSFER(iwork(3+iwork(2):),(/ 0.0_8 /))
+ jj=jj+1
+ END DO
+ ENDIF
+#else
+ IF (.NOT.tpreclist(ji)%calc) THEN
+ xtab(1:extent) = TRANSFER(lfiart(ji)%iwtab(3+lfiart(ji)%iwtab(2):),(/ 0.0_8 /))
+ ELSE
+ src=tpreclist(ji)%src(1)
+ xtab(1:extent) = TRANSFER(lfiart(src)%iwtab(3+lfiart(src)%iwtab(2):),(/ 0.0_8 /))
+ jj = 2
+ DO WHILE (tpreclist(ji)%src(jj)>0 .AND. jj.LE.MAXRAW)
+ src=tpreclist(ji)%src(jj)
+ xtab(1:extent) = xtab(1:extent) + TRANSFER(lfiart(src)%iwtab(3+lfiart(src)%iwtab(2):),(/ 0.0_8 /))
+ jj=jj+1
+ END DO
+ END IF
+#endif
+!TODO: works in all cases??? (X, Y, Z dimensions assumed to be ptdimx,y or z)
+ SELECT CASE(ndims)
+ CASE (0)
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,xtab(1))
+ CASE (1)
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,xtab(1:extent),count=(/extent/))
+ CASE (2)
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,reshape(xtab,(/ptdimx%len,ptdimy%len/)), &
+ start = (/1,1,level/) )
+ CASE (3)
+ status = NF90_PUT_VAR(kcdf_id,tpreclist(ji)%id_out,reshape(xtab,(/ptdimx%len,ptdimy%len,ptdimz%len/)))
+ CASE DEFAULT
+ print *,'Error: arrays with ',tpreclist(ji)%dim%ndims,' dimensions are not supported'
+ END SELECT
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ ELSE IF (infiles%files(1)%format == NETCDF_FORMAT) THEN
+ print *,'Error: unknown datatype'
+ STOP
+ END IF
+
+ END SELECT
+
+ if (options(OPTSPLIT)%set) idx = idx + 1
+ END DO
+ DEALLOCATE(itab,xtab)
+#if LOWMEM
+ DEALLOCATE(iwork)
+#endif
+ END SUBROUTINE fill_ncdf
+
+ SUBROUTINE build_lfi(infiles,outfiles,tpreclist,kbuflen)
+ TYPE(filelist_struct), INTENT(IN) :: infiles, outfiles
+ TYPE(workfield), DIMENSION(:), INTENT(IN) :: tpreclist
+ INTEGER, INTENT(IN) :: kbuflen
+
+ INTEGER :: kcdf_id, status
+ INTEGER :: ivar,ji,jj,ndims
+ INTEGER,DIMENSION(3) :: idims
+ INTEGER(KIND=8), DIMENSION(:), POINTER :: iwork
+ INTEGER(KIND=8), DIMENSION(:), POINTER :: idata
+ REAL(KIND=8), DIMENSION(:,:,:), ALLOCATABLE :: xtab3d
+ INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: itab3d
+ CHARACTER, DIMENSION(:), ALLOCATABLE :: ytab
+ CHARACTER(LEN=FM_FIELD_SIZE) :: yrecfm
+
+ INTEGER :: iartlen, idlen, icomlen
+ INTEGER(KIND=LFI_INT) :: iresp,ilu,iartlen8
+
+
+ ilu = outfiles%files(1)%lun_id
+ kcdf_id = infiles%files(1)%lun_id
+
+ ! Un article LFI est compose de :
+ ! - 1 entier identifiant le numero de grille
+ ! - 1 entier contenant la taille du commentaire
+ ! - le commentaire code en entier 64 bits
+ ! - les donnees proprement dites
+
+ PRINT *,'Taille buffer = ',2+kbuflen
+
+ ALLOCATE(iwork(2+kbuflen))
+
+ DO ivar=1,SIZE(tpreclist)
+ icomlen = LEN(tpreclist(ivar)%comment)
+
+ ! traitement Grille et Commentaire
+ iwork(1) = tpreclist(ivar)%grid
+ iwork(2) = icomlen
+ DO jj=1,iwork(2)
+ iwork(2+jj)=ICHAR(tpreclist(ivar)%comment(jj:jj))
+ END DO
+
+ IF (ASSOCIATED(tpreclist(ivar)%dim)) THEN
+ idlen = tpreclist(ivar)%dim%len
+ ndims = tpreclist(ivar)%dim%ndims
+ ELSE
+ idlen = 1
+ ndims = 0
+ END IF
+
+ idims(:) = 1
+ if(ndims>0) idims(1) = ptdimx%len
+ if(ndims>1) idims(2) = ptdimy%len
+ if(ndims>2) idims(3) = ptdimz%len
+ if(ndims>3) then
+ PRINT *,'Too many dimensions'
+ STOP
+ endif
+
+ iartlen = 2+icomlen+idlen
+ idata=>iwork(3+icomlen:iartlen)
+
+
+ SELECT CASE(tpreclist(ivar)%TYPE)
+ CASE(INT,BOOL)
+ ALLOCATE( itab3d(idims(1),idims(2),idims(3)) )
+ status = NF90_GET_VAR(kcdf_id,tpreclist(ivar)%id_in,itab3d)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+! PRINT *,'INT,BOOL --> ',tpreclist(ivar)%name,',len = ',idlen
+ idata(1:idlen) = RESHAPE( itab3d , (/ idims(1)*idims(2)*idims(3) /) )
+
+ DEALLOCATE(itab3d)
+
+ CASE(FLOAT)
+ ALLOCATE( xtab3d(idims(1),idims(2),idims(3)) )
+ status = NF90_GET_VAR(kcdf_id,tpreclist(ivar)%id_in,xtab3d)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+! PRINT *,'FLOAT --> ',tpreclist(ivar)%name,',len = ',idlen
+ idata(1:idlen) = RESHAPE( TRANSFER(xtab3d,(/ 0_8 /),idlen) , (/ idims(1)*idims(2)*idims(3) /) )
+
+ DEALLOCATE(xtab3d)
+
+ CASE(TEXT)
+ ALLOCATE(ytab(idlen))
+ status = NF90_GET_VAR(kcdf_id,tpreclist(ivar)%id_in,ytab)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+! PRINT *,'TEXT --> ',tpreclist(ivar)%name,',len = ',idlen
+ DO jj=1,idlen
+ idata(jj) = ICHAR(ytab(jj))
+ END DO
+
+ DEALLOCATE(ytab)
+
+ CASE default
+ ALLOCATE( xtab3d(idims(1),idims(2),idims(3)) )
+ status = NF90_GET_VAR(kcdf_id,tpreclist(ivar)%id_in,xtab3d)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ PRINT *,'Default (ERROR) -->',tpreclist(ivar)%name,',len = ',idlen
+ idata(1:idlen) = RESHAPE( TRANSFER(xtab3d,(/ 0_8 /),idlen) , (/ idims(1)*idims(2)*idims(3) /) )
+
+ DEALLOCATE(xtab3d)
+
+ END SELECT
+
+ ! Attention restoration des '%' dans le nom des champs LFI
+ yrecfm = str_replace(tpreclist(ivar)%name,'__','%')
+ ! et des '.'
+ yrecfm = str_replace(yrecfm,'--','.')
+ iartlen8 = iartlen
+ CALL LFIECR(iresp,ilu,yrecfm,iwork,iartlen8)
+
+ END DO
+ DEALLOCATE(iwork)
+
+ END SUBROUTINE build_lfi
+
+ SUBROUTINE UPDATE_VARID_IN(infiles,hinfile,tpreclist,nbvar,current_level)
+ !Update the id_in for netCDF files (could change from one file to the other)
+ TYPE(filelist_struct), INTENT(IN) :: infiles
+ CHARACTER(LEN=*), INTENT(IN) :: hinfile
+ TYPE(workfield), DIMENSION(:), INTENT(INOUT) :: tpreclist
+ INTEGER, INTENT(IN) :: nbvar
+ INTEGER, INTENT(IN) :: current_level
+
+ INTEGER :: ji, status
+ CHARACTER(len=4) :: suffix
+
+
+ if (infiles%files(1)%format /= NETCDF_FORMAT) return
+
+ write(suffix,'(I4.4)') current_level
+
+ DO ji=1,nbvar
+ IF (.NOT.tpreclist(ji)%tbr) CYCLE
+ status = NF90_INQ_VARID(infiles%files(1)%lun_id,trim(tpreclist(ji)%name)//trim(suffix),tpreclist(ji)%id_in)
+ IF (status /= NF90_NOERR .AND. tpreclist(ji)%found) THEN
+ tpreclist(ji)%found=.false.
+ tpreclist(ji)%tbr=.false.
+ tpreclist(ji)%tbw=.false.
+ print *,'Error: variable ',trim(tpreclist(ji)%name),' not found anymore in split file'
+ END IF
+ END DO
+ END SUBROUTINE UPDATE_VARID_IN
+
+ SUBROUTINE OPEN_FILES(infiles,outfiles,hinfile,houtfile,nbvar_infile,options,runmode)
+ TYPE(filelist_struct),INTENT(OUT) :: infiles, outfiles
+ CHARACTER(LEN=*), INTENT(IN) :: hinfile
+ CHARACTER(LEN=*), INTENT(IN) :: houtfile
+ INTEGER , INTENT(OUT) :: nbvar_infile
+ TYPE(option),DIMENSION(:),INTENT(IN) :: options
+ INTEGER , INTENT(IN) :: runmode
+
+ INTEGER :: extindex
+ INTEGER(KIND=LFI_INT) :: iresp,iverb,inap,inaf
+ INTEGER :: idx,status
+ CHARACTER(LEN=4) :: ypextsrc, ypextdest
+ LOGICAL :: fexist
+ INTEGER :: omode
+
+ iverb = 0
+
+ CALL init_sysfield()
+
+ IF (runmode == MODELFI2CDF) THEN
+ ! Cas LFI -> NetCDF
+ infiles%nbfiles = infiles%nbfiles + 1
+ idx = infiles%nbfiles
+ infiles%files(idx)%lun_id = 11
+ infiles%files(idx)%format = LFI_FORMAT
+ infiles%files(idx)%status = READING
+ CALL LFIOUV(iresp,infiles%files(idx)%lun_id,ltrue,hinfile,'OLD',lfalse&
+ & ,lfalse,iverb,inap,inaf)
+ infiles%files(idx)%opened = .TRUE.
+
+ nbvar_infile = inaf
+
+ IF (options(OPTLIST)%set) THEN
+ CALL LFILAF(iresp,infiles%files(idx)%lun_id,lfalse)
+ CALL LFIFER(iresp,infiles%files(idx)%lun_id,'KEEP')
+ return
+ END IF
+
+ IF (.NOT.options(OPTSPLIT)%set) THEN
+ outfiles%nbfiles = outfiles%nbfiles + 1
+
+ idx = outfiles%nbfiles
+ outfiles%files(idx)%format = NETCDF_FORMAT
+ outfiles%files(idx)%status = WRITING
+ IF (options(OPTCDF4)%set) THEN
+ status = NF90_CREATE(houtfile, IOR(NF90_CLOBBER,NF90_NETCDF4), outfiles%files(idx)%lun_id)
+ ELSE
+ status = NF90_CREATE(houtfile, IOR(NF90_CLOBBER,NF90_64BIT_OFFSET), outfiles%files(idx)%lun_id)
+ END IF
+
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ outfiles%files(idx)%opened = .TRUE.
+
+ status = NF90_SET_FILL(outfiles%files(idx)%lun_id,NF90_NOFILL,omode)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+!!$ SELECT CASE(omode)
+!!$ CASE (NF90_FILL)
+!!$ PRINT *,'Ancien mode : NF90_FILL'
+!!$ CASE (NF90_NOFILL)
+!!$ PRINT *,'Ancien mode : NF90_NOFILL'
+!!$ CASE default
+!!$ PRINT *, 'Ancien mode : inconnu'
+!!$ END SELECT
+ END IF ! .NOT.osplit
+
+ ELSE IF (runmode == MODECDF2CDF) THEN
+ ! Cas netCDF -> netCDF
+
+ infiles%nbfiles = infiles%nbfiles + 1
+ idx = infiles%nbfiles
+ status = NF90_OPEN(hinfile,NF90_NOWRITE,infiles%files(idx)%lun_id)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ infiles%files(idx)%opened = .TRUE.
+ infiles%files(idx)%format = NETCDF_FORMAT
+ infiles%files(idx)%status = READING
+
+ status = NF90_INQUIRE(infiles%files(idx)%lun_id, nvariables = nbvar_infile)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+
+ IF (.NOT.options(OPTSPLIT)%set) THEN
+ outfiles%nbfiles = outfiles%nbfiles + 1
+ idx = outfiles%nbfiles
+
+ IF (options(OPTCDF4)%set) THEN
+ status = NF90_CREATE(houtfile, IOR(NF90_CLOBBER,NF90_NETCDF4), outfiles%files(idx)%lun_id)
+ ELSE
+ status = NF90_CREATE(houtfile, IOR(NF90_CLOBBER,NF90_64BIT_OFFSET), outfiles%files(idx)%lun_id)
+ END IF
+
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ outfiles%files(idx)%opened = .TRUE.
+ outfiles%files(idx)%format = NETCDF_FORMAT
+ outfiles%files(idx)%status = WRITING
+
+ status = NF90_SET_FILL(outfiles%files(idx)%lun_id,NF90_NOFILL,omode)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ END IF ! .NOT.osplit
+
+ ELSE
+ ! Cas NetCDF -> LFI
+ infiles%nbfiles = infiles%nbfiles + 1
+ idx = infiles%nbfiles
+ status = NF90_OPEN(hinfile,NF90_NOWRITE,infiles%files(idx)%lun_id)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ infiles%files(idx)%opened = .TRUE.
+ infiles%files(idx)%format = NETCDF_FORMAT
+ infiles%files(idx)%status = READING
+
+ status = NF90_INQUIRE(infiles%files(idx)%lun_id, nvariables = nbvar_infile)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ inap = 100
+ outfiles%nbfiles = outfiles%nbfiles + 1
+ idx = outfiles%nbfiles
+ outfiles%files(idx)%lun_id = 11
+ outfiles%files(idx)%format = LFI_FORMAT
+ outfiles%files(idx)%status = WRITING
+ CALL LFIOUV(iresp,outfiles%files(idx)%lun_id,ltrue,houtfile,'NEW'&
+ & ,lfalse,lfalse,iverb,inap,inaf)
+ outfiles%files(idx)%opened = .TRUE.
+ END IF
+
+ PRINT *,'--> Fichier converti : ', houtfile
+
+ END SUBROUTINE OPEN_FILES
+
+ SUBROUTINE OPEN_SPLIT_LFIFILE_IN(infiles,hinfile,current_level)
+ TYPE(filelist_struct), INTENT(INOUT) :: infiles
+ CHARACTER(LEN=*), INTENT(IN) :: hinfile
+ INTEGER, INTENT(IN) :: current_level
+
+ INTEGER(KIND=LFI_INT) :: ilu,iresp,iverb,inap,nbvar
+
+ CHARACTER(LEN=3) :: suffix
+ CHARACTER(LEN=:),ALLOCATABLE :: filename
+
+
+ iverb = 0 !Verbosity level for LFI
+
+ ALLOCATE(character(len=len(hinfile)) :: filename)
+
+ ilu = infiles%files(1)%lun_id !We assume only 1 infile
+
+ write(suffix,'(I3.3)') current_level
+ filename=hinfile(1:len(hinfile)-7)//suffix//'.lfi'
+ CALL LFIOUV(iresp,ilu,ltrue,filename,'OLD',lfalse,lfalse,iverb,inap,nbvar)
+ infiles%files(1)%opened = .TRUE.
+
+ DEALLOCATE(filename)
+ END SUBROUTINE OPEN_SPLIT_LFIFILE_IN
+
+ SUBROUTINE OPEN_SPLIT_NCFILE_IN(infiles,hinfile,current_level)
+ TYPE(filelist_struct), INTENT(INOUT) :: infiles
+ CHARACTER(LEN=*), INTENT(IN) :: hinfile
+ INTEGER, INTENT(IN) :: current_level
+
+ INTEGER :: status
+ CHARACTER(LEN=3) :: suffix
+ CHARACTER(LEN=:),ALLOCATABLE :: filename
+
+
+ ALLOCATE(character(len=len(hinfile)) :: filename)
+
+ write(suffix,'(I3.3)') current_level
+ filename=hinfile(1:len(hinfile)-6)//suffix//'.nc'
+ status = NF90_OPEN(filename,NF90_NOWRITE,infiles%files(1)%lun_id)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ infiles%files(1)%opened = .TRUE.
+
+ DEALLOCATE(filename)
+ END SUBROUTINE OPEN_SPLIT_NCFILE_IN
+
+ SUBROUTINE OPEN_SPLIT_NCFILES_OUT(outfiles,houtfile,nbvar,tpreclist,options)
+ TYPE(filelist_struct), INTENT(INOUT) :: outfiles
+ CHARACTER(LEN=*), INTENT(IN) :: houtfile
+ INTEGER, INTENT(IN) :: nbvar
+ TYPE(workfield), DIMENSION(:), INTENT(IN) :: tpreclist
+ TYPE(option),DIMENSION(:), INTENT(IN) :: options
+
+ INTEGER :: ji, idx
+ INTEGER :: status
+ INTEGER :: omode
+ CHARACTER(LEN=MAXLEN) :: filename
+
+
+ DO ji = 1,nbvar
+ IF (tpreclist(ji)%tbw) outfiles%nbfiles = outfiles%nbfiles + 1
+ END DO
+
+ idx = 1
+ DO ji = 1,nbvar
+ IF (.NOT.tpreclist(ji)%tbw) CYCLE
+ outfiles%files(idx)%var_id = ji
+
+ IF (options(OPTCDF4)%set) THEN
+ filename = trim(houtfile)//'.'//trim(tpreclist(ji)%name)//'.nc4'
+ status = NF90_CREATE(trim(filename), IOR(NF90_CLOBBER,NF90_NETCDF4), outfiles%files(idx)%lun_id)
+ ELSE
+ filename = trim(houtfile)//'.'//trim(tpreclist(ji)%name)//'.nc'
+ status = NF90_CREATE(trim(filename), IOR(NF90_CLOBBER,NF90_64BIT_OFFSET), outfiles%files(idx)%lun_id)
+ END IF
+
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ status = NF90_SET_FILL(outfiles%files(idx)%lun_id,NF90_NOFILL,omode)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+
+ outfiles%files(idx)%opened = .TRUE.
+ outfiles%files(idx)%format = NETCDF_FORMAT
+ outfiles%files(idx)%status = WRITING
+
+ idx = idx + 1
+ END DO
+
+ END SUBROUTINE OPEN_SPLIT_NCFILES_OUT
+
+ SUBROUTINE CLOSE_FILES(filelist)
+ TYPE(filelist_struct),INTENT(INOUT) :: filelist
+
+ INTEGER(KIND=LFI_INT) :: iresp
+ INTEGER :: ji,status
+
+ DO ji=1,filelist%nbfiles
+ IF ( .NOT.filelist%files(ji)%opened ) CYCLE
+
+ IF ( filelist%files(ji)%format == LFI_FORMAT ) THEN
+ CALL LFIFER(iresp,filelist%files(ji)%lun_id,'KEEP')
+ ELSE IF ( filelist%files(ji)%format == NETCDF_FORMAT ) THEN
+ status = NF90_CLOSE(filelist%files(ji)%lun_id)
+ IF (status /= NF90_NOERR) CALL HANDLE_ERR(status,__LINE__)
+ END IF
+ filelist%files(ji)%opened=.false.
+ END DO
+
+ END SUBROUTINE CLOSE_FILES
+
+END MODULE mode_util
diff --git a/LIBTOOLS/tools/lfiz/Makefile b/LIBTOOLS/tools/lfiz/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..bd89bf5f4a95681493ba4f10a5c9f585a4be0802
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Makefile
@@ -0,0 +1,43 @@
+VPATH=src:$(DIR_OBJ)
+###########################
+DIR_OBJ = ./$(ARCH)
+
+include ../where.Libs
+
+INC = -I$(DIR_COMP)/$(ARCH)
+
+include $(DIR_CONF)/config.$(ARCH)
+include Rules.$(ARCH)
+
+PROGS = lfiz unlfiz testlibcomp
+
+%.o:%.f90 $(DIR_OBJ)/.dummy
+ $(CPP) $(INC) $(CPPFLAGS) $< > $(DIR_OBJ)/cpp_$(*F).f90
+ $(F90) $(INC) -c $(F90FLAGS) $(DIR_OBJ)/cpp_$(*F).f90 -o $(DIR_OBJ)/$(*F).o
+
+all: $(PROGS)
+
+$(PROGS): %:%.o $(LIBCOMP) $(LIBLFI)
+ cd $(DIR_OBJ); $(F90) $(LDFLAGS) -o $@ $@.o $(LIBLFI) $(LIBCOMP) $(LIBS)
+
+$(DIR_OBJ)/.dummy:
+ mkdir -p $(DIR_OBJ)
+ @touch $(DIR_OBJ)/.dummy
+
+$(LIBLFI): $(DIR_LFI)
+ $(MAKE) -C $(DIR_LFI)
+
+$(LIBCOMP): $(DIR_COMP)
+ $(MAKE) -C $(DIR_COMP)
+
+$(DIR_LFI) $(DIR_COMP):
+ @echo "ERROR : COMPRESS and/or NEWLFI directory can't be found"
+ @echo " from root directory DIR_LIB = $(DIR_LIB)";echo
+ @echo "Please check SRC_MESONH or DIR_LIB environment variable"
+ @echo "and try again...";exit 1
+
+clean:
+ (if [ -d $(DIR_OBJ) ] ; then cd $(DIR_OBJ); rm -f cpp_*.f90 cpp_*.f *.o *.mod ; fi)
+
+distclean:
+ rm -rf $(DIR_OBJ)
diff --git a/LIBTOOLS/tools/lfiz/Rules.AIX32 b/LIBTOOLS/tools/lfiz/Rules.AIX32
new file mode 100644
index 0000000000000000000000000000000000000000..6565cfd29eea3f22ac244827ed64e21f027d22eb
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.AIX32
@@ -0,0 +1,4 @@
+
+#LIBS += -L$(MESONH)/binaries -lbidon
+
+CPPFLAGS += -DFUJI
diff --git a/LIBTOOLS/tools/lfiz/Rules.AIX64 b/LIBTOOLS/tools/lfiz/Rules.AIX64
new file mode 100644
index 0000000000000000000000000000000000000000..58f7a25f69acedae84f516a88067969b414bd5ea
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.AIX64
@@ -0,0 +1,4 @@
+
+LIBS += -L$(MESONH)/binaries -lbidon
+
+CPPFLAGS += -DFUJI
diff --git a/LIBTOOLS/tools/lfiz/Rules.HPNAGf95 b/LIBTOOLS/tools/lfiz/Rules.HPNAGf95
new file mode 100644
index 0000000000000000000000000000000000000000..1d8c3f6fbe1352fa6b94c03fba7ce8c6cc14f9c3
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.HPNAGf95
@@ -0,0 +1,4 @@
+F90FLAGS += -g -O2
+CPPFLAGS += -DNAGf95
+
+
diff --git a/LIBTOOLS/tools/lfiz/Rules.HPf90 b/LIBTOOLS/tools/lfiz/Rules.HPf90
new file mode 100644
index 0000000000000000000000000000000000000000..6c001d600bfce3fb494115793f1009118f2491fe
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.HPf90
@@ -0,0 +1,2 @@
+CPPFLAGS += -DHP -DF90HP
+LDFLAGS += -lm
diff --git a/LIBTOOLS/tools/lfiz/Rules.LXNAGf95 b/LIBTOOLS/tools/lfiz/Rules.LXNAGf95
new file mode 100644
index 0000000000000000000000000000000000000000..c45ad9d67238c756a746013a31da03fe9a813e07
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.LXNAGf95
@@ -0,0 +1,2 @@
+F90FLAGS += -g -O2
+CPPFLAGS += -DNAGf95
diff --git a/LIBTOOLS/tools/lfiz/Rules.LXg95 b/LIBTOOLS/tools/lfiz/Rules.LXg95
new file mode 100644
index 0000000000000000000000000000000000000000..23e9888c2ae1203bdd7e1df56995196e710fc66f
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.LXg95
@@ -0,0 +1,2 @@
+F90FLAGS += -g -O2
+CPPFLAGS += -DG95
diff --git a/LIBTOOLS/tools/lfiz/Rules.LXgfortran b/LIBTOOLS/tools/lfiz/Rules.LXgfortran
new file mode 100644
index 0000000000000000000000000000000000000000..5c077152c1a8bea38d0363c36790b84a14e59d76
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.LXgfortran
@@ -0,0 +1,2 @@
+F90FLAGS += -g -O2
+CPPFLAGS +=
diff --git a/LIBTOOLS/tools/lfiz/Rules.LXpgf90 b/LIBTOOLS/tools/lfiz/Rules.LXpgf90
new file mode 100644
index 0000000000000000000000000000000000000000..27e46a8d18a2a4d3a1133b1f7110c3dd4fc6b355
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.LXpgf90
@@ -0,0 +1,5 @@
+CPP = cpp -P -traditional -Wcomment
+F90 = pgf90
+F90FLAGS = -O
+CPPFLAGS = -Dpgf
+LDFLAGS =
diff --git a/LIBTOOLS/tools/lfiz/Rules.SGI32 b/LIBTOOLS/tools/lfiz/Rules.SGI32
new file mode 100644
index 0000000000000000000000000000000000000000..e8f96912876ca39d8dd529233c4591f0f2120e8a
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.SGI32
@@ -0,0 +1,4 @@
+F90FLAGS += -O1
+CPPFLAGS +=
+LDFLAGS +=
+
diff --git a/LIBTOOLS/tools/lfiz/Rules.SGI64 b/LIBTOOLS/tools/lfiz/Rules.SGI64
new file mode 100644
index 0000000000000000000000000000000000000000..5006a7eef28b72bc11d41b1a708b1ef0616c85f6
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.SGI64
@@ -0,0 +1,4 @@
+F90FLAGS += -g
+CPPFLAGS +=
+LDFLAGS +=
+
diff --git a/LIBTOOLS/tools/lfiz/Rules.SX5 b/LIBTOOLS/tools/lfiz/Rules.SX5
new file mode 100644
index 0000000000000000000000000000000000000000..3b1cd89b78910096c66ce196f196e5302a2c42d2
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.SX5
@@ -0,0 +1,4 @@
+F90FLAGS +=
+CPPFLAGS += -DFUJI
+LDFLAGS +=
+
diff --git a/LIBTOOLS/tools/lfiz/Rules.SX8 b/LIBTOOLS/tools/lfiz/Rules.SX8
new file mode 100644
index 0000000000000000000000000000000000000000..fe588e40f1d7c082da57bccb34be224a12e5774e
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.SX8
@@ -0,0 +1,4 @@
+F90FLAGS +=
+CPPFLAGS += -DNEC
+LDFLAGS +=
+
diff --git a/LIBTOOLS/tools/lfiz/Rules.VPP b/LIBTOOLS/tools/lfiz/Rules.VPP
new file mode 100644
index 0000000000000000000000000000000000000000..4948ad01a43ca2e0a001dbc40148ff051fcc2d58
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/Rules.VPP
@@ -0,0 +1,4 @@
+F90FLAGS +=
+CPPFLAGS +=
+LDFLAGS +=
+
diff --git a/LIBTOOLS/tools/lfiz/src/lfiz.f90 b/LIBTOOLS/tools/lfiz/src/lfiz.f90
new file mode 100644
index 0000000000000000000000000000000000000000..de9b42b530b34fe53112a708238ae02139763af2
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/src/lfiz.f90
@@ -0,0 +1,243 @@
+PROGRAM LFIZ
+#ifdef NAGf95
+ USE F90_UNIX
+#endif
+
+IMPLICIT NONE
+
+#ifndef NAGf95
+INTEGER :: IARGC
+! CRAY specific
+INTEGER :: arglen
+!!!!!!!!!!!!!!!!!
+#endif
+INTEGER :: inarg
+CHARACTER(LEN=50) :: yexe
+
+
+INTEGER, PARAMETER :: FM_FIELD_SIZE = 16
+INTEGER, PARAMETER :: ISRCLU = 11
+INTEGER, PARAMETER :: IDESTLU = 12
+INTEGER :: JPHEXT
+INTEGER :: iverb
+INTEGER :: inap ! nb d'articles prevus (utile a la creation)
+INTEGER :: inaf ! nb d'articles presents dans un fichier existant
+INTEGER :: inafdest
+
+CHARACTER(LEN=128) :: filename,DESTFNAME
+INTEGER :: JI,JJ
+INTEGER :: IRESP
+CHARACTER(LEN=FM_FIELD_SIZE),DIMENSION(:),ALLOCATABLE :: yrecfm
+INTEGER, DIMENSION(:),ALLOCATABLE :: ileng
+INTEGER(KIND=8), DIMENSION(:),ALLOCATABLE :: iwork
+
+INTEGER :: ilengs
+INTEGER :: ipos
+INTEGER :: sizemax
+
+INTEGER :: IGRID
+INTEGER :: ICOMLEN,ICH
+CHARACTER(LEN=100) :: COMMENT
+INTEGER :: I2DSIZE,I3DSIZE,DATASIZE
+INTEGER :: IDIMX,IDIMY,IDIMZ
+LOGICAL :: GUSEDIM
+INTEGER :: CPT
+INTEGER :: LFICOMP
+INTEGER :: NEWSIZE
+INTEGER :: searchndx
+INTEGER :: INDDATIM
+INARG = IARGC()
+
+#if defined(F90HP)
+#define HPINCR 1
+#else
+#define HPINCR 0
+#endif
+
+#if defined(FUJI) || defined(NAGf95) || defined(NEC) || defined(HP) || defined(pgf) || defined(G95) || defined(GFORTRAN)
+ CALL GETARG(0+HPINCR,yexe)
+ IF (LEN_TRIM(yexe) == 0) THEN
+ PRINT *, 'FATAL ERROR : Activer la macro -DF90HP dans le Makefile et recompiler'
+ STOP
+ END IF
+#else
+ CALL PXFGETARG(0,yexe,arglen,iresp)
+#endif
+! PRINT *,yexe, ' avec ',INARG,' arguments.'
+ IF (INARG == 1) THEN
+#if defined(FUJI) || defined(NAGf95) || defined(NEC) || defined(HP) || defined(pgf) || defined(G95)|| defined(GFORTRAN)
+ CALL GETARG(1+HPINCR,filename)
+#else
+ CALL PXFGETARG(1,filename,arglen,iresp)
+#endif
+ ELSE
+ PRINT *,'Usage : ', TRIM(yexe), ' [fichier lfi]'
+ STOP
+ END IF
+
+searchndx = INDEX(TRIM(filename),".lfi",.TRUE.)
+IF (searchndx /= 0 .AND. (LEN_TRIM(filename)-searchndx) == 3) THEN
+ DESTFNAME=filename(1:searchndx)//'Z.lfi'
+ELSE
+ PRINT *,'ERROR : extension invalide'
+ STOP
+END IF
+
+iverb = 0 ! verbosity level
+
+
+IDIMX = 0
+IDIMY = 0
+IDIMZ = 0
+GUSEDIM = .FALSE.
+
+CALL LFIOUV(IRESP,ISRCLU,.TRUE.,filename,'OLD',.FALSE.&
+ & ,.FALSE.,iverb,inap,inaf)
+
+CALL FMREADLFIN1(ISRCLU,'LFI_COMPRESSED',LFICOMP,iresp)
+IF (iresp == 0) THEN
+ SELECT CASE (LFICOMP)
+ CASE(1)
+ PRINT *,TRIM(filename),' : already compressed'
+ CASE(0)
+ PRINT *,'Data are in 32bits real format'
+ CASE default
+ PRINT *,'File in an unknown compression mode'
+ END SELECT
+ CALL LFIFER(IRESP,ISRCLU,'KEEP')
+ STOP 9
+END IF
+
+CALL FMREADLFIN1(ISRCLU,'JPHEXT',JPHEXT,iresp)
+IF (iresp /= 0) JPHEXT = 1
+
+! First check if IMAX,JMAX,KMAX exist in LFI file
+! to handle 3D, 2D variables -> update IDIMX,IDIMY,IDIMZ
+CALL FMREADLFIN1(ISRCLU,'IMAX',IDIMX,iresp)
+IF (iresp == 0) IDIMX = IDIMX+2*JPHEXT ! IMAX + 2*JPHEXT
+!
+CALL FMREADLFIN1(ISRCLU,'JMAX',IDIMY,iresp)
+IF (iresp == 0) IDIMY = IDIMY+2*JPHEXT ! JMAX + 2*JPHEXT
+!
+CALL FMREADLFIN1(ISRCLU,'KMAX',IDIMZ,iresp)
+IF (iresp == 0) IDIMZ = IDIMZ+2 ! KMAX + 2*JPVEXT
+
+I2DSIZE = IDIMX*IDIMY
+I3DSIZE = IDIMX*IDIMY*IDIMZ
+
+GUSEDIM = (I2DSIZE > 0)
+IF (GUSEDIM) THEN
+ PRINT *,'MESONH 3D, 2D articles DIMENSIONS used :'
+ PRINT *,'DIMX =',IDIMX
+ PRINT *,'DIMY =',IDIMY
+ PRINT *,'DIMZ =',IDIMZ ! IDIMZ may be equal to 0 (PGD files)
+ELSE
+ PRINT *,'Can''t find IMAX or JMAX variables in the file : Compression ABORTED'
+ CALL LFIFER(IRESP,ISRCLU,'KEEP')
+ STOP
+END IF
+
+
+PRINT *,'compressed file : ',DESTFNAME
+CALL LFIOUV(IRESP,IDESTLU,.TRUE.,DESTFNAME,'NEW'&
+ & ,.FALSE.,.FALSE.,iverb,inaf+1,inafdest)
+
+CALL LFIPOS(IRESP,ISRCLU)
+ALLOCATE(yrecfm(inaf))
+ALLOCATE(ileng(inaf))
+yrecfm(:) = ''
+sizemax=0
+DO ji=1,inaf
+ CALL LFICAS(IRESP,ISRCLU,yrecfm(ji),ileng(ji),ipos,.TRUE.)
+ IF (ileng(ji) > sizemax) sizemax=ileng(ji)
+END DO
+PRINT *,' Nombre total d''articles dans fichier source :', inaf
+PRINT *,'sizemax =',sizemax
+ALLOCATE(IWORK(sizemax))
+
+CPT=0
+DO JI=1,inaf
+ CALL LFILEC(IRESP,ISRCLU,yrecfm(JI),iwork,ileng(JI))
+ IGRID = IWORK(1)
+ ICOMLEN = IWORK(2)
+ IF (ICOMLEN > LEN(COMMENT)) THEN
+ PRINT *,'ERROR : COMMENT string is too small'
+ STOP
+ END IF
+
+ COMMENT = ''
+ DO JJ=1,ICOMLEN
+ ICH = iwork(2+JJ)
+ COMMENT(JJ:JJ) = CHAR(ICH)
+ END DO
+ DATASIZE=ileng(JI)-ICOMLEN-2
+
+! IF (DATASIZE == I2DSIZE .OR. DATASIZE == I3DSIZE) THEN
+ !IF (MODULO(DATASIZE,I2DSIZE) == 0) THEN
+
+ INDDATIM=INDEX(yrecfm(JI),'.DATIM')
+ IF ((MODULO(DATASIZE,I2DSIZE) == 0).AND. (TRIM(yrecfm(ji))/='ZS').AND.&
+ (INDDATIM == 0))THEN
+ CPT=CPT+1
+
+! PRINT *,'GRID=',IGRID
+! PRINT *,'COMMENT = ',TRIM(COMMENT)
+! PRINT *,'Taille data = ',DATASIZE
+ PRINT *,'***** compression de ',JI,': ',TRIM(yrecfm(JI))
+ CALL COMPRESS_FIELD(IWORK(3+ICOMLEN),IDIMX,IDIMY,DATASIZE,NEWSIZE)
+! NEWSIZE=DATASIZE
+ PRINT *,'***** ARTICLE compressé ',JI,': ',TRIM(yrecfm(JI)),', taille=',DATASIZE,',comp=',NEWSIZE
+ ileng(JI) = NEWSIZE+ICOMLEN+2
+ ELSE
+ PRINT *,'ARTICLE ',JI,': ',TRIM(yrecfm(JI)),', taille =',ileng(JI)
+ END IF
+ CALL LFIECR(iresp,IDESTLU,yrecfm(JI),iwork,ileng(JI))
+END DO
+
+IF (CPT > 0) THEN
+ ! ADD a new article to TAG the compressed file
+ IWORK(1) = 0
+ COMMENT = "Compressed articles"
+ ICOMLEN = LEN_TRIM(COMMENT)
+ IWORK(2) = ICOMLEN
+ DO JJ=1,ICOMLEN
+ IWORK(2+JJ)=ICHAR(COMMENT(JJ:JJ))
+ END DO
+ ILENGS = 3+ICOMLEN
+ IWORK(ILENGS) = 1
+ CALL LFIECR(iresp,IDESTLU,'LFI_COMPRESSED',iwork,ilengs)
+END IF
+
+
+PRINT *,' Nombre total d''articles :', inaf
+PRINT *,' Nombre d''articles compresses :', CPT
+PRINT *,'sizemax =',sizemax
+CALL LFIFER(IRESP,ISRCLU,'KEEP')
+CALL LFIFER(IRESP,IDESTLU,'KEEP')
+
+CONTAINS
+
+SUBROUTINE FMREADLFIN1(klu,hrecfm,kval,kresp)
+INTEGER, INTENT(IN) :: klu ! logical fortran unit au lfi file
+CHARACTER(LEN=*),INTENT(IN) :: hrecfm ! article name to be read
+INTEGER, INTENT(OUT) :: kval ! integer value for hrecfm article
+INTEGER, INTENT(OUT) :: kresp! return code null if OK
+!
+INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE::iwork
+INTEGER :: iresp,ilenga,iposex,icomlen
+!
+CALL LFINFO(iresp,klu,hrecfm,ilenga,iposex)
+IF (iresp /=0 .OR. ilenga == 0) THEN
+ kresp = -1
+ kval = 0
+ELSE
+ ALLOCATE(IWORK(ilenga))
+ CALL LFILEC(iresp,klu,hrecfm,iwork,ilenga)
+ icomlen = iwork(2)
+ kval = iwork(3+icomlen)
+ kresp = iresp
+ DEALLOCATE(IWORK)
+END IF
+END SUBROUTINE FMREADLFIN1
+
+END PROGRAM LFIZ
diff --git a/LIBTOOLS/tools/lfiz/src/testlibcomp.f90 b/LIBTOOLS/tools/lfiz/src/testlibcomp.f90
new file mode 100644
index 0000000000000000000000000000000000000000..b8b80e627ca3218a0473f53d52b2dd1ee9ec5023
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/src/testlibcomp.f90
@@ -0,0 +1,63 @@
+PROGRAM testlibcomp
+IMPLICIT NONE
+
+INTEGER, PARAMETER :: IDIMX = 2
+INTEGER, PARAMETER :: IDIMY = 3
+INTEGER, PARAMETER :: IDIMZ = 7
+
+REAL(KIND=8),DIMENSION(IDIMX,IDIMY,IDIMZ) :: XORGTAB,XINTAB,XOUTTAB
+INTEGER :: DATASIZE ! original size of array
+INTEGER :: COMPSIZE ! size of compressed array
+INTEGER :: JI
+INTEGER :: INBELT,ITYPECOD
+
+! Level 1 : constant level
+XORGTAB(:,:,1) = -1.5
+
+! Level 2 : 2 values in level
+XORGTAB(:,:,2) = -10.4
+XORGTAB(1,3,2) = -5.3
+
+! Level 3 : 3 values in level
+XORGTAB(:,:,3) = -8.2
+XORGTAB(2,2,3) = 10.3
+XORGTAB(1,3,3) = -9999.99
+
+! Level 4 : normal
+XORGTAB(:,:,4) = RESHAPE((/ (-(JI/1000.),JI=1,6) /),(/ IDIMX,IDIMY /))
+
+! Level 5 : Min exclus
+XORGTAB(:,:,5) = XORGTAB(:,:,4)
+XORGTAB(2,1,5) = -5.5
+
+! Level 6 : Max exclus
+XORGTAB(:,:,6) = XORGTAB(:,:,4)
+XORGTAB(2,2,6) = 10.8
+
+! Level 7 : Min et Max exclus
+XORGTAB(:,:,7) = XORGTAB(:,:,4)
+XORGTAB(2,1,7) = -5.5
+XORGTAB(2,2,7) = 10.8
+
+XINTAB(:,:,:) = XORGTAB(:,:,:)
+DATASIZE = IDIMX * IDIMY * IDIMZ
+CALL COMPRESS_FIELD(XINTAB,IDIMX,IDIMY,DATASIZE,COMPSIZE)
+PRINT *,"---> org size = ",DATASIZE,", comp size = ",COMPSIZE
+
+! Now XINTAB is compressed
+CALL GET_COMPHEADER(XINTAB,DATASIZE,INBELT,ITYPECOD)
+IF (INBELT /= DATASIZE) THEN
+ PRINT *, "Fatal error in testlibcomp !"
+ STOP
+END IF
+CALL DECOMPRESS_FIELD(XOUTTAB,DATASIZE,XINTAB,COMPSIZE,ITYPECOD)
+! XOUTTAB contains the uncompressed data
+
+DO JI=1,IDIMZ
+ PRINT *,"Level ",JI
+ PRINT *," Original : ",XORGTAB(:,:,JI)
+ PRINT *," comp/uncomp : ",XOUTTAB(:,:,JI)
+ PRINT *," Difference : ",XORGTAB(:,:,JI)-XOUTTAB(:,:,JI)
+END DO
+
+END PROGRAM testlibcomp
diff --git a/LIBTOOLS/tools/lfiz/src/unlfiz.f90 b/LIBTOOLS/tools/lfiz/src/unlfiz.f90
new file mode 100644
index 0000000000000000000000000000000000000000..bd5a3008fe8b085eb2b1b1eb501d25bf56cfe49f
--- /dev/null
+++ b/LIBTOOLS/tools/lfiz/src/unlfiz.f90
@@ -0,0 +1,198 @@
+PROGRAM UNLFIZ
+#ifdef NAGf95
+ USE F90_UNIX
+#endif
+
+IMPLICIT NONE
+
+#ifndef NAGf95
+INTEGER :: IARGC
+! CRAY specific
+INTEGER :: arglen
+!!!!!!!!!!!!!!!!!
+#endif
+INTEGER :: inarg
+CHARACTER(LEN=50) :: yexe
+
+
+INTEGER, PARAMETER :: FM_FIELD_SIZE = 16
+INTEGER, PARAMETER :: ISRCLU = 11
+INTEGER, PARAMETER :: IDESTLU = 12
+INTEGER :: iverb
+INTEGER :: inap ! nb d'articles prevus (utile a la creation)
+INTEGER :: inaf ! nb d'articles presents dans un fichier existant
+INTEGER :: inafdest
+
+CHARACTER(LEN=128) :: filename,DESTFNAME
+INTEGER :: JI,JJ
+INTEGER :: IRESP
+CHARACTER(LEN=FM_FIELD_SIZE),DIMENSION(:),ALLOCATABLE :: yrecfm
+INTEGER, DIMENSION(:),ALLOCATABLE :: ileng
+INTEGER(KIND=8), DIMENSION(:),ALLOCATABLE :: iwork,iworknew
+
+INTEGER :: ilengs
+INTEGER :: ipos
+INTEGER :: sizemax
+
+INTEGER :: ICOMLEN
+CHARACTER(LEN=100) :: COMMENT
+INTEGER :: DATASIZE,NEWSIZE
+INTEGER :: IDIMX,IDIMY,IDIMZ
+LOGICAL :: GUSEDIM
+INTEGER :: CPT
+INTEGER :: LFICOMP
+INTEGER :: searchndx
+INTEGER :: ITYPCOD
+INTEGER :: ITOTAL,ITOTALMAX
+
+INARG = IARGC()
+
+#if defined(F90HP)
+#define HPINCR 1
+#else
+#define HPINCR 0
+#endif
+
+#if defined(FUJI) || defined(NAGf95) || defined(NEC) || defined(HP) || defined(pgf) || defined(G95) || defined(GFORTRAN)
+ CALL GETARG(0+HPINCR,yexe)
+ IF (LEN_TRIM(yexe) == 0) THEN
+ PRINT *, 'FATAL ERROR : Activer la macro -DF90HP dans le Makefile et recompiler'
+ STOP
+ END IF
+#else
+ CALL PXFGETARG(0,yexe,arglen,iresp)
+#endif
+! PRINT *,yexe, ' avec ',INARG,' arguments.'
+ IF (INARG == 1) THEN
+#if defined(FUJI) || defined(NAGf95) || defined(NEC) || defined(HP) || defined(pgf) || defined(G95) || defined(GFORTRAN)
+ CALL GETARG(1+HPINCR,filename)
+#else
+ CALL PXFGETARG(1,filename,arglen,iresp)
+#endif
+ ELSE
+ PRINT *,'Usage : ', TRIM(yexe), ' [fichier lfi]'
+ STOP
+ END IF
+
+
+searchndx = INDEX(TRIM(filename),".Z.lfi",.TRUE.)
+IF (searchndx /= 0 .AND. (LEN_TRIM(filename)-searchndx) == 5) THEN
+ PRINT *,'Extension fichier compresse trouvee'
+ DESTFNAME=filename(1:searchndx)//'lfi'
+ELSE
+ PRINT *,'ERROR : extension invalide'
+ STOP
+END IF
+
+
+iverb = 0 ! verbosity level
+
+
+IDIMX = 0
+IDIMY = 0
+IDIMZ = 0
+GUSEDIM = .FALSE.
+
+CALL LFIOUV(IRESP,ISRCLU,.TRUE.,filename,'OLD',.FALSE.&
+ & ,.FALSE.,iverb,inap,inaf)
+
+CALL FMREADLFIN1(ISRCLU,'LFI_COMPRESSED',LFICOMP,iresp)
+IF (iresp /= 0 .OR. LFICOMP /= 1) THEN
+ PRINT *, 'File ',TRIM(filename),' doesn''t need to be decompressed'
+ CALL LFIFER(IRESP,ISRCLU,'KEEP')
+ STOP 9
+END IF
+
+PRINT *,'Uncompressed (but 32 bits REAL precision) file : ',DESTFNAME
+CALL LFIOUV(IRESP,IDESTLU,.TRUE.,DESTFNAME,'NEW'&
+ & ,.FALSE.,.FALSE.,iverb,inaf,inafdest)
+
+CALL LFIPOS(IRESP,ISRCLU)
+ALLOCATE(yrecfm(inaf))
+ALLOCATE(ileng(inaf))
+yrecfm(:) = ''
+sizemax=0
+DO ji=1,inaf
+ CALL LFICAS(IRESP,ISRCLU,yrecfm(ji),ileng(ji),ipos,.TRUE.)
+ IF (ileng(ji) > sizemax) sizemax=ileng(ji)
+END DO
+PRINT *,' Nombre total d''articles dans fichier source :', inaf
+PRINT *,'sizemax =',sizemax
+ALLOCATE(IWORK(sizemax))
+ITOTALMAX=sizemax
+ALLOCATE(IWORKNEW(ITOTALMAX))
+
+CPT=0
+DO JI=1,inaf
+ CALL LFILEC(IRESP,ISRCLU,yrecfm(JI),iwork,ileng(JI))
+ ICOMLEN = IWORK(2)
+ DATASIZE = ileng(JI)-ICOMLEN-2
+
+ CALL GET_COMPHEADER(IWORK(3+ICOMLEN),DATASIZE,NEWSIZE,ITYPCOD)
+ IF (NEWSIZE >= 0) THEN
+
+ CPT=CPT+1
+ ITOTAL = NEWSIZE+2+ICOMLEN
+ PRINT *,'***** ARTICLE compressé ',JI,': ',TRIM(yrecfm(JI)),', taille=',DATASIZE,',decomp=',NEWSIZE
+ ! compressed data found
+ IF (ITOTALMAX < ITOTAL) THEN
+ ITOTALMAX = ITOTAL
+ DEALLOCATE(IWORKNEW)
+ ALLOCATE(IWORKNEW(ITOTALMAX))
+ END IF
+ IWORKNEW(1:2+ICOMLEN) = IWORK(1:2+ICOMLEN)
+ CALL DECOMPRESS_FIELD(IWORKNEW(3+ICOMLEN),NEWSIZE,IWORK(3+ICOMLEN),DATASIZE,ITYPCOD)
+ CALL LFIECR(iresp,IDESTLU,yrecfm(JI),IWORKNEW,ITOTAL)
+ ELSE
+ PRINT *,'ARTICLE ',JI,': ',TRIM(yrecfm(JI)),', taille =',ileng(JI)
+ CALL LFIECR(iresp,IDESTLU,yrecfm(JI),IWORK,ileng(JI))
+ END IF
+END DO
+
+IF (CPT > 0) THEN
+ ! ADD a new article to TAG the compressed file
+ IWORK(1) = 0
+ COMMENT = "UnCompressed articles"
+ ICOMLEN = LEN_TRIM(COMMENT)
+ IWORK(2) = ICOMLEN
+ DO JJ=1,ICOMLEN
+ IWORK(2+JJ)=ICHAR(COMMENT(JJ:JJ))
+ END DO
+ ILENGS = 3+ICOMLEN
+ IWORK(ILENGS) = 2
+ CALL LFIECR(iresp,IDESTLU,'LFI_COMPRESSED',iwork,ilengs)
+END IF
+
+
+PRINT *,' Nombre total d''articles :', inaf
+PRINT *,' Nombre d''articles decompresses :', CPT
+PRINT *,'sizemax =',sizemax
+CALL LFIFER(IRESP,ISRCLU,'KEEP')
+CALL LFIFER(IRESP,IDESTLU,'KEEP')
+
+CONTAINS
+
+SUBROUTINE FMREADLFIN1(klu,hrecfm,kval,kresp)
+INTEGER, INTENT(IN) :: klu ! logical fortran unit au lfi file
+CHARACTER(LEN=*),INTENT(IN) :: hrecfm ! article name to be read
+INTEGER, INTENT(OUT) :: kval ! integer value for hrecfm article
+INTEGER, INTENT(OUT) :: kresp! return code null if OK
+!
+INTEGER(KIND=8),DIMENSION(:),ALLOCATABLE::iwork
+INTEGER :: iresp,ilenga,iposex,icomlen
+!
+CALL LFINFO(iresp,klu,hrecfm,ilenga,iposex)
+IF (iresp /=0 .OR. ilenga == 0) THEN
+ kresp = -1
+ kval = 0
+ELSE
+ ALLOCATE(IWORK(ilenga))
+ CALL LFILEC(iresp,klu,hrecfm,iwork,ilenga)
+ icomlen = iwork(2)
+ kval = iwork(3+icomlen)
+ kresp = iresp
+ DEALLOCATE(IWORK)
+END IF
+END SUBROUTINE FMREADLFIN1
+
+END PROGRAM UNLFIZ
diff --git a/LIBTOOLS/tools/radar/radarascii2llv.c b/LIBTOOLS/tools/radar/radarascii2llv.c
new file mode 100644
index 0000000000000000000000000000000000000000..ef60e240c2e0626c4cdf6e273f825300774915b5
--- /dev/null
+++ b/LIBTOOLS/tools/radar/radarascii2llv.c
@@ -0,0 +1,52 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+
+int main(int argc, char** argv) {
+// PRG=ascii2llv ; gcc -lm -Wall -o $PRG ${PRG}.c && chmod u+x $PRG
+// convertit un fichier ascii r2 en fichier llv
+// arg 1: fichier asc ; 2 fichier llv
+ int i,j;
+ int lat,lon;
+ float **val;
+ char s1[20],s2[20],s3[20];
+ FILE *fin,*fout;
+
+ if((fin=fopen(argv[1],"r"))==NULL) printf("Failed to open %s!!!\n",argv[1]);
+ if((fout=fopen(argv[2],"w"))==NULL) printf("Failed to open %s!!!\n",argv[2]);
+
+// lecture entête
+ fscanf(fin,"%s %s %s %s %s %s %s %s\n",s1,s1,s1,s1,s1,s1,s2,s3);
+
+ lat=atoi(s2);
+ lon=atoi(s3);
+ printf("%d %d\n",lat,lon);
+
+// allocation valeurs
+ val=(float **)malloc(lon*sizeof(float*));
+
+// allocation et lecture valeurs
+ for(i=0;i<lon;i++) {
+ val[i]=(float *)malloc(lat*sizeof(float));
+ for(j=0;j<lat;j++) {
+ fscanf(fin,"%s",s1);
+ val[i][j]=atof(s1);
+ }
+ }
+
+// lecture/écriture latlon
+ for(i=0;i<lon;i++) {
+ for(j=0;j<lat;j++) {
+ fscanf(fin,"%s %s",s1,s2);
+ fprintf(fout,"%s %s %f\n",s1,s2,val[i][j]);
+ }
+ free(val[i]);
+ }
+ free(val);
+
+ fclose(fin);
+ fclose(fout);
+
+ return 1;
+} /* main */
diff --git a/LIBTOOLS/tools/vergrid/Makefile b/LIBTOOLS/tools/vergrid/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..6e548da8088ce065496b83386f394afe4e1af28e
--- /dev/null
+++ b/LIBTOOLS/tools/vergrid/Makefile
@@ -0,0 +1,37 @@
+VPATH=src:$(DIR_OBJ)
+###########################
+DIR_OBJ = ./$(ARCH)
+
+include ../where.Libs
+
+include $(DIR_CONF)/config.$(ARCH)
+#include Rules.$(ARCH)
+
+INC = -I $(DIR_OBJ)
+
+PROG = vergrid
+
+OBJS = mode_pos.o
+
+%.o:%.f90 $(DIR_OBJ)/.dummy
+ $(CPP) $(INC) $(CPPFLAGS) $< > $(DIR_OBJ)/cpp_$(*F).f90
+ $(F90) $(INC) -c $(F90FLAGS) $(DIR_OBJ)/cpp_$(*F).f90 -o $(DIR_OBJ)/$(*F).o
+ -@mv *.mod $(DIR_OBJ)/. 2> /dev/null || echo pas de module dans $*.f90
+
+all: $(PROG)
+
+$(PROG): $(PROG).o $(OBJS)
+ cd $(DIR_OBJ); $(F90) $(LDFLAGS) $(patsubst $(DIR_OBJ)/%,%,$^) -o $@ $(LIBS)
+
+$(DIR_OBJ)/.dummy:
+ mkdir $(DIR_OBJ)
+ @touch $(DIR_OBJ)/.dummy
+
+clean:
+ (if [ -d $(DIR_OBJ) ] ; then cd $(DIR_OBJ); rm -f cpp_*.f90 cpp_*.f *.o *.mod ; fi)
+
+distclean:
+ (if [ -d $(DIR_OBJ) ] ; then rm -rf $(DIR_OBJ) ;fi)
+
+
+$(PROG).o: $(PROG).f90 mode_pos.o
diff --git a/LIBTOOLS/tools/vergrid/src/mode_pos.f90 b/LIBTOOLS/tools/vergrid/src/mode_pos.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2ce9b77f591829559a80661cf5985771ec6c2239
--- /dev/null
+++ b/LIBTOOLS/tools/vergrid/src/mode_pos.f90
@@ -0,0 +1,210 @@
+!-----------------------------------------------------------------
+!--------------- special set of characters for RCS information
+!-----------------------------------------------------------------
+! $Source$ $Revision$ $Date$
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+!! ###############
+ MODULE MODE_POS
+!! ###############
+!!
+INTERFACE POS
+!!
+MODULE PROCEDURE POSNAM
+MODULE PROCEDURE POSKEY
+!!
+END INTERFACE
+!!
+!!
+CONTAINS
+!!
+!! ##############################################
+ SUBROUTINE POSNAM(KULNAM,HDNAML,OFOUND,KLUOUT)
+!! ##############################################
+!!
+!!*** *POSNAM*
+!!
+!! PURPOSE
+!! -------
+! To position namelist file at correct place for reading
+! namelist CDNAML.
+!!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENT
+!! -----------------
+!!
+!! REFERENCE
+!! ----------
+!! ECMWF Research Department documentation of the IFS
+!!
+!! AUTHOR
+!! -------
+!! Mats Hamrud *ECMWF*
+!!
+!! MODIFICATIONS
+!! --------------
+!! Original : 22/06/93
+!! I. Mallet 15/10/01 adaptation to MesoNH (F90 norm)
+!------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!* 0.1 Declarations of arguments
+!
+INTEGER, INTENT(IN) :: KULNAM
+CHARACTER(LEN=*), INTENT(IN) :: HDNAML
+LOGICAL, INTENT(OUT):: OFOUND
+INTEGER, OPTIONAL,INTENT(IN) :: KLUOUT
+!
+!* 0.2 Declarations of local variables
+!
+CHARACTER(LEN=120) :: YLINE
+CHARACTER(LEN=1) :: YLTEST
+INTEGER :: ILEN,ILEY,IND1
+INTEGER :: J,JA
+!
+CHARACTER(LEN=1),DIMENSION(26) :: YLO=(/'a','b','c','d','e','f','g','h', &
+ 'i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y','z'/)
+CHARACTER(LEN=1),DIMENSION(26) :: YUP=(/'A','B','C','D','E','F','G','H', &
+ 'I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/)
+!
+!* 1. POSITION FILE
+! -------------
+!
+REWIND(KULNAM)
+ILEN=LEN(HDNAML)
+!
+search_nam : DO
+ YLINE=' '
+ READ(KULNAM,'(A)',END=100) YLINE
+ ILEY=LEN(YLINE)
+ DO J=1,ILEY
+ DO JA=1,26
+ IF (YLINE(J:J)==YLO(JA)) YLINE(J:J)=YUP(JA)
+ END DO
+ END DO
+ IND1=INDEX(YLINE,'&'//HDNAML)
+ IF(IND1.NE.0) THEN
+ YLTEST=YLINE(IND1+ILEN+1:IND1+ILEN+1)
+ IF((LLT(YLTEST,'0').OR.LGT(YLTEST,'9')).AND. &
+ (LLT(YLTEST,'A').OR.LGT(YLTEST,'Z'))) EXIT search_nam
+ END IF
+ENDDO search_nam
+!
+BACKSPACE(KULNAM)
+OFOUND=.TRUE.
+IF (PRESENT(KLUOUT)) WRITE(KLUOUT,FMT=*) '-- namelist ',HDNAML,' read'
+!
+RETURN
+!
+! end of file: namelist name not found
+100 CONTINUE
+OFOUND=.FALSE.
+IF (PRESENT(KLUOUT)) &
+WRITE(KLUOUT,FMT=*) &
+'-- namelist ',HDNAML,' not found: default values used if required'
+!------------------------------------------------------------------
+END SUBROUTINE POSNAM
+!!
+!!
+!! ################################################
+ SUBROUTINE POSKEY(KULNAM,KLUOUT,HKEYWD1,HKEYWD2)
+!! ################################################
+!!
+!!*** *POSKEY*
+!!
+!! PURPOSE
+!! -------
+! To position namelist file at correct place after reading
+! keyword HKEYWD
+!!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENT
+!! -----------------
+!!
+!! REFERENCE
+!! ----------
+!!
+!! AUTHOR
+!! -------
+!! I. Mallet *Meteo-France*
+!!
+!! MODIFICATIONS
+!! --------------
+!! Original : 15/10/01
+!------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+!* 0.1 Declarations of arguments
+!
+INTEGER, INTENT(IN) :: KULNAM
+INTEGER, INTENT(IN) :: KLUOUT
+CHARACTER(LEN=*), INTENT(IN) :: HKEYWD1
+CHARACTER(LEN=*), OPTIONAL, INTENT(IN) :: HKEYWD2
+!
+!* 0.2 Declarations of local variables
+!
+CHARACTER(LEN=120) :: YLINE
+INTEGER :: ILEN1
+!
+!
+!* 1. POSITION FILE
+! -------------
+!
+REWIND(KULNAM)
+ILEN1=LEN(HKEYWD1)
+IF (PRESENT(HKEYWD2)) ILEN2=LEN(HKEYWD2)
+!
+search_key : DO
+ YLINE=' '
+ READ(KULNAM,'(A)',END=100) YLINE
+ YLINE=ADJUSTL(YLINE)
+ IF (YLINE(1:ILEN1) .EQ. HKEYWD1(1:ILEN1)) EXIT search_key
+ENDDO search_key
+!
+WRITE(KLUOUT,FMT=*) '-- keyword ',HKEYWD1,' found'
+!
+RETURN
+!
+! end of file: keyword not found
+100 CONTINUE
+IF (.NOT.PRESENT(HKEYWD2)) THEN
+ WRITE(KLUOUT,FMT=*) '-- keyword ',HKEYWD1,' not found: program stop'
+ STOP
+ELSE
+!
+!* 2. SECOND KEYWORD: POSITION FILE
+! -----------------------------
+!
+ REWIND(KULNAM)
+ search_key2 : DO
+ YLINE=' '
+ READ(KULNAM,'(A)',END=101) YLINE
+ YLINE=ADJUSTL(YLINE)
+ IF (YLINE(1:ILEN2) .EQ. HKEYWD2(1:ILEN2)) EXIT search_key2
+ ENDDO search_key2
+ WRITE(KLUOUT,FMT=*) '-- keyword ',HKEYWD2,' found'
+ RETURN
+END IF
+! end of file: scd keyword not found
+101 CONTINUE
+WRITE(KLUOUT,FMT=*) '-- keyword ',HKEYWD2,' not found: program stop'
+STOP
+!------------------------------------------------------------------
+END SUBROUTINE POSKEY
+!
+END MODULE MODE_POS
diff --git a/LIBTOOLS/tools/vergrid/src/vergrid.f90 b/LIBTOOLS/tools/vergrid/src/vergrid.f90
new file mode 100644
index 0000000000000000000000000000000000000000..c19c801cd264892d2986420d24e4a7d05611acc8
--- /dev/null
+++ b/LIBTOOLS/tools/vergrid/src/vergrid.f90
@@ -0,0 +1,334 @@
+! ########################
+ PROGRAM COMPUTE_VER_GRID
+! ########################
+!
+!!**** *COMPUTE_VER_GRID* - compute the vertigal grid from data in namelist
+!!
+!! PURPOSE
+!! -------
+!!
+!!** METHOD
+!! ------
+!!
+!! EXTERNAL
+!! --------
+!!
+!! IMPLICIT ARGUMENTS
+!! ------------------
+!!
+!! REFERENCE
+!! ---------
+!!
+!! Book 2
+!!
+!! AUTHOR
+!! ------
+!!
+!! V.Masson Meteo-France
+!!
+!! MODIFICATIONS
+!! -------------
+!! Original 11/04/97
+!-------------------------------------------------------------------------------
+!
+!* 0. DECLARATIONS
+! ------------
+!
+#ifdef NAGf95
+USE F90_UNIX ! for GETARG
+#endif
+!
+USE MODE_POS
+!
+IMPLICIT NONE
+!
+!* 0.1 Declaration of local variables
+! ------------------------------
+!
+! Variables for input line
+CHARACTER(LEN=100) :: yexe
+integer :: ilenexe
+#ifndef NAGf95
+INTEGER :: iargc
+! CRAY specific
+INTEGER :: arglen
+!!!!!!!!!!!!!!!!!
+#endif
+INTEGER :: inarg
+!
+INTEGER, PARAMETER :: JPVEXT = 1 ! Vertical External points number
+!
+CHARACTER(LEN=28) :: YNAM1 ! name of the namelist file
+INTEGER :: INAM1
+CHARACTER(LEN=18) :: YLUOUT0 ! Name of output_listing file
+INTEGER :: ILUOUT0
+INTEGER :: IRESP
+LOGICAL :: GFOUND
+!
+INTEGER :: JK ! vertical loop control
+INTEGER :: IKB ! first inner vertical point index
+INTEGER :: IKE ! last inner vertical point index
+INTEGER :: IKU ! upper vertical point index
+INTEGER :: NKMAX ! Dimensions in z direction
+! namelist NAM_VER_GRID in PRE_REAL
+CHARACTER(LEN=6) :: YZGRID_TYPE ! type of input vertical grid
+REAL :: ZDZGRD ! vertical mesh length near the ground
+REAL :: ZDZTOP ! vertical mesh length near the top
+REAL :: ZSTRGRD ! stretching value near the ground
+REAL :: ZSTRTOP ! stretching value near the top of the model
+REAL :: ZZMAX_STRGRD ! maximum height under which the stretching is equal to
+ ! ZSTRGRD
+! namelist NAM_GRIDn_PRE in PRE_IDEAL
+CHARACTER(LEN=6) :: CZGRID_TYPE ! type of input vertical grid
+REAL :: XDZGRD ! vertical mesh length near the ground
+REAL :: XDZTOP ! vertical mesh length near the top
+REAL :: XSTRGRD ! stretching value near the ground
+REAL :: XSTRTOP ! stretching value near the top of the model
+REAL :: XZMAX_STRGRD ! maximum height under which the stretching is equal to
+REAL :: XLATOR,XLONOR ! latitude and longitude of the Origine point
+REAL :: XLATCEN,XLONCEN ! latitude and longitude of the center of the domain
+REAL :: XDELTAX,XDELTAY ! horizontal mesh lengths
+REAL :: XHMAX ! Maximum height for orography
+REAL :: NEXPX,NEXPY ! Exponents for orography in case of CZS='SINE'
+REAL :: XAX, XAY ! Widths for orography in case CZS='BELL'
+INTEGER :: NIZS , NJZS ! Localization of the center in case CZS ='BELL'
+! namelist NAM_DIMn_PRE in PRE_IDEAL
+INTEGER :: NIMAX, NJMAX ! Dimensions in x,y directions
+!
+REAL :: ZSTRETCH ! running stretching value
+LOGICAL :: LTHINSHELL ! thinshell approximation
+REAL, DIMENSION(:), ALLOCATABLE :: ZZHAT ! height level without orography
+REAL, DIMENSION(:), ALLOCATABLE :: ZSTRETCHING ! stretching between two
+! ! consecutive vertical levels
+!
+!* 0.3 Declaration of namelists
+! ------------------------
+!
+! in PRE_REAL1.nam
+NAMELIST/NAM_VER_GRID/ LTHINSHELL,NKMAX, &
+ YZGRID_TYPE,ZDZGRD,ZDZTOP,ZZMAX_STRGRD,ZSTRGRD,ZSTRTOP, &
+ NIMAX,NJMAX, &
+ XLONOR,XLATOR,XLATCEN,XLONCEN,XDELTAX,XDELTAY, &
+ XHMAX,NEXPX,NEXPY,XAX,XAY,NIZS,NJZS
+! in PRE_IDEA1.nam
+NAMELIST/NAM_DIMN_PRE/ NIMAX,NJMAX,NKMAX
+NAMELIST/NAM_GRIDN_PRE/ CZGRID_TYPE,XLONOR,XLATOR,XLONCEN,XLATCEN,XDELTAX, &
+ XDELTAY,XDZGRD,XDZTOP,XZMAX_STRGRD,XSTRGRD,XSTRTOP, &
+ XHMAX,NEXPX,NEXPY,XAX,XAY,NIZS,NJZS
+!
+NAMELIST/NAM_VER_OUT/ YZGRID_TYPE,NKMAX,ZDZGRD,ZDZTOP, &
+ ZZMAX_STRGRD,ZSTRGRD,ZSTRTOP
+!-------------------------------------------------------------------------------
+!
+!* 1. SET DEFAULT VALUES
+! ------------------
+!
+NKMAX=0
+ZDZGRD=300. ; XDZGRD=300.
+ZDZTOP=300. ; XDZTOP=300.
+ZZMAX_STRGRD=0. ; XZMAX_STRGRD=0.
+ZSTRGRD=0. ; XSTRGRD=0.
+ZSTRTOP=0. ; XSTRTOP=0.
+YZGRID_TYPE='FUNCTN' ; CZGRID_TYPE='FUNCTN'
+!
+YLUOUT0='OUTPUT_VER_GRID'
+YNAM1='VER_GRID1.nam'
+!
+!-------------------------------------------------------------------------------
+!
+!* 2. RETRIEVE THE NAME OF THE NAMELIST FILE
+! --------------------------------------
+!
+inarg = iargc()
+#if defined(F90HP)
+#define HPINCR 1
+#else
+#define HPINCR 0
+#endif
+!
+#if defined(FUJI) || defined(NAGf95) || defined(NEC) || defined(HP) || defined(pgf) || defined(G95) || defined(GFORTRAN)
+CALL GETARG(1+HPINCR,yexe)
+IF (LEN_TRIM(yexe) == 0) THEN
+ PRINT *, 'FATAL ERROR : Activer la macro -DF90HP dans le Makefile et recompiler'
+ STOP
+END IF
+#else
+CALL PXFGETARG(1,yexe,arglen,iresp)
+#endif
+YNAM1=TRIM(yexe)
+PRINT *,'Input file is ',YNAM1
+!
+!-------------------------------------------------------------------------------
+!
+!* 3. OPENNING OF THE FILES
+! ---------------------
+!
+!CALL FMATTR(YLUOUT0,YLUOUT0,ILUOUT0,IRESP)
+ILUOUT0=20
+OPEN(ILUOUT0,FILE=YLUOUT0)
+!
+!CALL FMATTR(YNAM1,YLUOUT0,INAM1,IRESP)
+INAM1=21
+OPEN(INAM1,FILE=YNAM1,STATUS='OLD',iostat=iresp)
+IF (IRESP==0) THEN
+ PRINT *,'Opening namelist file ',YNAM1
+ELSE
+ STOP 'ERROR in opening namelist file'
+ENDIF
+!
+!-------------------------------------------------------------------------------
+!
+!* 4. READING OF THE DATA
+!* 1.2 Vertical grid value
+! -------------------
+!
+CALL POSNAM(INAM1,'NAM_VER_GRID',GFOUND)
+IF (GFOUND) THEN
+ READ(INAM1,NAM_VER_GRID)
+ PRINT *, ' namelist NAM_VER_GRID read'
+ENDIF
+!
+IF(NKMAX==0) THEN
+ CALL POSNAM(INAM1,'NAM_GRIDN_PRE',GFOUND)
+ IF (GFOUND) THEN
+ READ(INAM1,NAM_GRIDN_PRE)
+ PRINT *, ' namelist NAM_GRIDN_PRE read'
+ ENDIF
+ CALL POSNAM(INAM1,'NAM_DIMN_PRE',GFOUND)
+ IF (GFOUND) THEN
+ READ(INAM1,NAM_DIMN_PRE)
+ PRINT *, ' namelist NAM_DIMN_PRE read'
+ ENDIF
+ IRESP=-1
+ENDIF
+!
+IF (NKMAX==0) THEN
+ CLOSE(INAM1)
+ STOP 'Bad initialization of vertical parameters'
+ENDIF
+!
+IF (IRESP==-1) THEN ! PRE_IDEA1.nam case
+ YZGRID_TYPE=CZGRID_TYPE
+ ZDZGRD=XDZGRD
+ ZDZTOP=XDZTOP
+ ZZMAX_STRGRD=XZMAX_STRGRD
+ ZSTRGRD=XSTRGRD
+ ZSTRTOP=XSTRTOP
+ENDIF
+!-------------------------------------------------------------------------------
+!
+!* 5. COMPUTATION OF VERTICAL STRETCHING :
+! ----------------------------------
+!
+IKB=JPVEXT+1
+IKE=NKMAX+JPVEXT
+IKU=NKMAX+2*JPVEXT
+!
+IF (.NOT. ALLOCATED(ZZHAT)) ALLOCATE(ZZHAT(IKU))
+!
+IF (YZGRID_TYPE=='FUNCTN') THEN
+!
+ IF (ABS(ZDZTOP-ZDZGRD) < 1.E-10) THEN
+ ZZHAT(:) = (/ (FLOAT(JK-IKB)*ZDZGRD, JK=1,IKU) /)
+!
+ ELSE
+ IF (ZDZGRD>ZDZTOP) THEN
+ WRITE(ILUOUT0,*) 'ZDZGRD MUST BE SMALLER THAN OR EQUAL TO ZDZTOP'
+ WRITE(ILUOUT0,*) 'CHANGE THESE PARAMETERS AND TRY AGAIN'
+ WRITE(ILUOUT0,*) 'ZDZGRD =', ZDZGRD,' ZDZTOP =', ZDZTOP
+ STOP
+ END IF
+!
+ ZZHAT(IKB-1)=-ZDZGRD
+ ZZHAT(IKB)= 0.
+ ZZHAT(IKB+1)=ZDZGRD
+ DO JK=IKB+2,IKU
+ IF ( ZZHAT(JK-1) < ZZMAX_STRGRD - 1.E-10 ) THEN
+ ZSTRETCH=ZSTRGRD/100.
+ ELSE
+ ZSTRETCH=ZSTRTOP/100.
+ END IF
+!
+ ZZHAT(JK)=ZZHAT(JK-1)+(ZZHAT(JK-1)-ZZHAT(JK-2))*(1.+ZSTRETCH)
+!
+ IF ( ZZHAT(JK)-ZZHAT(JK-1) > ZDZTOP ) THEN
+ ZZHAT(JK)=ZZHAT(JK-1)+ZDZTOP
+ END IF
+ END DO
+!
+ END IF
+!
+END IF
+!-------------------------------------------------------------------------------
+!
+!* 6. MANUALLY SPECIFIED LEVELS :
+! -------------------------
+!
+IF (YZGRID_TYPE=='MANUAL') THEN
+!
+ CALL POSKEY(INAM1,ILUOUT0,'ZHAT')
+ READ(INAM1,*) (ZZHAT(JK), JK=JPVEXT+1,NKMAX+JPVEXT+1)
+!
+ DO JK=JPVEXT,1,-1
+ ZZHAT(JK)=ZZHAT(JK+1) - (ZZHAT(JPVEXT+2)-ZZHAT(JPVEXT+1))
+ END DO
+ DO JK=NKMAX+JPVEXT+2,IKU
+ ZZHAT(JK)=ZZHAT(JK-1) + (ZZHAT(NKMAX+JPVEXT+1)-ZZHAT(NKMAX+JPVEXT))
+ END DO
+!
+END IF
+!
+!-------------------------------------------------------------------------------
+!
+!* 7. TEST ON STRETCHING :
+! ------------------
+!
+WRITE(ILUOUT0,nml=NAM_VER_OUT)
+WRITE(ILUOUT0,*)
+WRITE(ILUOUT0,1) 1,ZZHAT(1)
+WRITE(ILUOUT0,1) 2,ZZHAT(2)
+ALLOCATE(ZSTRETCHING(IKU))
+DO JK=3,IKU
+ ZSTRETCHING(JK)=(ZZHAT(JK)-ZZHAT(JK-1))/(ZZHAT(JK-1)-ZZHAT(JK-2))-1.
+ IF ( ABS(ZSTRETCHING(JK) ) > 0.20 + 1.E-10 ) THEN
+ WRITE(ILUOUT0,4) JK,ZZHAT(JK),100.*ZSTRETCHING(JK)
+ ELSE IF ( ABS(ZSTRETCHING(JK) ) > 0.07 ) THEN
+ WRITE(ILUOUT0,3) JK,ZZHAT(JK),100.*ZSTRETCHING(JK)
+ ELSE
+ WRITE(ILUOUT0,2) JK,ZZHAT(JK),100.*ZSTRETCHING(JK)
+ ENDIF
+ENDDO
+IF ( ANY(ABS(ZSTRETCHING(3:) ) > 0.20 + 1.E-10 ) ) THEN
+ WRITE(ILUOUT0,*)
+ WRITE(ILUOUT0,*) ' +-------------------------------------+'
+ WRITE(ILUOUT0,*) ' | STRETCHING TOO HIGH (MORE THAN 20%) |'
+ WRITE(ILUOUT0,*) ' +-------------------------------------+'
+ WRITE(ILUOUT0,*)
+ STOP
+END IF
+WRITE(ILUOUT0,*)
+!
+1 FORMAT('ZHAT(',I3,')=',F18.12)
+2 FORMAT('ZHAT(',I3,')=',F18.12,' (+',F6.2,' %)')
+3 FORMAT('ZHAT(',I3,')=',F18.12,' (+',F6.2,' %) WARNING: high stretching')
+4 FORMAT('ZHAT(',I3,')=',F18.12,' (+',F6.2,' %) ERROR : stretching too high')
+!
+DEALLOCATE(ZSTRETCHING)
+!-------------------------------------------------------------------------------
+!
+PRINT *, 'VERGRID completed'
+PRINT *, '=> output grid and stretching in file ', YLUOUT0
+!
+!-------------------------------------------------------------------------------
+!
+!* 8. CLOSING OF THE FILES
+! --------------------
+!
+CLOSE(INAM1)
+!CALL FMFREE(YNAM1,YLUOUT0,IRESP)
+CLOSE(ILUOUT0)
+!CALL FMFREE(YLUOUT0,YLUOUT0,IRESP)
+!
+!-------------------------------------------------------------------------------
+!
+END PROGRAM COMPUTE_VER_GRID
diff --git a/LIBTOOLS/tools/where.Libs b/LIBTOOLS/tools/where.Libs
new file mode 100644
index 0000000000000000000000000000000000000000..796c8b019de5ea2e41fbf8654dd336fbe320e080
--- /dev/null
+++ b/LIBTOOLS/tools/where.Libs
@@ -0,0 +1,29 @@
+ifeq ($(origin MNH_LIBTOOLS), undefined)
+MNH_LIBTOOLS := $(shell pwd|sed -e 's/\/tools\/.*//')
+endif
+
+ifeq ($(origin DIR_LIB), undefined)
+DIR_LIB := $(MNH_LIBTOOLS)/lib
+endif
+
+DIR_CONF:=$(MNH_LIBTOOLS)/conf
+
+DIR_LFI = $(DIR_LIB)/NEWLFI
+DIR_COMP = $(DIR_LIB)/COMPRESS
+DIR_NCAR = $(NCARG_ROOT)/lib
+DIR_DIA = $(MNH_LIBTOOLS)/tools/diachro
+DIR_V5D = $(DIR_LIB)/vis5d
+DIR_GRIB = $(DIR_LIB)/gribex_1302b
+
+LIBLFI = $(DIR_LFI)/$(ARCH)/libNEWLFI_ALL.a
+LIBCOMP = $(DIR_COMP)/$(ARCH)/liblficomp.a
+LIBNCAR = -L$(DIR_NCAR) -lncarg -lncarg_gks -lncarg_c
+LIBV5D = $(DIR_V5D)/$(ARCH)/libv5d.a
+
+LIBDIA = libdiachro.a
+LIBEXTRACT = libextract.a
+ifneq ($(strip $(VERSION)),) # string VERSION not empty
+LIBDIA = libdiachro_$(VERSION).a
+LIBEXTRACT = libextract_$(VERSION).a
+endif
+