Changeset 1186 for LMDZ4


Ignore:
Timestamp:
Jun 18, 2009, 11:20:44 AM (15 years ago)
Author:
Ehouarn Millour
Message:

Cleanup around IOIPSL, so that LMDZ dynamics may be used without IOIPSL.

  • moved ersatz IOIPSL routines (ioipsl_* , taken from IOIPSLv2_1_8, so that 'getin' function may be used even if not using the IOIPSL library) from dyn3d/dyn3dpar to bibio.
  • enclosed 'use ioipsl' instruction with #ifdef CPP_IOIPSL cpp keys.

EM

Location:
LMDZ4/branches/LMDZ4-dev/libf
Files:
1 added
2 deleted
21 edited
2 moved

Legend:

Unmodified
Added
Removed

  • LMDZ4/branches/LMDZ4-dev/libf/bibio/initdynav.F

    r1114 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    4 c
    5 c
    64      subroutine initdynav(infile,day0,anne0,tstep,t_ops,t_wrt
    75     .                     ,fileid)
    86
     7#ifdef CPP_IOIPSL
    98       USE IOIPSL
     9#endif
    1010       USE infotrac, ONLY : nqtot, ttext
    1111
    … …  
    4848#include "description.h"
    4949#include "serre.h"
     50#include "iniprint.h"
    5051
    5152C   Arguments
    … …  
    5556      real tstep, t_ops, t_wrt
    5657      integer fileid
    57       integer thoriid, zvertiid
    5858
     59#ifdef CPP_IOIPSL
     60! This routine needs IOIPSL to work
    5961C   Variables locales
    6062C
     63      integer thoriid, zvertiid
    6164      integer tau0
    6265      real zjulian
    … …  
    161164C
    162165      call histend(fileid)
     166#else
     167! tell the user this routine should be run with ioipsl
     168      write(lunout,*)"initdynav: Warning this routine should not be",
     169     &               " used without ioipsl"
     170#endif
     171! of #ifdef CPP_IOIPSL
    163172      return
    164173      end

  • LMDZ4/branches/LMDZ4-dev/libf/bibio/initfluxsto.F

    r1114 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      subroutine initfluxsto
    … …  
    66     .                    fileid,filevid,filedid)
    77
     8#ifdef CPP_IOIPSL
    89       USE IOIPSL
    9 
     10#endif
    1011      implicit none
    1112
    … …  
    4748#include "description.h"
    4849#include "serre.h"
     50#include "iniprint.h"
    4951
    5052C   Arguments
    5153C
    5254      character*(*) infile
    53       integer*4 itau
    5455      real tstep, t_ops, t_wrt
    5556      integer fileid, filevid,filedid
    56       integer ndex(1)
     57
     58#ifdef CPP_IOIPSL
     59! This routine needs IOIPSL to work
     60C   Variables locales
     61C
    5762      real nivd(1)
    58 
    59 C   Variables locales
    60 C
    6163      integer tau0
    6264      real zjulian
    … …  
    222224      endif
    223225       
     226#else
     227! tell the user this routine should be run with ioipsl
     228      write(lunout,*)"initfluxsto: Warning this routine should not be",
     229     &               " used without ioipsl"
     230#endif
     231! of #ifdef CPP_IOIPSL
    224232      return
    225233      end

  • LMDZ4/branches/LMDZ4-dev/libf/bibio/inithist.F

    r1114 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      subroutine inithist(infile,day0,anne0,tstep,t_ops,t_wrt,fileid,
    55     .                    filevid)
    66
     7#ifdef CPP_IOIPSL
    78       USE IOIPSL
     9#endif
    810       USE infotrac, ONLY : nqtot, ttext
    911
    … …  
    4850#include "description.h"
    4951#include "serre.h"
     52#include "iniprint.h"
    5053
    5154C   Arguments
    … …  
    5659      integer fileid, filevid
    5760
     61#ifdef CPP_IOIPSL
     62! This routine needs IOIPSL to work
    5863C   Variables locales
    5964C
    … …  
    181186      call histend(fileid)
    182187      call histend(filevid)
     188#else
     189! tell the user this routine should be run with ioipsl
     190      write(lunout,*)"inithist: Warning this routine should not be",
     191     &               " used without ioipsl"
     192#endif
     193! of #ifdef CPP_IOIPSL
    183194      return
    184195      end

  • LMDZ4/branches/LMDZ4-dev/libf/bibio/ioipsl_getincom.F90

    r1185 r1186  
    1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    2 ! Module and routines in this file are taken from IOIPSL
    3 ! files getincom.f90
    4 ! Module names has been changed to avoid problems
    5 ! if compiling model with IOIPSL library
    6 ! Ehouarn - March 2009
    7 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     1!
     2! $Id$
     3!
     4! Module/Routines extracted from IOIPSL v2_1_8
     5!
    86MODULE ioipsl_getincom
    9 !---------------------------------------------------------------------
    10   USE ioipsl_stringop, &
    11  &   ONLY : findpos,nocomma,cmpblank,strlowercase,gensig,find_sig
    12 !-
    13   IMPLICIT NONE
    14 !-
    15   PRIVATE
    16   PUBLIC :: getin, getin_dump
    17 !-
    18   INTERFACE getin
    19     MODULE PROCEDURE getinrs, getinr1d, getinr2d, &
    20  &                   getinis, getini1d, getini2d, &
    21  &                   getincs, getinc1d, getinc2d, &
    22  &                   getinls, getinl1d, getinl2d
    23   END INTERFACE
     7!-
     8!$Id: getincom.f90 536 2009-01-30 11:46:27Z bellier $
     9!-
     10! This software is governed by the CeCILL license
     11! See IOIPSL/IOIPSL_License_CeCILL.txt
     12!---------------------------------------------------------------------
     13USE ioipsl_errioipsl, ONLY : ipslerr
     14USE ioipsl_stringop, &
     15 &   ONLY : nocomma,cmpblank,strlowercase
     16!-
     17IMPLICIT NONE
     18!-
     19PRIVATE
     20PUBLIC :: getin, getin_dump
     21!-
     22INTERFACE getin
     23!!--------------------------------------------------------------------
     24!! The "getin" routines get a variable.
     25!! We first check if we find it in the database
     26!! and if not we get it from the run.def file.
     27!!
     28!! SUBROUTINE getin (target,ret_val)
     29!!
     30!! INPUT
     31!!
     32!! (C) target : Name of the variable
     33!!
     34!! OUTPUT
     35!!
     36!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain
     37!!                     that will contain the (standard)
     38!!                     integer/real/character/logical values
     39!!--------------------------------------------------------------------
     40  MODULE PROCEDURE getinrs, getinr1d, getinr2d, &
     41 &                 getinis, getini1d, getini2d, &
     42 &                 getincs, getinc1d, getinc2d, &
     43 &                 getinls, getinl1d, getinl2d
     44END INTERFACE
     45!-
     46!!--------------------------------------------------------------------
     47!! The "getin_dump" routine will dump the content of the database
     48!! into a file which has the same format as the run.def file.
     49!! The idea is that the user can see which parameters were used
     50!! and re-use the file for another run.
     51!!
     52!!  SUBROUTINE getin_dump (fileprefix)
     53!!
     54!! OPTIONAL INPUT argument
     55!!
     56!! (C) fileprefix : allows the user to change the name of the file
     57!!                  in which the data will be archived
     58!!--------------------------------------------------------------------
    2459!-
    2560  INTEGER,PARAMETER :: max_files=100
    … …  
    2762  INTEGER,SAVE      :: nbfiles
    2863!-
    29   INTEGER,PARAMETER :: max_lines=4000
    30   INTEGER,SAVE :: nb_lines
    31   CHARACTER(LEN=100),DIMENSION(max_lines),SAVE :: fichier
    32   INTEGER,DIMENSION(max_lines),SAVE :: targetsiglist,fromfile,compline
    33   CHARACTER(LEN=30),DIMENSION(max_lines),SAVE  :: targetlist
     64  INTEGER,PARAMETER :: i_txtslab=1000,l_n=30
     65  INTEGER,SAVE :: nb_lines,i_txtsize=0
     66  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier
     67  CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist
     68  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline
     69!-
     70  INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15
     71  CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)'
    3472!-
    3573! The data base of parameters
    3674!-
    3775  INTEGER,PARAMETER :: memslabs=200
    38   INTEGER,PARAMETER :: compress_lim = 20
     76  INTEGER,PARAMETER :: compress_lim=20
    3977!-
    4078  INTEGER,SAVE :: nb_keys=0
    4179  INTEGER,SAVE :: keymemsize=0
    42   INTEGER,SAVE,ALLOCATABLE :: keysig(:)
    43   CHARACTER(LEN=30),SAVE,ALLOCATABLE :: keystr(:)
     80!-
     81! keystr definition
     82! name of a key
    4483!-
    4584! keystatus definition
    … …  
    4887! keystatus = 3 : Some vector elements were taken from default
    4988!-
    50   INTEGER,SAVE,ALLOCATABLE :: keystatus(:)
    51 !-
    5289! keytype definition
    53 ! keytype = 1 : Interger
     90! keytype = 1 : Integer
    5491! keytype = 2 : Real
    5592! keytype = 3 : Character
    5693! keytype = 4 : Logical
    5794!-
    58   INTEGER,SAVE,ALLOCATABLE :: keytype(:)
     95  INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4
    5996!-
    6097! Allow compression for keys (only for integer and real)
    61 ! keycompress < 0 : not compresses
     98! keycompress < 0 : not compressed
    6299! keycompress > 0 : number of repeat of the value
    63100!-
    64   INTEGER,SAVE,ALLOCATABLE :: keycompress(:)
    65   INTEGER,SAVE,ALLOCATABLE :: keyfromfile(:)
    66 !-
    67   INTEGER,SAVE,ALLOCATABLE :: keymemstart(:)
    68   INTEGER,SAVE,ALLOCATABLE :: keymemlen(:)
    69 !-
    70   INTEGER,SAVE,ALLOCATABLE :: intmem(:)
    71   INTEGER,SAVE             :: intmemsize=0, intmempos=0
    72   REAL,SAVE,ALLOCATABLE :: realmem(:)
    73   INTEGER,SAVE          :: realmemsize=0, realmempos=0
    74   CHARACTER(LEN=100),SAVE,ALLOCATABLE :: charmem(:)
    75   INTEGER,SAVE             :: charmemsize=0, charmempos=0
    76   LOGICAL,SAVE,ALLOCATABLE :: logicmem(:)
    77   INTEGER,SAVE             :: logicmemsize=0, logicmempos=0
     101TYPE :: t_key
     102  CHARACTER(LEN=l_n) :: keystr
     103  INTEGER :: keystatus, keytype, keycompress, &
     104 &           keyfromfile, keymemstart, keymemlen
     105END TYPE t_key
     106!-
     107  TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab
     108!-
     109  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem
     110  INTEGER,SAVE :: i_memsize=0, i_mempos=0
     111  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem
     112  INTEGER,SAVE :: r_memsize=0, r_mempos=0
     113  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem
     114  INTEGER,SAVE :: c_memsize=0, c_mempos=0
     115  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem
     116  INTEGER,SAVE :: l_memsize=0, l_mempos=0
    78117!-
    79118CONTAINS
    80119!-
    81 !=== REAL INTERFACES
    82 !-
    83 SUBROUTINE getinrs (TARGET,ret_val)
    84 !---------------------------------------------------------------------
    85 !-  Get a real scalar. We first check if we find it
    86 !-  in the database and if not we get it from the run.def
    87 !-
    88 !-  getinr1d and getinr2d are written on the same pattern
    89 !---------------------------------------------------------------------
    90   IMPLICIT NONE
    91 !-
    92   CHARACTER(LEN=*) :: TARGET
    93   REAL :: ret_val
    94 !-
    95   REAL,DIMENSION(1) :: tmp_ret_val
    96   INTEGER :: target_sig, pos, status=0, fileorig
    97 !---------------------------------------------------------------------
    98 !-
    99 ! Compute the signature of the target
    100 !-
    101   CALL gensig (TARGET,target_sig)
     120!=== INTEGER INTERFACE
     121!-
     122SUBROUTINE getinis (target,ret_val)
     123!---------------------------------------------------------------------
     124  IMPLICIT NONE
     125!-
     126  CHARACTER(LEN=*) :: target
     127  INTEGER :: ret_val
     128!-
     129  INTEGER,DIMENSION(1) :: tmp_ret_val
     130  INTEGER :: pos,status=0,fileorig
     131!---------------------------------------------------------------------
    102132!-
    103133! Do we have this target in our database ?
    104134!-
    105   CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
     135  CALL get_findkey (1,target,pos)
    106136!-
    107137  tmp_ret_val(1) = ret_val
    … …  
    109139  IF (pos < 0) THEN
    110140!-- Get the information out of the file
    111     CALL getfilr (TARGET,status,fileorig,tmp_ret_val)
     141    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
    112142!-- Put the data into the database
    113     CALL getdbwr (TARGET,target_sig,status,fileorig,1,tmp_ret_val)
     143    CALL get_wdb &
     144 &   (target,status,fileorig,1,i_val=tmp_ret_val)
    114145  ELSE
    115146!-- Get the value out of the database
    116     CALL getdbrr (pos,1,TARGET,tmp_ret_val)
     147    CALL get_rdb (pos,1,target,i_val=tmp_ret_val)
    117148  ENDIF
    118149  ret_val = tmp_ret_val(1)
    119150!---------------------
    120 END SUBROUTINE getinrs
    121 !-
    122 !===
    123 !-
    124 SUBROUTINE getinr1d (TARGET,ret_val)
    125 !---------------------------------------------------------------------
    126 !- See getinrs for details. It is the same thing but for a vector
    127 !---------------------------------------------------------------------
    128   IMPLICIT NONE
    129 !-
    130   CHARACTER(LEN=*) :: TARGET
    131   REAL,DIMENSION(:) :: ret_val
    132 !-
    133   REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
     151END SUBROUTINE getinis
     152!===
     153SUBROUTINE getini1d (target,ret_val)
     154!---------------------------------------------------------------------
     155  IMPLICIT NONE
     156!-
     157  CHARACTER(LEN=*) :: target
     158  INTEGER,DIMENSION(:) :: ret_val
     159!-
     160  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
    134161  INTEGER,SAVE :: tmp_ret_size = 0
    135   INTEGER :: target_sig, pos, size_of_in, status=0, fileorig
    136 !---------------------------------------------------------------------
    137 !-
    138 ! Compute the signature of the target
    139 !-
    140   CALL gensig (TARGET,target_sig)
     162  INTEGER :: pos,size_of_in,status=0,fileorig
     163!---------------------------------------------------------------------
    141164!-
    142165! Do we have this target in our database ?
    143166!-
    144   CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
     167  CALL get_findkey (1,target,pos)
    145168!-
    146169  size_of_in = SIZE(ret_val)
    … …  
    155178!-
    156179  IF (pos < 0) THEN
    157 !-- Ge the information out of the file
    158     CALL getfilr (TARGET,status,fileorig,tmp_ret_val)
     180!-- Get the information out of the file
     181    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
    159182!-- Put the data into the database
    160     CALL getdbwr &
    161  &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
     183    CALL get_wdb &
     184 &   (target,status,fileorig,size_of_in,i_val=tmp_ret_val)
    162185  ELSE
    163186!-- Get the value out of the database
    164     CALL getdbrr (pos,size_of_in,TARGET,tmp_ret_val)
     187    CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val)
    165188  ENDIF
    166189  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
    167190!----------------------
    168 END SUBROUTINE getinr1d
    169 !-
    170 !===
    171 !-
    172 SUBROUTINE getinr2d (TARGET,ret_val)
    173 !---------------------------------------------------------------------
    174 !- See getinrs for details. It is the same thing but for a matrix
    175 !---------------------------------------------------------------------
    176   IMPLICIT NONE
    177 !-
    178   CHARACTER(LEN=*) :: TARGET
    179   REAL,DIMENSION(:,:) :: ret_val
    180 !-
    181   REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
     191END SUBROUTINE getini1d
     192!===
     193SUBROUTINE getini2d (target,ret_val)
     194!---------------------------------------------------------------------
     195  IMPLICIT NONE
     196!-
     197  CHARACTER(LEN=*) :: target
     198  INTEGER,DIMENSION(:,:) :: ret_val
     199!-
     200  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
    182201  INTEGER,SAVE :: tmp_ret_size = 0
    183   INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig
    184   INTEGER :: jl, jj, ji
    185 !---------------------------------------------------------------------
    186 !-
    187 ! Compute the signature of the target
    188 !-
    189   CALL gensig (TARGET,target_sig)
     202  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
     203  INTEGER :: jl,jj,ji
     204!---------------------------------------------------------------------
    190205!-
    191206! Do we have this target in our database ?
    192207!-
    193   CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
     208  CALL get_findkey (1,target,pos)
    194209!-
    195210  size_of_in = SIZE(ret_val)
    … …  
    213228!-
    214229  IF (pos < 0) THEN
    215 !-- Ge the information out of the file
    216     CALL getfilr (TARGET,status,fileorig,tmp_ret_val)
     230!-- Get the information out of the file
     231    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
    217232!-- Put the data into the database
    218     CALL getdbwr &
    219  &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
     233    CALL get_wdb &
     234 &   (target,status,fileorig,size_of_in,i_val=tmp_ret_val)
    220235  ELSE
    221236!-- Get the value out of the database
    222     CALL getdbrr (pos,size_of_in,TARGET,tmp_ret_val)
     237    CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val)
     238  ENDIF
     239!-
     240  jl=0
     241  DO jj=1,size_2
     242    DO ji=1,size_1
     243      jl=jl+1
     244      ret_val(ji,jj) = tmp_ret_val(jl)
     245    ENDDO
     246  ENDDO
     247!----------------------
     248END SUBROUTINE getini2d
     249!-
     250!=== REAL INTERFACE
     251!-
     252SUBROUTINE getinrs (target,ret_val)
     253!---------------------------------------------------------------------
     254  IMPLICIT NONE
     255!-
     256  CHARACTER(LEN=*) :: target
     257  REAL :: ret_val
     258!-
     259  REAL,DIMENSION(1) :: tmp_ret_val
     260  INTEGER :: pos,status=0,fileorig
     261!---------------------------------------------------------------------
     262!-
     263! Do we have this target in our database ?
     264!-
     265  CALL get_findkey (1,target,pos)
     266!-
     267  tmp_ret_val(1) = ret_val
     268!-
     269  IF (pos < 0) THEN
     270!-- Get the information out of the file
     271    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
     272!-- Put the data into the database
     273    CALL get_wdb &
     274 &   (target,status,fileorig,1,r_val=tmp_ret_val)
     275  ELSE
     276!-- Get the value out of the database
     277    CALL get_rdb (pos,1,target,r_val=tmp_ret_val)
     278  ENDIF
     279  ret_val = tmp_ret_val(1)
     280!---------------------
     281END SUBROUTINE getinrs
     282!===
     283SUBROUTINE getinr1d (target,ret_val)
     284!---------------------------------------------------------------------
     285  IMPLICIT NONE
     286!-
     287  CHARACTER(LEN=*) :: target
     288  REAL,DIMENSION(:) :: ret_val
     289!-
     290  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
     291  INTEGER,SAVE :: tmp_ret_size = 0
     292  INTEGER :: pos,size_of_in,status=0,fileorig
     293!---------------------------------------------------------------------
     294!-
     295! Do we have this target in our database ?
     296!-
     297  CALL get_findkey (1,target,pos)
     298!-
     299  size_of_in = SIZE(ret_val)
     300  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
     301    ALLOCATE (tmp_ret_val(size_of_in))
     302  ELSE IF (size_of_in > tmp_ret_size) THEN
     303    DEALLOCATE (tmp_ret_val)
     304    ALLOCATE (tmp_ret_val(size_of_in))
     305    tmp_ret_size = size_of_in
     306  ENDIF
     307  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
     308!-
     309  IF (pos < 0) THEN
     310!-- Get the information out of the file
     311    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
     312!-- Put the data into the database
     313    CALL get_wdb &
     314 &   (target,status,fileorig,size_of_in,r_val=tmp_ret_val)
     315  ELSE
     316!-- Get the value out of the database
     317    CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val)
     318  ENDIF
     319  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
     320!----------------------
     321END SUBROUTINE getinr1d
     322!===
     323SUBROUTINE getinr2d (target,ret_val)
     324!---------------------------------------------------------------------
     325  IMPLICIT NONE
     326!-
     327  CHARACTER(LEN=*) :: target
     328  REAL,DIMENSION(:,:) :: ret_val
     329!-
     330  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
     331  INTEGER,SAVE :: tmp_ret_size = 0
     332  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
     333  INTEGER :: jl,jj,ji
     334!---------------------------------------------------------------------
     335!-
     336! Do we have this target in our database ?
     337!-
     338  CALL get_findkey (1,target,pos)
     339!-
     340  size_of_in = SIZE(ret_val)
     341  size_1 = SIZE(ret_val,1)
     342  size_2 = SIZE(ret_val,2)
     343  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
     344    ALLOCATE (tmp_ret_val(size_of_in))
     345  ELSE IF (size_of_in > tmp_ret_size) THEN
     346    DEALLOCATE (tmp_ret_val)
     347    ALLOCATE (tmp_ret_val(size_of_in))
     348    tmp_ret_size = size_of_in
     349  ENDIF
     350!-
     351  jl=0
     352  DO jj=1,size_2
     353    DO ji=1,size_1
     354      jl=jl+1
     355      tmp_ret_val(jl) = ret_val(ji,jj)
     356    ENDDO
     357  ENDDO
     358!-
     359  IF (pos < 0) THEN
     360!-- Get the information out of the file
     361    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
     362!-- Put the data into the database
     363    CALL get_wdb &
     364 &   (target,status,fileorig,size_of_in,r_val=tmp_ret_val)
     365  ELSE
     366!-- Get the value out of the database
     367    CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val)
    223368  ENDIF
    224369!-
    … …  
    233378END SUBROUTINE getinr2d
    234379!-
    235 !===
    236 !-
    237 SUBROUTINE getfilr (TARGET,status,fileorig,ret_val)
    238 !---------------------------------------------------------------------
    239 !- Subroutine that will extract from the file the values
    240 !- attributed to the keyword target
    241 !-
    242 !- REALS
    243 !- -----
    244 !-
    245 !- target   : in  : CHARACTER(LEN=*)  target for which we will
    246 !-                                    look in the file
    247 !- status   : out : INTEGER tells us from where we obtained the data
    248 !- fileorig : out : The index of the file from which the key comes
    249 !- ret_val  : out : REAL(nb_to_ret) values read
    250 !---------------------------------------------------------------------
    251   IMPLICIT NONE
    252 !-
    253   CHARACTER(LEN=*) :: TARGET
    254   INTEGER :: status, fileorig
    255   REAL,DIMENSION(:) :: ret_val
    256 !-
    257   INTEGER :: nb_to_ret
    258   INTEGER :: it, pos, len_str, epos, ppos, int_tmp, status_cnt
    259   CHARACTER(LEN=3)  :: cnt, tl, dl
    260   CHARACTER(LEN=10) :: fmt
    261   CHARACTER(LEN=30) :: full_target
    262   CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp
    263   INTEGER :: full_target_sig
    264   REAL :: compvalue
    265 !-
    266   INTEGER,SAVE :: max_len = 0
    267   LOGICAL,SAVE,ALLOCATABLE :: found(:)
    268   LOGICAL :: def_beha
    269   LOGICAL :: compressed = .FALSE.
    270 !---------------------------------------------------------------------
    271   nb_to_ret = SIZE(ret_val)
    272   CALL getin_read
    273 !-
    274 ! Get the variables and memory we need
    275 !-
    276   IF (max_len == 0) THEN
    277     ALLOCATE(found(nb_to_ret))
    278     max_len = nb_to_ret
    279   ENDIF
    280   IF (max_len < nb_to_ret) THEN
    281     DEALLOCATE(found)
    282     ALLOCATE(found(nb_to_ret))
    283     max_len = nb_to_ret
    284   ENDIF
    285   found(:) = .FALSE.
    286 !-
    287 ! See what we find in the files read
    288 !-
    289   DO it=1,nb_to_ret
    290 !---
    291 !-
    292 !-- First try the target as it is
    293 !---
    294     full_target = TARGET(1:len_TRIM(target))
    295     CALL gensig (full_target,full_target_sig)
    296     CALL find_sig (nb_lines,targetlist,full_target, &
    297  &                 targetsiglist,full_target_sig,pos)
    298 !---
    299 !-- Another try
    300 !---
    301     IF (pos < 0) THEN
    302       WRITE(cnt,'(I3.3)') it
    303       full_target = TARGET(1:len_TRIM(target))//'__'//cnt
    304       CALL gensig (full_target,full_target_sig)
    305       CALL find_sig (nb_lines,targetlist,full_target, &
    306  &                   targetsiglist,full_target_sig,pos)
    307     ENDIF
    308 !---
    309 !-- A priori we dont know from which file the target could come.
    310 !-- Thus by default we attribute it to the first file :
    311 !---
    312     fileorig = 1
    313 !--
    314     IF (pos > 0) THEN
    315 !----
    316       found(it) = .TRUE.
    317       fileorig = fromfile(pos)
    318 !-----
    319 !---- DECODE
    320 !-----
    321       str_READ = TRIM(ADJUSTL(fichier(pos)))
    322       str_READ_lower = str_READ
    323       CALL strlowercase (str_READ_lower)
    324 !----
    325       IF (    (     (INDEX(str_READ_lower,'def') == 1)     &
    326  &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &
    327  &        .OR.(     (INDEX(str_READ_lower,'default') == 1) &
    328  &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN
    329         def_beha = .TRUE.
    330       ELSE
    331         def_beha = .FALSE.
    332         len_str = LEN_TRIM(str_READ)
    333         epos = INDEX(str_READ,'e')
    334         ppos = INDEX(str_READ,'.')
    335 !------
    336         IF (epos > 0) THEN
    337           WRITE(tl,'(I3.3)') len_str
    338           WRITE(dl,'(I3.3)') epos-ppos-1
    339           fmt='(e'//tl//'.'//dl//')'
    340           READ(str_READ,fmt) ret_val(it)
    341         ELSE IF (ppos > 0) THEN
    342           WRITE(tl,'(I3.3)') len_str
    343           WRITE(dl,'(I3.3)') len_str-ppos
    344           fmt='(f'//tl//'.'//dl//')'
    345           READ(str_READ,fmt) ret_val(it)
    346         ELSE
    347           WRITE(tl,'(I3.3)') len_str
    348           fmt = '(I'//tl//')'
    349           READ(str_READ,fmt) int_tmp
    350           ret_val(it) = REAL(int_tmp)
    351         ENDIF
    352       ENDIF
    353 !----
    354       targetsiglist(pos) = -1
    355 !-----
    356 !---- Is this the value of a compressed field ?
    357 !-----
    358       IF (compline(pos) > 0) THEN
    359         IF (compline(pos) == nb_to_ret) THEN
    360           compressed = .TRUE.
    361           compvalue = ret_val(it)
    362         ELSE
    363           WRITE(*,*) 'WARNING from getfilr'
    364           WRITE(*,*) 'For key ',TRIM(TARGET), &
    365  & ' we have a compressed field but which does not have the right size.'
    366           WRITE(*,*) 'We will try to fix that '
    367           compressed = .TRUE.
    368           compvalue = ret_val(it)
    369         ENDIF
    370       ENDIF
    371     ELSE
    372       found(it) = .FALSE.
    373     ENDIF
    374   ENDDO
    375 !--
    376 ! If this is a compressed field then we will uncompress it
    377 !--
    378   IF (compressed) THEN
    379     DO it=1,nb_to_ret
    380       IF (.NOT. found(it)) THEN
    381         ret_val(it) = compvalue
    382         found(it) = .TRUE.
    383       ENDIF
    384     ENDDO
    385   ENDIF
    386 !-
    387 ! Now we get the status for what we found
    388 !-
    389   IF (def_beha) THEN
    390     status = 2
    391     WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET)
     380!=== CHARACTER INTERFACE
     381!-
     382SUBROUTINE getincs (target,ret_val)
     383!---------------------------------------------------------------------
     384  IMPLICIT NONE
     385!-
     386  CHARACTER(LEN=*) :: target
     387  CHARACTER(LEN=*) :: ret_val
     388!-
     389  CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val
     390  INTEGER :: pos,status=0,fileorig
     391!---------------------------------------------------------------------
     392!-
     393! Do we have this target in our database ?
     394!-
     395  CALL get_findkey (1,target,pos)
     396!-
     397  tmp_ret_val(1) = ret_val
     398!-
     399  IF (pos < 0) THEN
     400!-- Get the information out of the file
     401    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
     402!-- Put the data into the database
     403    CALL get_wdb &
     404 &   (target,status,fileorig,1,c_val=tmp_ret_val)
    392405  ELSE
    393     status_cnt = 0
    394     DO it=1,nb_to_ret
    395       IF (.NOT. found(it)) THEN
    396         status_cnt = status_cnt+1
    397         IF (nb_to_ret > 1) THEN
    398           WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it
    399         ELSE
    400           str_tmp = TRIM(TARGET)
    401         ENDIF
    402         WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)
    403       ENDIF
    404     ENDDO
    405 !---
    406     IF (status_cnt == 0) THEN
    407       status = 1
    408     ELSE IF (status_cnt == nb_to_ret) THEN
    409       status = 2
    410     ELSE
    411       status = 3
    412     ENDIF
    413   ENDIF
    414 !---------------------
    415 END SUBROUTINE getfilr
    416 !-
    417 !=== INTEGER INTERFACES
    418 !-
    419 SUBROUTINE getinis (TARGET,ret_val)
    420 !---------------------------------------------------------------------
    421 !- Get a interer scalar. We first check if we find it
    422 !- in the database and if not we get it from the run.def
    423 !-
    424 !- getini1d and getini2d are written on the same pattern
    425 !---------------------------------------------------------------------
    426   IMPLICIT NONE
    427 !-
    428   CHARACTER(LEN=*) :: TARGET
    429   INTEGER :: ret_val
    430 !-
    431   INTEGER,DIMENSION(1) :: tmp_ret_val
    432   INTEGER :: target_sig, pos, status=0, fileorig
    433 !---------------------------------------------------------------------
    434 !-
    435 ! Compute the signature of the target
    436 !-
    437   CALL gensig (TARGET,target_sig)
    438 !-
    439 ! Do we have this target in our database ?
    440 !-
    441   CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
    442 !-
    443   tmp_ret_val(1) = ret_val
    444 !-
    445   IF (pos < 0) THEN
    446 !-- Ge the information out of the file
    447     CALL getfili (TARGET,status,fileorig,tmp_ret_val)
    448 !-- Put the data into the database
    449     CALL getdbwi (TARGET,target_sig,status,fileorig,1,tmp_ret_val)
    450     ELSE
    451406!-- Get the value out of the database
    452     CALL getdbri (pos,1,TARGET,tmp_ret_val)
     407    CALL get_rdb (pos,1,target,c_val=tmp_ret_val)
    453408  ENDIF
    454409  ret_val = tmp_ret_val(1)
    455410!---------------------
    456 END SUBROUTINE getinis
    457 !-
    458 !===
    459 !-
    460 SUBROUTINE getini1d (TARGET,ret_val)
    461 !---------------------------------------------------------------------
    462 !- See getinis for details. It is the same thing but for a vector
    463 !---------------------------------------------------------------------
    464   IMPLICIT NONE
    465 !-
    466   CHARACTER(LEN=*) :: TARGET
    467   INTEGER,DIMENSION(:) :: ret_val
    468 !-
    469   INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
     411END SUBROUTINE getincs
     412!===
     413SUBROUTINE getinc1d (target,ret_val)
     414!---------------------------------------------------------------------
     415  IMPLICIT NONE
     416!-
     417  CHARACTER(LEN=*) :: target
     418  CHARACTER(LEN=*),DIMENSION(:) :: ret_val
     419!-
     420  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
    470421  INTEGER,SAVE :: tmp_ret_size = 0
    471   INTEGER :: target_sig, pos, size_of_in, status=0, fileorig
    472 !---------------------------------------------------------------------
    473 !-
    474 ! Compute the signature of the target
    475 !-
    476   CALL gensig (TARGET,target_sig)
     422  INTEGER :: pos,size_of_in,status=0,fileorig
     423!---------------------------------------------------------------------
    477424!-
    478425! Do we have this target in our database ?
    479426!-
    480   CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
     427  CALL get_findkey (1,target,pos)
    481428!-
    482429  size_of_in = SIZE(ret_val)
    … …  
    491438!-
    492439  IF (pos < 0) THEN
    493 !-- Ge the information out of the file
    494     CALL getfili (TARGET,status,fileorig,tmp_ret_val)
     440!-- Get the information out of the file
     441    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
    495442!-- Put the data into the database
    496     CALL getdbwi &
    497  &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
     443    CALL get_wdb &
     444 &   (target,status,fileorig,size_of_in,c_val=tmp_ret_val)
    498445  ELSE
    499446!-- Get the value out of the database
    500     CALL getdbri (pos,size_of_in,TARGET,tmp_ret_val)
     447    CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val)
    501448  ENDIF
    502449  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
    503450!----------------------
    504 END SUBROUTINE getini1d
    505 !-
    506 !===
    507 !-
    508 SUBROUTINE getini2d (TARGET,ret_val)
    509 !---------------------------------------------------------------------
    510 !- See getinis for details. It is the same thing but for a matrix
    511 !---------------------------------------------------------------------
    512   IMPLICIT NONE
    513 !-
    514   CHARACTER(LEN=*) :: TARGET
    515   INTEGER,DIMENSION(:,:) :: ret_val
    516 !-
    517   INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
     451END SUBROUTINE getinc1d
     452!===
     453SUBROUTINE getinc2d (target,ret_val)
     454!---------------------------------------------------------------------
     455  IMPLICIT NONE
     456!-
     457  CHARACTER(LEN=*) :: target
     458  CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val
     459!-
     460  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
    518461  INTEGER,SAVE :: tmp_ret_size = 0
    519   INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig
    520   INTEGER :: jl, jj, ji
    521 !---------------------------------------------------------------------
    522 !-
    523 ! Compute the signature of the target
    524 !-
    525   CALL gensig (TARGET,target_sig)
     462  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
     463  INTEGER :: jl,jj,ji
     464!---------------------------------------------------------------------
    526465!-
    527466! Do we have this target in our database ?
    528467!-
    529   CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
     468  CALL get_findkey (1,target,pos)
    530469!-
    531470  size_of_in = SIZE(ret_val)
    … …  
    549488!-
    550489  IF (pos < 0) THEN
    551 !-- Ge the information out of the file
    552     CALL getfili (TARGET,status,fileorig,tmp_ret_val)
     490!-- Get the information out of the file
     491    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
    553492!-- Put the data into the database
    554     CALL getdbwi &
    555  &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
     493    CALL get_wdb &
     494 &   (target,status,fileorig,size_of_in,c_val=tmp_ret_val)
    556495  ELSE
    557496!-- Get the value out of the database
    558     CALL getdbri (pos,size_of_in,TARGET,tmp_ret_val)
     497    CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val)
    559498  ENDIF
    560499!-
    … …  
    567506  ENDDO
    568507!----------------------
    569 END SUBROUTINE getini2d
    570 !-
    571 !===
    572 !-
    573 SUBROUTINE getfili (TARGET,status,fileorig,ret_val)
    574 !---------------------------------------------------------------------
    575 !- Subroutine that will extract from the file the values
    576 !- attributed to the keyword target
    577 !-
    578 !- INTEGER
    579 !- -------
    580 !-
    581 !- target   : in  : CHARACTER(LEN=*)  target for which we will
    582 !-                                    look in the file
    583 !- status   : out : INTEGER tells us from where we obtained the data
    584 !- fileorig : out : The index of the file from which the key comes
    585 !- ret_val  : out : INTEGER(nb_to_ret) values read
    586 !---------------------------------------------------------------------
    587   IMPLICIT NONE
    588 !-
    589   CHARACTER(LEN=*) :: TARGET
    590   INTEGER :: status, fileorig
    591   INTEGER :: ret_val(:)
    592 !-
    593   INTEGER :: nb_to_ret
    594   INTEGER :: it, pos, len_str, status_cnt
    595   CHARACTER(LEN=3)  :: cnt, chlen
    596   CHARACTER(LEN=10) ::  fmt
    597   CHARACTER(LEN=30) :: full_target
    598   CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp
    599   INTEGER :: full_target_sig
    600   INTEGER :: compvalue
    601 !-
    602   INTEGER,SAVE :: max_len = 0
    603   LOGICAL,SAVE,ALLOCATABLE :: found(:)
    604   LOGICAL :: def_beha
    605   LOGICAL :: compressed = .FALSE.
    606 !---------------------------------------------------------------------
    607   nb_to_ret = SIZE(ret_val)
    608   CALL getin_read
    609 !-
    610 ! Get the variables and memory we need
    611 !-
    612   IF (max_len == 0) THEN
    613     ALLOCATE(found(nb_to_ret))
    614     max_len = nb_to_ret
    615   ENDIF
    616   IF (max_len < nb_to_ret) THEN
    617     DEALLOCATE(found)
    618     ALLOCATE(found(nb_to_ret))
    619     max_len = nb_to_ret
    620   ENDIF
    621   found(:) = .FALSE.
    622 !-
    623 ! See what we find in the files read
    624 !-
    625   DO it=1,nb_to_ret
    626 !---
    627 !-- First try the target as it is
    628 !---
    629     full_target = TARGET(1:len_TRIM(target))
    630     CALL gensig (full_target,full_target_sig)
    631     CALL find_sig (nb_lines,targetlist,full_target, &
    632  &                 targetsiglist,full_target_sig,pos)
    633 !---
    634 !-- Another try
    635 !---
    636     IF (pos < 0) THEN
    637       WRITE(cnt,'(I3.3)') it
    638       full_target = TARGET(1:len_TRIM(target))//'__'//cnt
    639       CALL gensig (full_target,full_target_sig)
    640       CALL find_sig (nb_lines,targetlist,full_target, &
    641  &                   targetsiglist,full_target_sig,pos)
    642     ENDIF
    643 !---
    644 !-- A priori we dont know from which file the target could come.
    645 !-- Thus by default we attribute it to the first file :
    646 !---
    647     fileorig = 1
    648 !-
    649     IF (pos > 0) THEN
    650 !-----
    651       found(it) = .TRUE.
    652       fileorig = fromfile(pos)
    653 !-----
    654 !---- DECODE
    655 !----
    656       str_READ = TRIM(ADJUSTL(fichier(pos)))
    657       str_READ_lower = str_READ
    658       CALL strlowercase (str_READ_lower)
    659 !-----
    660       IF (    (     (INDEX(str_READ_lower,'def') == 1)     &
    661  &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &
    662  &        .OR.(     (INDEX(str_READ_lower,'default') == 1) &
    663  &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN
    664         def_beha = .TRUE.
    665       ELSE
    666         def_beha = .FALSE.
    667         len_str = LEN_TRIM(str_READ)
    668         WRITE(chlen,'(I3.3)') len_str
    669         fmt = '(I'//chlen//')'
    670         READ(str_READ,fmt) ret_val(it)
    671       ENDIF
    672 !-----
    673       targetsiglist(pos) = -1
    674 !-----
    675 !---- Is this the value of a compressed field ?
    676 !-----
    677       IF (compline(pos) > 0) THEN
    678         IF (compline(pos) == nb_to_ret) THEN
    679           compressed = .TRUE.
    680           compvalue = ret_val(it)
    681         ELSE
    682           WRITE(*,*) 'WARNING from getfilr'
    683           WRITE(*,*) 'For key ',TRIM(TARGET), &
    684  & ' we have a compressed field but which does not have the right size.'
    685           WRITE(*,*) 'We will try to fix that '
    686           compressed = .TRUE.
    687           compvalue = ret_val(it)
    688         ENDIF
    689       ENDIF
    690     ELSE
    691       found(it) = .FALSE.
    692     ENDIF
    693   ENDDO
    694 !-
    695 ! If this is a compressed field then we will uncompress it
    696 !-
    697   IF (compressed) THEN
    698     DO it=1,nb_to_ret
    699       IF (.NOT. found(it)) THEN
    700         ret_val(it) = compvalue
    701         found(it) = .TRUE.
    702       ENDIF
    703     ENDDO
    704   ENDIF
    705 !-
    706 ! Now we get the status for what we found
    707 !-
    708   IF (def_beha) THEN
    709     status = 2
    710     WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET)
    711   ELSE
    712     status_cnt = 0
    713     DO it=1,nb_to_ret
    714       IF (.NOT. found(it)) THEN
    715         status_cnt = status_cnt+1
    716         IF (nb_to_ret > 1) THEN
    717           WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it
    718         ELSE
    719           str_tmp = TRIM(TARGET)
    720         ENDIF
    721         WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)
    722       ENDIF
    723     ENDDO
    724 !---
    725     IF (status_cnt == 0) THEN
    726       status = 1
    727     ELSE IF (status_cnt == nb_to_ret) THEN
    728       status = 2
    729     ELSE
    730       status = 3
    731     ENDIF
    732   ENDIF
    733 !---------------------
    734 END SUBROUTINE getfili
    735 !-
    736 !=== CHARACTER INTERFACES
    737 !-
    738 SUBROUTINE getincs (TARGET,ret_val)
    739 !---------------------------------------------------------------------
    740 !- Get a CHARACTER scalar. We first check if we find it
    741 !- in the database and if not we get it from the run.def
    742 !-
    743 !- getinc1d and getinc2d are written on the same pattern
    744 !---------------------------------------------------------------------
    745   IMPLICIT NONE
    746 !-
    747   CHARACTER(LEN=*) :: TARGET
    748   CHARACTER(LEN=*) :: ret_val
    749 !-
    750   CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val
    751   INTEGER :: target_sig, pos, status=0, fileorig
    752 !---------------------------------------------------------------------
    753 !-
    754 ! Compute the signature of the target
    755 !-
    756   CALL gensig (TARGET,target_sig)
     508END SUBROUTINE getinc2d
     509!-
     510!=== LOGICAL INTERFACE
     511!-
     512SUBROUTINE getinls (target,ret_val)
     513!---------------------------------------------------------------------
     514  IMPLICIT NONE
     515!-
     516  CHARACTER(LEN=*) :: target
     517  LOGICAL :: ret_val
     518!-
     519  LOGICAL,DIMENSION(1) :: tmp_ret_val
     520  INTEGER :: pos,status=0,fileorig
     521!---------------------------------------------------------------------
    757522!-
    758523! Do we have this target in our database ?
    759524!-
    760   CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
     525  CALL get_findkey (1,target,pos)
    761526!-
    762527  tmp_ret_val(1) = ret_val
    763528!-
    764529  IF (pos < 0) THEN
    765 !-- Ge the information out of the file
    766     CALL getfilc (TARGET,status,fileorig,tmp_ret_val)
     530!-- Get the information out of the file
     531    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
    767532!-- Put the data into the database
    768     CALL getdbwc (TARGET,target_sig,status,fileorig,1,tmp_ret_val)
     533    CALL get_wdb &
     534 &   (target,status,fileorig,1,l_val=tmp_ret_val)
    769535  ELSE
    770536!-- Get the value out of the database
    771     CALL getdbrc (pos,1,TARGET,tmp_ret_val)
     537    CALL get_rdb (pos,1,target,l_val=tmp_ret_val)
    772538  ENDIF
    773539  ret_val = tmp_ret_val(1)
    774540!---------------------
    775 END SUBROUTINE getincs
    776 !-
    777 !===
    778 !-
    779 SUBROUTINE getinc1d (TARGET,ret_val)
    780 !---------------------------------------------------------------------
    781 !- See getincs for details. It is the same thing but for a vector
    782 !---------------------------------------------------------------------
    783   IMPLICIT NONE
    784 !-
    785   CHARACTER(LEN=*) :: TARGET
    786   CHARACTER(LEN=*),DIMENSION(:) :: ret_val
    787 !-
    788   CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
     541END SUBROUTINE getinls
     542!===
     543SUBROUTINE getinl1d (target,ret_val)
     544!---------------------------------------------------------------------
     545  IMPLICIT NONE
     546!-
     547  CHARACTER(LEN=*) :: target
     548  LOGICAL,DIMENSION(:) :: ret_val
     549!-
     550  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
    789551  INTEGER,SAVE :: tmp_ret_size = 0
    790   INTEGER :: target_sig, pos, size_of_in, status=0, fileorig
    791 !---------------------------------------------------------------------
    792 !-
    793 ! Compute the signature of the target
    794 !-
    795   CALL gensig (TARGET,target_sig)
     552  INTEGER :: pos,size_of_in,status=0,fileorig
     553!---------------------------------------------------------------------
    796554!-
    797555! Do we have this target in our database ?
    798556!-
    799   CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
     557  CALL get_findkey (1,target,pos)
    800558!-
    801559  size_of_in = SIZE(ret_val)
    … …  
    810568!-
    811569  IF (pos < 0) THEN
    812 !-- Ge the information out of the file
    813     CALL getfilc (TARGET,status,fileorig,tmp_ret_val)
     570!-- Get the information out of the file
     571    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
    814572!-- Put the data into the database
    815     CALL getdbwc &
    816  &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
     573    CALL get_wdb &
     574 &   (target,status,fileorig,size_of_in,l_val=tmp_ret_val)
    817575  ELSE
    818576!-- Get the value out of the database
    819     CALL getdbrc (pos,size_of_in,TARGET,tmp_ret_val)
     577    CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val)
    820578  ENDIF
    821579  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
    822580!----------------------
    823 END SUBROUTINE getinc1d
    824 !-
    825 !===
    826 !-
    827 SUBROUTINE getinc2d (TARGET,ret_val)
    828 !---------------------------------------------------------------------
    829 !- See getincs for details. It is the same thing but for a matrix
    830 !---------------------------------------------------------------------
    831   IMPLICIT NONE
    832 !-
    833   CHARACTER(LEN=*) :: TARGET
    834   CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val
    835 !-
    836   CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
     581END SUBROUTINE getinl1d
     582!===
     583SUBROUTINE getinl2d (target,ret_val)
     584!---------------------------------------------------------------------
     585  IMPLICIT NONE
     586!-
     587  CHARACTER(LEN=*) :: target
     588  LOGICAL,DIMENSION(:,:) :: ret_val
     589!-
     590  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
    837591  INTEGER,SAVE :: tmp_ret_size = 0
    838   INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig
     592  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
    839593  INTEGER :: jl,jj,ji
    840594!---------------------------------------------------------------------
    841595!-
    842 ! Compute the signature of the target
    843 !-
    844   CALL gensig (TARGET,target_sig)
    845 !-
    846596! Do we have this target in our database ?
    847597!-
    848   CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
     598  CALL get_findkey (1,target,pos)
    849599!-
    850600  size_of_in = SIZE(ret_val)
    … …  
    868618!-
    869619  IF (pos < 0) THEN
    870 !-- Ge the information out of the file
    871     CALL getfilc (TARGET,status,fileorig,tmp_ret_val)
     620!-- Get the information out of the file
     621    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
    872622!-- Put the data into the database
    873     CALL getdbwc &
    874  &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
     623    CALL get_wdb &
     624 &   (target,status,fileorig,size_of_in,l_val=tmp_ret_val)
    875625  ELSE
    876626!-- Get the value out of the database
    877     CALL getdbrc (pos,size_of_in,TARGET,tmp_ret_val)
    878   ENDIF
    879 !-
    880   jl=0
    881   DO jj=1,size_2
    882     DO ji=1,size_1
    883       jl=jl+1
    884       ret_val(ji,jj) = tmp_ret_val(jl)
    885     ENDDO
    886   ENDDO
    887 !----------------------
    888 END SUBROUTINE getinc2d
    889 !-
    890 !===
    891 !-
    892 SUBROUTINE getfilc (TARGET,status,fileorig,ret_val)
    893 !---------------------------------------------------------------------
    894 !- Subroutine that will extract from the file the values
    895 !- attributed to the keyword target
    896 !-
    897 !- CHARACTER
    898 !- ---------
    899 !-
    900 !- target   : in  : CHARACTER(LEN=*)  target for which we will
    901 !-                                    look in the file
    902 !- status   : out : INTEGER tells us from where we obtained the data
    903 !- fileorig : out : The index of the file from which the key comes
    904 !- ret_val  : out : CHARACTER(nb_to_ret) values read
    905 !---------------------------------------------------------------------
    906   IMPLICIT NONE
    907 !-
    908 !-
    909   CHARACTER(LEN=*) :: TARGET
    910   INTEGER :: status, fileorig
    911   CHARACTER(LEN=*),DIMENSION(:) :: ret_val
    912 !-
    913   INTEGER :: nb_to_ret
    914   INTEGER :: it, pos, len_str, status_cnt
    915   CHARACTER(LEN=3)  :: cnt
    916   CHARACTER(LEN=30) :: full_target
    917   CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp
    918   INTEGER :: full_target_sig
    919 !-
    920   INTEGER,SAVE :: max_len = 0
    921   LOGICAL,DIMENSION(:),SAVE,ALLOCATABLE :: found
    922   LOGICAL :: def_beha
    923 !---------------------------------------------------------------------
    924   nb_to_ret = SIZE(ret_val)
    925   CALL getin_read
    926 !-
    927 ! Get the variables and memory we need
    928 !-
    929   IF (max_len == 0) THEN
    930     ALLOCATE(found(nb_to_ret))
    931     max_len = nb_to_ret
    932   ENDIF
    933   IF (max_len < nb_to_ret) THEN
    934     DEALLOCATE(found)
    935     ALLOCATE(found(nb_to_ret))
    936     max_len = nb_to_ret
    937   ENDIF
    938   found(:) = .FALSE.
    939 !-
    940 ! See what we find in the files read
    941 !-
    942   DO it=1,nb_to_ret
    943 !---
    944 !-- First try the target as it is
    945     full_target = TARGET(1:len_TRIM(target))
    946     CALL gensig (full_target,full_target_sig)
    947     CALL find_sig (nb_lines,targetlist,full_target, &
    948  &                 targetsiglist,full_target_sig,pos)
    949 !---
    950 !-- Another try
    951 !---
    952     IF (pos < 0) THEN
    953       WRITE(cnt,'(I3.3)') it
    954       full_target = TARGET(1:len_TRIM(target))//'__'//cnt
    955       CALL gensig (full_target,full_target_sig)
    956       CALL find_sig (nb_lines,targetlist,full_target, &
    957  &                   targetsiglist,full_target_sig,pos)
    958     ENDIF
    959 !---
    960 !-- A priori we dont know from which file the target could come.
    961 !-- Thus by default we attribute it to the first file :
    962 !---
    963     fileorig = 1
    964 !---
    965     IF (pos > 0) THEN
    966 !-----
    967       found(it) = .TRUE.
    968       fileorig = fromfile(pos)
    969 !-----
    970 !---- DECODE
    971 !-----
    972       str_READ = TRIM(ADJUSTL(fichier(pos)))
    973       str_READ_lower = str_READ
    974       CALL strlowercase (str_READ_lower)
    975 !-----
    976       IF (    (     (INDEX(str_READ_lower,'def') == 1)     &
    977  &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &
    978  &        .OR.(     (INDEX(str_READ_lower,'default') == 1) &
    979  &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN
    980         def_beha = .TRUE.
    981       ELSE
    982         def_beha = .FALSE.
    983         len_str = LEN_TRIM(str_READ)
    984         ret_val(it) = str_READ(1:len_str)
    985       ENDIF
    986 !-----
    987       targetsiglist(pos) = -1
    988 !-----
    989     ELSE
    990       found(it) = .FALSE.
    991     ENDIF
    992   ENDDO
    993 !-
    994 ! Now we get the status for what we found
    995 !-
    996   IF (def_beha) THEN
    997     status = 2
    998     WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET)
    999   ELSE
    1000     status_cnt = 0
    1001     DO it=1,nb_to_ret
    1002       IF (.NOT. found(it)) THEN
    1003         status_cnt = status_cnt+1
    1004         IF (nb_to_ret > 1) THEN
    1005           WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it
    1006         ELSE
    1007           str_tmp = TARGET(1:len_TRIM(target))
    1008         ENDIF
    1009         WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)
    1010       ENDIF
    1011     ENDDO
    1012 !-
    1013     IF (status_cnt == 0) THEN
    1014       status = 1
    1015     ELSE IF (status_cnt == nb_to_ret) THEN
    1016       status = 2
    1017     ELSE
    1018       status = 3
    1019     ENDIF
    1020   ENDIF
    1021 !---------------------
    1022 END SUBROUTINE getfilc
    1023 !-
    1024 !=== LOGICAL INTERFACES
    1025 !-
    1026 SUBROUTINE getinls (TARGET,ret_val)
    1027 !---------------------------------------------------------------------
    1028 !- Get a logical scalar. We first check if we find it
    1029 !- in the database and if not we get it from the run.def
    1030 !-
    1031 !- getinl1d and getinl2d are written on the same pattern
    1032 !---------------------------------------------------------------------
    1033   IMPLICIT NONE
    1034 !-
    1035   CHARACTER(LEN=*) :: TARGET
    1036   LOGICAL :: ret_val
    1037 !-
    1038   LOGICAL,DIMENSION(1) :: tmp_ret_val
    1039   INTEGER :: target_sig, pos, status=0, fileorig
    1040 !---------------------------------------------------------------------
    1041 !-
    1042 ! Compute the signature of the target
    1043 !-
    1044   CALL gensig (TARGET,target_sig)
    1045 !-
    1046 ! Do we have this target in our database ?
    1047 !-
    1048   CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
    1049 !-
    1050   tmp_ret_val(1) = ret_val
    1051 !-
    1052   IF (pos < 0) THEN
    1053 !-- Ge the information out of the file
    1054     CALL getfill (TARGET,status,fileorig,tmp_ret_val)
    1055 !-- Put the data into the database
    1056     CALL getdbwl (TARGET,target_sig,status,fileorig,1,tmp_ret_val)
    1057   ELSE
    1058 !-- Get the value out of the database
    1059     CALL getdbrl (pos,1,TARGET,tmp_ret_val)
    1060   ENDIF
    1061   ret_val = tmp_ret_val(1)
    1062 !---------------------
    1063 END SUBROUTINE getinls
    1064 !-
    1065 !===
    1066 !-
    1067 SUBROUTINE getinl1d (TARGET,ret_val)
    1068 !---------------------------------------------------------------------
    1069 !- See getinls for details. It is the same thing but for a vector
    1070 !---------------------------------------------------------------------
    1071   IMPLICIT NONE
    1072 !-
    1073   CHARACTER(LEN=*) :: TARGET
    1074   LOGICAL,DIMENSION(:) :: ret_val
    1075 !-
    1076   LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
    1077   INTEGER,SAVE :: tmp_ret_size = 0
    1078   INTEGER :: target_sig, pos, size_of_in, status=0, fileorig
    1079 !---------------------------------------------------------------------
    1080 !-
    1081 ! Compute the signature of the target
    1082 !-
    1083   CALL gensig (TARGET,target_sig)
    1084 !-
    1085 ! Do we have this target in our database ?
    1086 !-
    1087   CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
    1088 !-
    1089   size_of_in = SIZE(ret_val)
    1090   IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
    1091     ALLOCATE (tmp_ret_val(size_of_in))
    1092   ELSE IF (size_of_in > tmp_ret_size) THEN
    1093     DEALLOCATE (tmp_ret_val)
    1094     ALLOCATE (tmp_ret_val(size_of_in))
    1095     tmp_ret_size = size_of_in
    1096   ENDIF
    1097   tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
    1098 !-
    1099   IF (pos < 0) THEN
    1100 !-- Ge the information out of the file
    1101     CALL getfill (TARGET,status,fileorig,tmp_ret_val)
    1102 !-- Put the data into the database
    1103     CALL getdbwl &
    1104  &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
    1105   ELSE
    1106 !-- Get the value out of the database
    1107     CALL getdbrl (pos,size_of_in,TARGET,tmp_ret_val)
    1108   ENDIF
    1109   ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
    1110 !----------------------
    1111 END SUBROUTINE getinl1d
    1112 !-
    1113 !===
    1114 !-
    1115 SUBROUTINE getinl2d (TARGET,ret_val)
    1116 !---------------------------------------------------------------------
    1117 !- See getinls for details. It is the same thing but for a matrix
    1118 !---------------------------------------------------------------------
    1119   IMPLICIT NONE
    1120 !-
    1121   CHARACTER(LEN=*) :: TARGET
    1122   LOGICAL,DIMENSION(:,:) :: ret_val
    1123 !-
    1124   LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
    1125   INTEGER,SAVE :: tmp_ret_size = 0
    1126   INTEGER :: target_sig,pos,size_of_in,size_1,size_2,status=0,fileorig
    1127   INTEGER :: jl,jj,ji
    1128 !---------------------------------------------------------------------
    1129 !-
    1130 ! Compute the signature of the target
    1131 !-
    1132   CALL gensig (TARGET,target_sig)
    1133 !-
    1134 ! Do we have this target in our database ?
    1135 !-
    1136   CALL find_sig (nb_keys,keystr,target,keysig,target_sig,pos)
    1137 !-
    1138   size_of_in = SIZE(ret_val)
    1139   size_1 = SIZE(ret_val,1)
    1140   size_2 = SIZE(ret_val,2)
    1141   IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
    1142     ALLOCATE (tmp_ret_val(size_of_in))
    1143   ELSE IF (size_of_in > tmp_ret_size) THEN
    1144     DEALLOCATE (tmp_ret_val)
    1145     ALLOCATE (tmp_ret_val(size_of_in))
    1146     tmp_ret_size = size_of_in
    1147   ENDIF
    1148 !-
    1149   jl=0
    1150   DO jj=1,size_2
    1151     DO ji=1,size_1
    1152       jl=jl+1
    1153       tmp_ret_val(jl) = ret_val(ji,jj)
    1154     ENDDO
    1155   ENDDO
    1156 !-
    1157   IF (pos < 0) THEN
    1158 !-- Ge the information out of the file
    1159     CALL getfill (TARGET,status,fileorig,tmp_ret_val)
    1160 !-- Put the data into the database
    1161     CALL getdbwl &
    1162  &   (TARGET,target_sig,status,fileorig,size_of_in,tmp_ret_val)
    1163   ELSE
    1164 !-- Get the value out of the database
    1165     CALL getdbrl (pos,size_of_in,TARGET,tmp_ret_val)
     627    CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val)
    1166628  ENDIF
    1167629!-
    … …  
    1176638END SUBROUTINE getinl2d
    1177639!-
    1178 !===
    1179 !-
    1180 SUBROUTINE getfill (TARGET,status,fileorig,ret_val)
     640!=== Generic file/database INTERFACE
     641!-
     642SUBROUTINE get_fil (target,status,fileorig,i_val,r_val,c_val,l_val)
    1181643!---------------------------------------------------------------------
    1182644!- Subroutine that will extract from the file the values
    1183645!- attributed to the keyword target
    1184646!-
    1185 !- LOGICAL
    1186 !- -------
    1187 !-
    1188 !- target   : in  : CHARACTER(LEN=*)  target for which we will
    1189 !-                                    look in the file
    1190 !- status   : out : INTEGER tells us from where we obtained the data
    1191 !- fileorig : out : The index of the file from which the key comes
    1192 !- ret_val  : out : LOGICAL(nb_to_ret) values read
    1193 !---------------------------------------------------------------------
    1194   IMPLICIT NONE
    1195 !-
    1196   CHARACTER(LEN=*) :: TARGET
    1197   INTEGER :: status, fileorig
    1198   LOGICAL,DIMENSION(:) :: ret_val
    1199 !-
    1200   INTEGER :: nb_to_ret
    1201   INTEGER :: it, pos, len_str, ipos_tr, ipos_fl, status_cnt
    1202   CHARACTER(LEN=3)  :: cnt
    1203   CHARACTER(LEN=30) :: full_target
    1204   CHARACTER(LEN=80) :: str_READ, str_READ_lower, str_tmp
    1205   INTEGER :: full_target_sig
    1206 !-
    1207   INTEGER,SAVE :: max_len = 0
    1208   LOGICAL,DIMENSION(:),SAVE,ALLOCATABLE :: found
    1209   LOGICAL :: def_beha
    1210 !---------------------------------------------------------------------
    1211   nb_to_ret = SIZE(ret_val)
     647!- (C) target    : target for which we will look in the file
     648!- (I) status    : tells us from where we obtained the data
     649!- (I) fileorig  : index of the file from which the key comes
     650!- (I) i_val(:)  : INTEGER(nb_to_ret)   values
     651!- (R) r_val(:)  : REAL(nb_to_ret)      values
     652!- (L) l_val(:)  : LOGICAL(nb_to_ret)   values
     653!- (C) c_val(:)  : CHARACTER(nb_to_ret) values
     654!---------------------------------------------------------------------
     655  IMPLICIT NONE
     656!-
     657  CHARACTER(LEN=*) :: target
     658  INTEGER,INTENT(OUT) :: status,fileorig
     659  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
     660  REAL,DIMENSION(:),OPTIONAL             :: r_val
     661  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
     662  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
     663!-
     664  INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err
     665  CHARACTER(LEN=n_d_fmt)  :: cnt
     666  CHARACTER(LEN=80) :: str_READ,str_READ_lower
     667  CHARACTER(LEN=9)  :: c_vtyp
     668  LOGICAL,DIMENSION(:),ALLOCATABLE :: found
     669  LOGICAL :: def_beha,compressed
     670  CHARACTER(LEN=10) :: c_fmt
     671  INTEGER :: i_cmpval
     672  REAL    :: r_cmpval
     673  INTEGER :: ipos_tr,ipos_fl
     674!---------------------------------------------------------------------
     675!-
     676! Get the type of the argument
     677  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
     678  SELECT CASE (k_typ)
     679  CASE(k_i)
     680    nb_to_ret = SIZE(i_val)
     681  CASE(k_r)
     682    nb_to_ret = SIZE(r_val)
     683  CASE(k_c)
     684    nb_to_ret = SIZE(c_val)
     685  CASE(k_l)
     686    nb_to_ret = SIZE(l_val)
     687  CASE DEFAULT
     688    CALL ipslerr (3,'get_fil', &
     689 &   'Internal error','Unknown type of data',' ')
     690  END SELECT
     691!-
     692! Read the file(s)
    1212693  CALL getin_read
    1213694!-
    1214 ! Get the variables and memory we need
    1215 !-
    1216   IF (max_len == 0) THEN
    1217     ALLOCATE(found(nb_to_ret))
    1218     max_len = nb_to_ret
    1219   ENDIF
    1220   IF (max_len < nb_to_ret) THEN
    1221     DEALLOCATE(found)
    1222     ALLOCATE(found(nb_to_ret))
    1223     max_len = nb_to_ret
    1224   ENDIF
     695! Allocate and initialize the memory we need
     696  ALLOCATE(found(nb_to_ret))
    1225697  found(:) = .FALSE.
    1226698!-
    1227699! See what we find in the files read
    1228 !-
    1229700  DO it=1,nb_to_ret
    1230701!---
    1231702!-- First try the target as it is
    1232 !---
    1233     full_target = TARGET(1:len_TRIM(target))
    1234     CALL gensig (full_target,full_target_sig)
    1235     CALL find_sig (nb_lines,targetlist,full_target, &
    1236  &                 targetsiglist,full_target_sig,pos)
     703    CALL get_findkey (2,target,pos)
    1237704!---
    1238705!-- Another try
    1239706!---
    1240707    IF (pos < 0) THEN
    1241       WRITE(cnt,'(I3.3)') it
    1242       full_target = TARGET(1:len_TRIM(target))//'__'//cnt
    1243       CALL gensig (full_target,full_target_sig)
    1244       CALL find_sig (nb_lines,targetlist,full_target, &
    1245  &                   targetsiglist,full_target_sig,pos)
    1246     ENDIF
    1247 !---
    1248 !-- A priori we dont know from which file the target could come.
     708      WRITE(UNIT=cnt,FMT=c_i_fmt) it
     709      CALL get_findkey (2,TRIM(target)//'__'//cnt,pos)
     710    ENDIF
     711!---
     712!-- We dont know from which file the target could come.
    1249713!-- Thus by default we attribute it to the first file :
    1250 !---
    1251714    fileorig = 1
    1252715!---
    … …  
    1258721!---- DECODE
    1259722!-----
    1260       str_READ = TRIM(ADJUSTL(fichier(pos)))
     723      str_READ = ADJUSTL(fichier(pos))
    1261724      str_READ_lower = str_READ
    1262725      CALL strlowercase (str_READ_lower)
    1263726!-----
    1264       IF (    (     (INDEX(str_READ_lower,'def') == 1)     &
    1265  &             .AND.(LEN_TRIM(str_READ_lower) == 3)   )    &
    1266  &        .OR.(     (INDEX(str_READ_lower,'default') == 1) &
    1267  &             .AND.(LEN_TRIM(str_READ_lower) == 7)   )   ) THEN
     727      IF (    (TRIM(str_READ_lower) == 'def')     &
     728 &        .OR.(TRIM(str_READ_lower) == 'default') ) THEN
    1268729        def_beha = .TRUE.
    1269730      ELSE
    1270731        def_beha = .FALSE.
    1271732        len_str = LEN_TRIM(str_READ)
    1272         ipos_tr = -1
    1273         ipos_fl = -1
     733        io_err = 0
     734        SELECT CASE (k_typ)
     735        CASE(k_i)
     736          WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str
     737          READ (UNIT=str_READ(1:len_str), &
     738 &              FMT=c_fmt,IOSTAT=io_err) i_val(it)
     739        CASE(k_r)
     740          READ (UNIT=str_READ(1:len_str), &
     741 &              FMT=*,IOSTAT=io_err) r_val(it)
     742        CASE(k_c)
     743          c_val(it) = str_READ(1:len_str)
     744        CASE(k_l)
     745          ipos_tr = -1
     746          ipos_fl = -1
     747          ipos_tr = MAX(INDEX(str_READ_lower,'tru'), &
     748 &                      INDEX(str_READ_lower,'y'))
     749          ipos_fl = MAX(INDEX(str_READ_lower,'fal'), &
     750 &                      INDEX(str_READ_lower,'n'))
     751          IF (ipos_tr > 0) THEN
     752            l_val(it) = .TRUE.
     753          ELSE IF (ipos_fl > 0) THEN
     754            l_val(it) = .FALSE.
     755          ELSE
     756            io_err = 100
     757          ENDIF
     758        END SELECT
     759        IF (io_err /= 0) THEN
     760          CALL ipslerr (3,'get_fil', &
     761 &         'Target '//TRIM(target), &
     762 &         'is not of '//TRIM(c_vtyp)//' type',' ')
     763        ENDIF
     764      ENDIF
     765!-----
     766      IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
    1274767!-------
    1275         ipos_tr = MAX(INDEX(str_READ,'tru'),INDEX(str_READ,'TRU'), &
    1276  &                    INDEX(str_READ,'y'),INDEX(str_READ,'Y'))
    1277         ipos_fl = MAX(INDEX(str_READ,'fal'),INDEX(str_READ,'FAL'), &
    1278  &                    INDEX(str_READ,'n'),INDEX(str_READ,'N'))
    1279 !-------
    1280         IF (ipos_tr > 0) THEN
    1281           ret_val(it) = .TRUE.
    1282         ELSE IF (ipos_fl > 0) THEN
    1283           ret_val(it) = .FALSE.
    1284         ELSE
    1285           WRITE(*,*) "ERROR : getfill : TARGET ", &
    1286  &                   TRIM(TARGET)," is not of logical value"
    1287           STOP 'getinl'
     768!------ Is this the value of a compressed field ?
     769        compressed = (compline(pos) > 0)
     770        IF (compressed) THEN
     771          IF (compline(pos) /= nb_to_ret) THEN
     772            CALL ipslerr (2,'get_fil', &
     773 &           'For key '//TRIM(target)//' we have a compressed field', &
     774 &           'which does not have the right size.', &
     775 &           'We will try to fix that.')
     776          ENDIF
     777          IF      (k_typ == k_i) THEN
     778            i_cmpval = i_val(it)
     779          ELSE IF (k_typ == k_r) THEN
     780            r_cmpval = r_val(it)
     781          ENDIF
    1288782        ENDIF
    1289783      ENDIF
    1290 !-----
    1291       targetsiglist(pos) = -1
    1292 !-----
    1293784    ELSE
    1294 !-
    1295785      found(it) = .FALSE.
    1296 !-
    1297     ENDIF
    1298 !-
     786      def_beha = .FALSE.
     787      compressed = .FALSE.
     788    ENDIF
    1299789  ENDDO
    1300790!-
    1301 ! Now we get the status for what we found
    1302 !-
     791  IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
     792!---
     793!-- If this is a compressed field then we will uncompress it
     794    IF (compressed) THEN
     795      DO it=1,nb_to_ret
     796        IF (.NOT.found(it)) THEN
     797          IF      (k_typ == k_i) THEN
     798            i_val(it) = i_cmpval
     799          ELSE IF (k_typ == k_r) THEN
     800          ENDIF
     801          found(it) = .TRUE.
     802        ENDIF
     803      ENDDO
     804    ENDIF
     805  ENDIF
     806!-
     807! Now we set the status for what we found
    1303808  IF (def_beha) THEN
    1304809    status = 2
    1305     WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(TARGET)
     810    WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(target)
    1306811  ELSE
    1307812    status_cnt = 0
    1308813    DO it=1,nb_to_ret
    1309       IF (.NOT. found(it)) THEN
     814      IF (.NOT.found(it)) THEN
    1310815        status_cnt = status_cnt+1
    1311         IF (nb_to_ret > 1) THEN
    1312           WRITE(str_tmp,'(a,"__",I3.3)') TRIM(TARGET),it
    1313         ELSE
    1314           str_tmp = TRIM(TARGET)
     816        IF      (status_cnt <= max_msgs) THEN
     817          WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', &
     818 &               ADVANCE='NO') TRIM(target)
     819          IF (nb_to_ret > 1) THEN
     820            WRITE (UNIT=*,FMT='("__")',ADVANCE='NO')
     821            WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it
     822          ENDIF
     823          SELECT CASE (k_typ)
     824          CASE(k_i)
     825            WRITE (UNIT=*,FMT=*) "=",i_val(it)
     826          CASE(k_r)
     827            WRITE (UNIT=*,FMT=*) "=",r_val(it)
     828          CASE(k_c)
     829            WRITE (UNIT=*,FMT=*) "=",c_val(it)
     830          CASE(k_l)
     831            WRITE (UNIT=*,FMT=*) "=",l_val(it)
     832          END SELECT
     833        ELSE IF (status_cnt == max_msgs+1) THEN
     834          WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)')
    1315835        ENDIF
    1316         WRITE(*,*) 'USING DEFAULTS : ',TRIM(str_tmp),'=',ret_val(it)
    1317836      ENDIF
    1318837    ENDDO
    … …  
    1326845    ENDIF
    1327846  ENDIF
     847! Deallocate the memory
     848  DEALLOCATE(found)
    1328849!---------------------
    1329 END SUBROUTINE getfill
     850END SUBROUTINE get_fil
     851!===
     852SUBROUTINE get_rdb (pos,size_of_in,target,i_val,r_val,c_val,l_val)
     853!---------------------------------------------------------------------
     854!- Read the required variable in the database
     855!---------------------------------------------------------------------
     856  IMPLICIT NONE
     857!-
     858  INTEGER :: pos,size_of_in
     859  CHARACTER(LEN=*) :: target
     860  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
     861  REAL,DIMENSION(:),OPTIONAL             :: r_val
     862  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
     863  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
     864!-
     865  INTEGER :: k_typ,k_beg,k_end
     866  CHARACTER(LEN=9) :: c_vtyp
     867!---------------------------------------------------------------------
     868!-
     869! Get the type of the argument
     870  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
     871  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
     872 &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
     873    CALL ipslerr (3,'get_rdb', &
     874 &   'Internal error','Unknown type of data',' ')
     875  ENDIF
     876!-
     877  IF (key_tab(pos)%keytype /= k_typ) THEN
     878    CALL ipslerr (3,'get_rdb', &
     879 &   'Wrong data type for keyword '//TRIM(target), &
     880 &   '(NOT '//TRIM(c_vtyp)//')',' ')
     881  ENDIF
     882!-
     883  IF (key_tab(pos)%keycompress > 0) THEN
     884    IF (    (key_tab(pos)%keycompress /= size_of_in) &
     885 &      .OR.(key_tab(pos)%keymemlen /= 1) ) THEN
     886      CALL ipslerr (3,'get_rdb', &
     887 &     'Wrong compression length','for keyword '//TRIM(target),' ')
     888    ELSE
     889      SELECT CASE (k_typ)
     890      CASE(k_i)
     891        i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart)
     892      CASE(k_r)
     893        r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart)
     894      END SELECT
     895    ENDIF
     896  ELSE
     897    IF (key_tab(pos)%keymemlen /= size_of_in) THEN
     898      CALL ipslerr (3,'get_rdb', &
     899 &     'Wrong array length','for keyword '//TRIM(target),' ')
     900    ELSE
     901      k_beg = key_tab(pos)%keymemstart
     902      k_end = k_beg+key_tab(pos)%keymemlen-1
     903      SELECT CASE (k_typ)
     904      CASE(k_i)
     905        i_val(1:size_of_in) = i_mem(k_beg:k_end)
     906      CASE(k_r)
     907        r_val(1:size_of_in) = r_mem(k_beg:k_end)
     908      CASE(k_c)
     909        c_val(1:size_of_in) = c_mem(k_beg:k_end)
     910      CASE(k_l)
     911        l_val(1:size_of_in) = l_mem(k_beg:k_end)
     912      END SELECT
     913    ENDIF
     914  ENDIF
     915!---------------------
     916END SUBROUTINE get_rdb
     917!===
     918SUBROUTINE get_wdb &
     919 &  (target,status,fileorig,size_of_in, &
     920 &   i_val,r_val,c_val,l_val)
     921!---------------------------------------------------------------------
     922!- Write data into the data base
     923!---------------------------------------------------------------------
     924  IMPLICIT NONE
     925!-
     926  CHARACTER(LEN=*) :: target
     927  INTEGER :: status,fileorig,size_of_in
     928  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
     929  REAL,DIMENSION(:),OPTIONAL             :: r_val
     930  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
     931  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
     932!-
     933  INTEGER :: k_typ
     934  CHARACTER(LEN=9) :: c_vtyp
     935  INTEGER :: k_mempos,k_memsize,k_beg,k_end
     936  LOGICAL :: l_cmp
     937!---------------------------------------------------------------------
     938!-
     939! Get the type of the argument
     940  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
     941  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
     942 &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
     943    CALL ipslerr (3,'get_wdb', &
     944 &   'Internal error','Unknown type of data',' ')
     945  ENDIF
     946!-
     947! First check if we have sufficiant space for the new key
     948  IF (nb_keys+1 > keymemsize) THEN
     949    CALL getin_allockeys ()
     950  ENDIF
     951!-
     952  SELECT CASE (k_typ)
     953  CASE(k_i)
     954    k_mempos = i_mempos; k_memsize = i_memsize;
     955    l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) &
     956 &         .AND.(size_of_in > compress_lim)
     957  CASE(k_r)
     958    k_mempos = r_mempos; k_memsize = r_memsize;
     959    l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) &
     960 &         .AND.(size_of_in > compress_lim)
     961  CASE(k_c)
     962    k_mempos = c_mempos; k_memsize = c_memsize;
     963    l_cmp = .FALSE.
     964  CASE(k_l)
     965    k_mempos = l_mempos; k_memsize = l_memsize;
     966    l_cmp = .FALSE.
     967  END SELECT
     968!-
     969! Fill out the items of the data base
     970  nb_keys = nb_keys+1
     971  key_tab(nb_keys)%keystr = target(1:MIN(LEN_TRIM(target),l_n))
     972  key_tab(nb_keys)%keystatus = status
     973  key_tab(nb_keys)%keytype = k_typ
     974  key_tab(nb_keys)%keyfromfile = fileorig
     975  key_tab(nb_keys)%keymemstart = k_mempos+1
     976  IF (l_cmp) THEN
     977    key_tab(nb_keys)%keycompress = size_of_in
     978    key_tab(nb_keys)%keymemlen = 1
     979  ELSE
     980    key_tab(nb_keys)%keycompress = -1
     981    key_tab(nb_keys)%keymemlen = size_of_in
     982  ENDIF
     983!-
     984! Before writing the actual size lets see if we have the space
     985  IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen &
     986 &    > k_memsize) THEN
     987    CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen)
     988  ENDIF
     989!-
     990  k_beg = key_tab(nb_keys)%keymemstart
     991  k_end = k_beg+key_tab(nb_keys)%keymemlen-1
     992  SELECT CASE (k_typ)
     993  CASE(k_i)
     994    i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen)
     995    i_mempos = k_end
     996  CASE(k_r)
     997    r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen)
     998    r_mempos = k_end
     999  CASE(k_c)
     1000    c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen)
     1001    c_mempos = k_end
     1002  CASE(k_l)
     1003    l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen)
     1004    l_mempos = k_end
     1005  END SELECT
     1006!---------------------
     1007END SUBROUTINE get_wdb
    13301008!-
    13311009!===
    … …  
    13361014!-
    13371015  INTEGER,SAVE :: allread=0
    1338   INTEGER,SAVE :: current,i
     1016  INTEGER,SAVE :: current
    13391017!---------------------------------------------------------------------
    13401018  IF (allread == 0) THEN
    13411019!-- Allocate a first set of memory.
    1342     CALL getin_allockeys
    1343     CALL getin_allocmem (1,0)
    1344     CALL getin_allocmem (2,0)
    1345     CALL getin_allocmem (3,0)
    1346     CALL getin_allocmem (4,0)
     1020    CALL getin_alloctxt ()
     1021    CALL getin_allockeys ()
     1022    CALL getin_allocmem (k_i,0)
     1023    CALL getin_allocmem (k_r,0)
     1024    CALL getin_allocmem (k_c,0)
     1025    CALL getin_allocmem (k_l,0)
    13471026!-- Start with reading the files
    13481027    nbfiles = 1
    13491028    filelist(1) = 'run.def'
    13501029    current = 1
    1351     nb_lines = 0
    13521030!--
    13531031    DO WHILE (current <= nbfiles)
    … …  
    13731051  INTEGER :: current
    13741052!-
    1375   CHARACTER(LEN=100) :: READ_str, NEW_str, new_key, last_key, key_str
    1376   CHARACTER(LEN=3) :: cnt
     1053  CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str
     1054  CHARACTER(LEN=n_d_fmt) :: cnt
     1055  CHARACTER(LEN=10) :: c_fmt
    13771056  INTEGER :: nb_lastkey
    13781057!-
    1379   INTEGER :: eof, ptn, len_str, i, it, iund
     1058  INTEGER :: eof,ptn,len_str,i,it,iund,io_err
    13801059  LOGICAL :: check = .FALSE.
    13811060!---------------------------------------------------------------------
    … …  
    13881067  ENDIF
    13891068!-
    1390   OPEN (22,file=filelist(current),ERR=9997,STATUS="OLD")
     1069  OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err)
     1070  IF (io_err /= 0) THEN
     1071    CALL ipslerr (2,'getin_readdef', &
     1072 &  'Could not open file '//TRIM(filelist(current)),' ',' ')
     1073    RETURN
     1074  ENDIF
    13911075!-
    13921076  DO WHILE (eof /= 1)
    … …  
    13991083!---- Get the target
    14001084      key_str = TRIM(ADJUSTL(READ_str(1:ptn-1)))
    1401 !---- Make sure that if a vector keyword has the right length
    1402       iund =  INDEX(key_str,'__')
     1085!---- Make sure that a vector keyword has the right length
     1086      iund = INDEX(key_str,'__')
    14031087      IF (iund > 0) THEN
    1404         SELECTCASE( len_trim(key_str)-iund )
    1405           CASE(2)
    1406             READ(key_str(iund+2:len_trim(key_str)),'(I1)') it
    1407           CASE(3)
    1408             READ(key_str(iund+2:len_trim(key_str)),'(I2)') it
    1409           CASE(4)
    1410             READ(key_str(iund+2:len_trim(key_str)),'(I3)') it
    1411           CASE DEFAULT
    1412             it = -1
    1413         END SELECT
    1414         IF (it > 0) THEN
    1415           WRITE(cnt,'(I3.3)') it
     1088        WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') &
     1089 &        LEN_TRIM(key_str)-iund-1
     1090        READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), &
     1091 &           FMT=c_fmt,IOSTAT=io_err) it
     1092        IF ( (io_err == 0).AND.(it > 0) ) THEN
     1093          WRITE(UNIT=cnt,FMT=c_i_fmt) it
    14161094          key_str = key_str(1:iund+1)//cnt
    14171095        ELSE
    1418           WRITE(*,*) &
    1419  &          'getin_readdef : A very strange key has just been found'
    1420           WRITE(*,*) 'getin_readdef : ',key_str(1:len_TRIM(key_str))
    1421           STOP 'getin_readdef'
     1096          CALL ipslerr (3,'getin_readdef', &
     1097 &         'A very strange key has just been found :', &
     1098 &         TRIM(key_str),' ')
    14221099        ENDIF
    14231100      ENDIF
    … …  
    14481125        ELSE
    14491126          IF (nb_lastkey /= 1) THEN
    1450             WRITE(*,*) &
    1451  &   'getin_readdef : An error has occured. We can not have a scalar'
    1452             WRITE(*,*) 'getin_readdef : keywod and a vector content'
    1453             STOP 'getin_readdef'
     1127            CALL ipslerr (3,'getin_readdef', &
     1128 &           'We can not have a scalar keyword', &
     1129 &           'and a vector content',' ')
    14541130          ENDIF
    14551131!-------- The last keyword needs to be transformed into a vector.
     1132          WRITE(UNIT=cnt,FMT=c_i_fmt) 1
    14561133          targetlist(nb_lines) = &
    1457  &          last_key(1:MIN(len_trim(last_key),30))//'__001'
    1458           CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines))
    1459           key_str = last_key(1:len_TRIM(last_key))
     1134 &         last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt
     1135          key_str = last_key(1:LEN_TRIM(last_key))
    14601136        ENDIF
    14611137      ENDIF
    … …  
    14641140      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
    14651141    ELSE
    1466 !---- If we have an empty line the the keyword finishes
     1142!---- If we have an empty line then the keyword finishes
    14671143      nb_lastkey = 0
    14681144      IF (check) THEN
    … …  
    14721148  ENDDO
    14731149!-
    1474   CLOSE(22)
     1150  CLOSE(UNIT=22)
    14751151!-
    14761152  IF (check) THEN
    1477     OPEN (22,file='run.def.test')
     1153    OPEN (UNIT=22,file='run.def.test')
    14781154    DO i=1,nb_lines
    1479       WRITE(22,*) targetlist(i)," : ",fichier(i)
     1155      WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i)
    14801156    ENDDO
    1481     CLOSE(22)
    1482   ENDIF
    1483 !-
    1484   RETURN
    1485 !-
    1486 9997 WRITE(*,*) "getin_readdef : Could not open file ", &
    1487           & TRIM(filelist(current))
     1157    CLOSE(UNIT=22)
     1158  ENDIF
    14881159!---------------------------
    14891160END SUBROUTINE getin_readdef
    … …  
    15011172! ARGUMENTS
    15021173!-
    1503   INTEGER :: current, nb_lastkey
    1504   CHARACTER(LEN=*) :: key_str, NEW_str, last_key
     1174  INTEGER :: current,nb_lastkey
     1175  CHARACTER(LEN=*) :: key_str,NEW_str,last_key
    15051176!-
    15061177! LOCAL
    15071178!-
    1508   INTEGER :: len_str, blk, nbve, starpos
    1509   CHARACTER(LEN=100) :: tmp_str, new_key, mult
    1510   CHARACTER(LEN=3)   :: cnt, chlen
    1511   CHARACTER(LEN=10)  :: fmt
     1179  INTEGER :: len_str,blk,nbve,starpos
     1180  CHARACTER(LEN=100) :: tmp_str,new_key,mult
     1181  CHARACTER(LEN=n_d_fmt) :: cnt
     1182  CHARACTER(LEN=10) :: c_fmt
    15121183!---------------------------------------------------------------------
    15131184  len_str = LEN_TRIM(NEW_str)
    … …  
    15211192    DO WHILE (blk > 0)
    15221193      IF (nbfiles+1 > max_files) THEN
    1523         WRITE(*,*) 'FATAL ERROR : Too many files to include'
    1524         STOP 'getin_readdef'
     1194        CALL ipslerr (3,'getin_decrypt', &
     1195 &       'Too many files to include',' ',' ')
    15251196      ENDIF
    15261197!-----
    … …  
    15331204!---
    15341205    IF (nbfiles+1 > max_files) THEN
    1535       WRITE(*,*) 'FATAL ERROR : Too many files to include'
    1536       STOP 'getin_readdef'
     1206      CALL ipslerr (3,'getin_decrypt', &
     1207 &     'Too many files to include',' ',' ')
    15371208    ENDIF
    15381209!---
    … …  
    15461217!-- We are working on a new line of input
    15471218!-
     1219    IF (nb_lines+1 > i_txtsize) THEN
     1220      CALL getin_alloctxt ()
     1221    ENDIF
    15481222    nb_lines = nb_lines+1
    1549     IF (nb_lines > max_lines) THEN
    1550       WRITE(*,*) &
    1551  &      'Too many line in the run.def files. You need to increase'
    1552       WRITE(*,*) 'the parameter max_lines in the module getincom.'
    1553       STOP 'getin_decrypt'
    1554     ENDIF
    15551223!-
    15561224!-- First we solve the issue of conpressed information. Once
    … …  
    15611229 &                    .AND.(tmp_str(1:1) /= "'") ) THEN
    15621230!-----
    1563       IF (INDEX(key_str(1:len_TRIM(key_str)),'__') > 0) THEN
    1564         WRITE(*,*) 'ERROR : getin_decrypt'
    1565         WRITE(*,*) &
    1566 &         'We can not have a compressed field of values for in a'
    1567         WRITE(*,*) &
    1568 &         'vector notation. If a target is of the type TARGET__1'
    1569         WRITE(*,*) 'then only a scalar value is allowed'
    1570         WRITE(*,*) 'The key at fault : ',key_str(1:len_TRIM(key_str))
    1571         STOP 'getin_decrypt'
     1231      IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN
     1232        CALL ipslerr (3,'getin_decrypt', &
     1233 &       'We can not have a compressed field of values', &
     1234 &       'in a vector notation (TARGET__n).', &
     1235 &       'The key at fault : '//TRIM(key_str))
    15721236      ENDIF
    15731237!-
    … …  
    15801244      blk = INDEX(NEW_str(1:len_str),' ')
    15811245      IF (blk > 1) THEN
    1582         WRITE(*,*) &
    1583  &       'This is a strange behavior of getin_decrypt you could report'
    1584       ENDIF
    1585       WRITE(chlen,'(I3.3)') LEN_TRIM(mult)
    1586       fmt = '(I'//chlen//')'
    1587       READ(mult,fmt) compline(nb_lines)
     1246        CALL ipslerr (2,'getin_decrypt', &
     1247 &       'This is a strange behavior','you could report',' ')
     1248      ENDIF
     1249      WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult)
     1250      READ(UNIT=mult,FMT=c_fmt) compline(nb_lines)
    15881251!---
    15891252    ELSE
    … …  
    15931256!-- If there is no space wthin the line then the target is a scalar
    15941257!-- or the element of a properly written vector.
    1595 !-- (ie of the type TARGET__1)
     1258!-- (ie of the type TARGET__00001)
    15961259!-
    15971260    IF (    (blk <= 1) &
    … …  
    16021265!------ Save info of current keyword as a scalar
    16031266!------ if it is not a continuation
    1604         targetlist(nb_lines) = key_str(1:MIN(len_trim(key_str),30))
    1605         last_key = key_str(1:MIN(len_trim(key_str),30))
     1267        targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n))
     1268        last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n))
    16061269        nb_lastkey = 1
    16071270      ELSE
    16081271!------ We are continuing a vector so the keyword needs
    16091272!------ to get the underscores
    1610         WRITE(cnt,'(I3.3)') nb_lastkey+1
     1273        WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1
    16111274        targetlist(nb_lines) = &
    1612  &        key_str(1:MIN(len_trim(key_str),25))//'__'//cnt
    1613         last_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt
     1275 &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
     1276        last_key = &
     1277 &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
    16141278        nb_lastkey = nb_lastkey+1
    16151279      ENDIF
    16161280!-----
    1617       CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines))
    16181281      fichier(nb_lines) = NEW_str(1:len_str)
    16191282      fromfile(nb_lines) = current
    … …  
    16221285!---- If there are blanks whithin the line then we are dealing
    16231286!---- with a vector and we need to split it in many entries
    1624 !---- with the TRAGET__1 notation.
     1287!---- with the TARGET__n notation.
    16251288!----
    16261289!---- Test if the targer is not already a vector target !
    16271290!-
    16281291      IF (INDEX(TRIM(key_str),'__') > 0) THEN
    1629         WRITE(*,*) 'ERROR : getin_decrypt'
    1630         WRITE(*,*) 'We have found a mixed vector notation'
    1631         WRITE(*,*) 'If a target is of the type TARGET__1'
    1632         WRITE(*,*) 'then only a scalar value is allowed'
    1633         WRITE(*,*) 'The key at fault : ',key_str(1:len_TRIM(key_str))
    1634         STOP 'getin_decrypt'
     1292        CALL ipslerr (3,'getin_decrypt', &
     1293 &       'We have found a mixed vector notation (TARGET__n).', &
     1294 &       'The key at fault : '//TRIM(key_str),' ')
    16351295      ENDIF
    16361296!-
    16371297      nbve = nb_lastkey
    16381298      nbve = nbve+1
    1639       WRITE(cnt,'(I3.3)') nbve
     1299      WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
    16401300!-
    16411301      DO WHILE (blk > 0)
    … …  
    16441304!-
    16451305        fichier(nb_lines) = tmp_str(1:blk)
    1646         new_key =  key_str(1:MIN(len_trim(key_str),25))//'__'//cnt
    1647         targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key),30))
    1648         CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines))
     1306        new_key = &
     1307 &       key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
     1308        targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
    16491309        fromfile(nb_lines) = current
    16501310!-
    … …  
    16521312        blk = INDEX(TRIM(tmp_str),' ')
    16531313!-
     1314        IF (nb_lines+1 > i_txtsize) THEN
     1315          CALL getin_alloctxt ()
     1316        ENDIF
    16541317        nb_lines = nb_lines+1
    1655         IF (nb_lines > max_lines) THEN
    1656           WRITE(*,*) &
    1657  &          'Too many line in the run.def files. You need to increase'
    1658           WRITE(*,*) 'the parameter max_lines in the module getincom.'
    1659           STOP 'getin_decrypt'
    1660         ENDIF
    16611318        nbve = nbve+1
    1662         WRITE(cnt,'(I3.3)') nbve
     1319        WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
    16631320!-
    16641321      ENDDO
    … …  
    16671324!-
    16681325      fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str))
    1669       new_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt
    1670       targetlist(nb_lines) = new_key(1:MIN(len_trim(new_key),30))
    1671       CALL gensig (targetlist(nb_lines),targetsiglist(nb_lines))
     1326      new_key = &
     1327 &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
     1328      targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
    16721329      fromfile(nb_lines) = current
    16731330!-
    1674       last_key = key_str(1:MIN(len_trim(key_str),25))//'__'//cnt
     1331      last_key = &
     1332 &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
    16751333      nb_lastkey = nbve
    16761334!-
    … …  
    16891347  IMPLICIT NONE
    16901348!-
    1691 ! Arguments
    1692 !-
    1693 !-
    1694 ! LOCAL
    1695 !-
    1696   INTEGER :: line,i,sig
    1697   INTEGER :: found
    1698   CHARACTER(LEN=30) :: str
     1349  INTEGER :: line,n_k,k
    16991350!---------------------------------------------------------------------
    17001351  DO line=1,nb_lines-1
    17011352!-
    1702     CALL find_sig &
    1703  &    (nb_lines-line,targetlist(line+1:nb_lines),targetlist(line), &
    1704  &     targetsiglist(line+1:nb_lines),targetsiglist(line),found)
     1353    n_k = 0
     1354    DO k=line+1,nb_lines
     1355      IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN
     1356        n_k = k
     1357        EXIT
     1358      ENDIF
     1359    ENDDO
    17051360!---
    17061361!-- IF we have found it we have a problem to solve.
    17071362!---
    1708     IF (found > 0) THEN
    1709       WRITE(*,*) 'COUNT : ', &
    1710  &  COUNT(ABS(targetsiglist(line+1:nb_lines)-targetsiglist(line)) < 1)
    1711 !-----
     1363    IF (n_k > 0) THEN
     1364      WRITE(*,*) 'COUNT : ',n_k
    17121365      WRITE(*,*) &
    1713  & 'getin_checkcohe : Found a problem on key ',targetlist(line)
     1366 &  'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line))
    17141367      WRITE(*,*) &
    1715  & 'getin_checkcohe : The following values were encoutered :'
     1368 &  'getin_checkcohe : The following values were encoutered :'
    17161369      WRITE(*,*) &
    1717  & '                ',TRIM(targetlist(line)), &
    1718  &               targetsiglist(line),' == ',fichier(line)
     1370 &  '                ',TRIM(targetlist(line)),' == ',fichier(line)
    17191371      WRITE(*,*) &
    1720  & '                ',TRIM(targetlist(line+found)), &
    1721  &               targetsiglist(line+found),' == ',fichier(line+found)
     1372 &  '                ',TRIM(targetlist(k)),' == ',fichier(k)
    17221373      WRITE(*,*) &
    1723  & 'getin_checkcohe : We will keep only the last value'
    1724 !-----
    1725       targetsiglist(line) = 1
     1374 &  'getin_checkcohe : We will keep only the last value'
     1375      targetlist(line) = ' '
    17261376    ENDIF
    17271377  ENDDO
    1728 !-
     1378!-----------------------------
    17291379END SUBROUTINE getin_checkcohe
    17301380!-
    … …  
    17351385  IMPLICIT NONE
    17361386!-
    1737   INTEGER :: unit, eof, nb_lastkey
     1387  INTEGER :: unit,eof,nb_lastkey
    17381388  CHARACTER(LEN=100) :: dummy
    17391389  CHARACTER(LEN=100) :: out_string
    … …  
    17451395!-
    17461396  DO WHILE (first == "#")
    1747     READ (unit,'(a100)',ERR=9998,END=7778) dummy
     1397    READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy
    17481398    dummy = TRIM(ADJUSTL(dummy))
    17491399    first=dummy(1:1)
    … …  
    17561406  RETURN
    17571407!-
    1758 9998 WRITE(*,*) " GETIN_SKIPAFEW : Error while reading file "
    1759   STOP 'getin_skipafew'
    1760 !-
    1761 7778 eof = 1
     14089998 CONTINUE
     1409  CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ')
     1410!-
     14117778 CONTINUE
     1412  eof = 1
    17621413!----------------------------
    17631414END SUBROUTINE getin_skipafew
    17641415!-
    1765 !=== INTEGER database INTERFACE
    1766 !-
    1767 SUBROUTINE getdbwi &
    1768  &  (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)
    1769 !---------------------------------------------------------------------
    1770 !- Write the INTEGER data into the data base
    1771 !---------------------------------------------------------------------
    1772   IMPLICIT NONE
    1773 !-
    1774   CHARACTER(LEN=*) :: target
    1775   INTEGER :: target_sig, status, fileorig, size_of_in
    1776   INTEGER,DIMENSION(:) :: tmp_ret_val
    1777 !---------------------------------------------------------------------
    1778 !-
    1779 ! First check if we have sufficiant space for the new key
    1780 !-
    1781   IF (nb_keys+1 > keymemsize) THEN
    1782     CALL getin_allockeys ()
    1783   ENDIF
    1784 !-
    1785 ! Fill out the items of the data base
    1786 !-
    1787   nb_keys = nb_keys+1
    1788   keysig(nb_keys) = target_sig
    1789   keystr(nb_keys) = target(1:MIN(len_trim(target),30))
    1790   keystatus(nb_keys) = status
    1791   keytype(nb_keys) = 1
    1792   keyfromfile(nb_keys) = fileorig
    1793 !-
    1794 ! Can we compress the data base entry ?
    1795 !-
    1796   IF (     (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) &
    1797  &    .AND.(size_of_in > compress_lim)) THEN
    1798     keymemstart(nb_keys) = intmempos+1
    1799     keycompress(nb_keys) = size_of_in
    1800     keymemlen(nb_keys) = 1
    1801   ELSE
    1802     keymemstart(nb_keys) = intmempos+1
    1803     keycompress(nb_keys) = -1
    1804     keymemlen(nb_keys) = size_of_in
    1805   ENDIF
    1806 !-
    1807 ! Before writing the actual size lets see if we have the space
    1808 !-
    1809   IF (keymemstart(nb_keys)+keymemlen(nb_keys) > intmemsize) THEN
    1810     CALL getin_allocmem (1,keymemlen(nb_keys))
    1811   ENDIF
    1812 !-
    1813   intmem(keymemstart(nb_keys): &
    1814  &       keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
    1815  &  tmp_ret_val(1:keymemlen(nb_keys))
    1816   intmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
    1817 !---------------------
    1818 END SUBROUTINE getdbwi
    1819 !-
    1820 !===
    1821 !-
    1822 SUBROUTINE getdbri (pos,size_of_in,target,tmp_ret_val)
    1823 !---------------------------------------------------------------------
    1824 !- Read the required variables in the database for INTEGERS
    1825 !---------------------------------------------------------------------
    1826   IMPLICIT NONE
    1827 !-
    1828   INTEGER :: pos, size_of_in
    1829   CHARACTER(LEN=*) :: target
    1830   INTEGER,DIMENSION(:) :: tmp_ret_val
    1831 !---------------------------------------------------------------------
    1832   IF (keytype(pos) /= 1) THEN
    1833     WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target
    1834     STOP 'getdbri'
    1835   ENDIF
    1836 !-
    1837   IF (keycompress(pos) > 0) THEN
    1838     IF ( keycompress(pos) /= size_of_in .OR. keymemlen(pos) /= 1 ) THEN
    1839       WRITE(*,*) &
    1840  &      'FATAL ERROR : Wrong compression length for keyword ',target
    1841       STOP 'getdbri'
    1842     ELSE
    1843       tmp_ret_val(1:size_of_in) = intmem(keymemstart(pos))
    1844     ENDIF
    1845   ELSE
    1846     IF (keymemlen(pos) /= size_of_in) THEN
    1847       WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target
    1848       STOP 'getdbri'
    1849     ELSE
    1850       tmp_ret_val(1:size_of_in) = &
    1851  &      intmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
    1852     ENDIF
    1853   ENDIF
    1854 !---------------------
    1855 END SUBROUTINE getdbri
    1856 !-
    1857 !=== REAL database INTERFACE
    1858 !-
    1859 SUBROUTINE getdbwr &
    1860  &  (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)
    1861 !---------------------------------------------------------------------
    1862 !- Write the REAL data into the data base
    1863 !---------------------------------------------------------------------
    1864   IMPLICIT NONE
    1865 !-
    1866   CHARACTER(LEN=*) :: target
    1867   INTEGER :: target_sig, status, fileorig, size_of_in
    1868   REAL,DIMENSION(:) :: tmp_ret_val
    1869 !---------------------------------------------------------------------
    1870 !-
    1871 ! First check if we have sufficiant space for the new key
    1872 !-
    1873   IF (nb_keys+1 > keymemsize) THEN
    1874     CALL getin_allockeys ()
    1875   ENDIF
    1876 !-
    1877 ! Fill out the items of the data base
    1878 !-
    1879   nb_keys = nb_keys+1
    1880   keysig(nb_keys) = target_sig
    1881   keystr(nb_keys) = target(1:MIN(len_trim(target),30))
    1882   keystatus(nb_keys) = status
    1883   keytype(nb_keys) = 2
    1884   keyfromfile(nb_keys) = fileorig
    1885 !-
    1886 ! Can we compress the data base entry ?
    1887 !-
    1888   IF (     (MINVAL(tmp_ret_val) == MAXVAL(tmp_ret_val)) &
    1889 &     .AND.(size_of_in > compress_lim)) THEN
    1890     keymemstart(nb_keys) = realmempos+1
    1891     keycompress(nb_keys) = size_of_in
    1892     keymemlen(nb_keys) = 1
    1893   ELSE
    1894     keymemstart(nb_keys) = realmempos+1
    1895     keycompress(nb_keys) = -1
    1896     keymemlen(nb_keys) = size_of_in
    1897   ENDIF
    1898 !-
    1899 ! Before writing the actual size lets see if we have the space
    1900 !-
    1901   IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN
    1902     CALL getin_allocmem (2,keymemlen(nb_keys))
    1903   ENDIF
    1904 !-
    1905   realmem(keymemstart(nb_keys): &
    1906  &        keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
    1907  &  tmp_ret_val(1:keymemlen(nb_keys))
    1908   realmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
    1909 !---------------------
    1910 END SUBROUTINE getdbwr
    1911 !-
    1912 !===
    1913 !-
    1914 SUBROUTINE getdbrr (pos,size_of_in,target,tmp_ret_val)
    1915 !---------------------------------------------------------------------
    1916 !- Read the required variables in the database for REALS
    1917 !---------------------------------------------------------------------
    1918   IMPLICIT NONE
    1919 !-
    1920   INTEGER :: pos, size_of_in
    1921   CHARACTER(LEN=*) :: target
    1922   REAL,DIMENSION(:) :: tmp_ret_val
    1923 !---------------------------------------------------------------------
    1924   IF (keytype(pos) /= 2) THEN
    1925     WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target
    1926     STOP 'getdbrr'
    1927   ENDIF
    1928 !-
    1929   IF (keycompress(pos) > 0) THEN
    1930     IF (    (keycompress(pos) /= size_of_in) &
    1931  &      .OR.(keymemlen(pos) /= 1) ) THEN
    1932       WRITE(*,*) &
    1933  &      'FATAL ERROR : Wrong compression length for keyword ',target
    1934       STOP 'getdbrr'
    1935     ELSE
    1936       tmp_ret_val(1:size_of_in) = realmem(keymemstart(pos))
    1937     ENDIF
    1938   ELSE
    1939     IF (keymemlen(pos) /= size_of_in) THEN
    1940       WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target
    1941       STOP 'getdbrr'
    1942     ELSE
    1943       tmp_ret_val(1:size_of_in) = &
    1944  &      realmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
    1945     ENDIF
    1946   ENDIF
    1947 !---------------------
    1948 END SUBROUTINE getdbrr
    1949 !-
    1950 !=== CHARACTER database INTERFACE
    1951 !-
    1952 SUBROUTINE getdbwc &
    1953  &  (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)
    1954 !---------------------------------------------------------------------
    1955 !- Write the CHARACTER data into the data base
    1956 !---------------------------------------------------------------------
    1957   IMPLICIT NONE
    1958 !-
    1959   CHARACTER(LEN=*) :: target
    1960   INTEGER :: target_sig,status,fileorig,size_of_in
    1961   CHARACTER(LEN=*),DIMENSION(:) :: tmp_ret_val
    1962 !---------------------------------------------------------------------
    1963 !-
    1964 ! First check if we have sufficiant space for the new key
    1965 !-
    1966   IF (nb_keys+1 > keymemsize) THEN
    1967     CALL getin_allockeys ()
    1968   ENDIF
    1969 !-
    1970 ! Fill out the items of the data base
    1971 !-
    1972   nb_keys = nb_keys+1
    1973   keysig(nb_keys) = target_sig
    1974   keystr(nb_keys) = target(1:MIN(len_trim(target),30))
    1975   keystatus(nb_keys) = status
    1976   keytype(nb_keys) = 3
    1977   keyfromfile(nb_keys) = fileorig
    1978   keymemstart(nb_keys) = charmempos+1
    1979   keymemlen(nb_keys) = size_of_in
    1980 !-
    1981 ! Before writing the actual size lets see if we have the space
    1982 !-
    1983   IF (keymemstart(nb_keys)+keymemlen(nb_keys) > realmemsize) THEN
    1984     CALL getin_allocmem (3,keymemlen(nb_keys))
    1985   ENDIF
    1986 !-
    1987   charmem(keymemstart(nb_keys): &
    1988  &        keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
    1989  &  tmp_ret_val(1:keymemlen(nb_keys))
    1990   charmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
    1991 !---------------------
    1992 END SUBROUTINE getdbwc
    1993 !-
    1994 !===
    1995 !-
    1996 SUBROUTINE getdbrc(pos,size_of_in,target,tmp_ret_val)
    1997 !---------------------------------------------------------------------
    1998 !- Read the required variables in the database for CHARACTER
    1999 !---------------------------------------------------------------------
    2000   IMPLICIT NONE
    2001 !-
    2002   INTEGER :: pos, size_of_in
    2003   CHARACTER(LEN=*) :: target
    2004   CHARACTER(LEN=*),DIMENSION(:) :: tmp_ret_val
    2005 !---------------------------------------------------------------------
    2006   IF (keytype(pos) /= 3) THEN
    2007     WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target
    2008     STOP 'getdbrc'
    2009   ENDIF
    2010 !-
    2011   IF (keymemlen(pos) /= size_of_in) THEN
    2012     WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target
    2013     STOP 'getdbrc'
    2014   ELSE
    2015     tmp_ret_val(1:size_of_in) = &
    2016  &    charmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
    2017   ENDIF
    2018 !---------------------
    2019 END SUBROUTINE getdbrc
    2020 !-
    2021 !=== LOGICAL database INTERFACE
    2022 !-
    2023 SUBROUTINE getdbwl &
    2024  &  (target,target_sig,status,fileorig,size_of_in,tmp_ret_val)
    2025 !---------------------------------------------------------------------
    2026 !- Write the LOGICAL data into the data base
    2027 !---------------------------------------------------------------------
    2028   IMPLICIT NONE
    2029 !-
    2030   CHARACTER(LEN=*) :: target
    2031   INTEGER :: target_sig, status, fileorig, size_of_in
    2032   LOGICAL,DIMENSION(:) :: tmp_ret_val
    2033 !---------------------------------------------------------------------
    2034 !-
    2035 ! First check if we have sufficiant space for the new key
    2036 !-
    2037   IF (nb_keys+1 > keymemsize) THEN
    2038     CALL getin_allockeys ()
    2039   ENDIF
    2040 !-
    2041 ! Fill out the items of the data base
    2042 !-
    2043   nb_keys = nb_keys+1
    2044   keysig(nb_keys) = target_sig
    2045   keystr(nb_keys) = target(1:MIN(len_trim(target),30))
    2046   keystatus(nb_keys) = status
    2047   keytype(nb_keys) = 4
    2048   keyfromfile(nb_keys) = fileorig
    2049   keymemstart(nb_keys) = logicmempos+1
    2050   keymemlen(nb_keys) = size_of_in
    2051 !-
    2052 ! Before writing the actual size lets see if we have the space
    2053 !-
    2054   IF (keymemstart(nb_keys)+keymemlen(nb_keys) > logicmemsize) THEN
    2055     CALL getin_allocmem (4,keymemlen(nb_keys))
    2056   ENDIF
    2057 !-
    2058   logicmem(keymemstart(nb_keys): &
    2059  &         keymemstart(nb_keys)+keymemlen(nb_keys)-1) = &
    2060  &  tmp_ret_val(1:keymemlen(nb_keys))
    2061   logicmempos = keymemstart(nb_keys)+keymemlen(nb_keys)-1
    2062 !---------------------
    2063 END SUBROUTINE getdbwl
    2064 !-
    2065 !===
    2066 !-
    2067 SUBROUTINE getdbrl(pos,size_of_in,target,tmp_ret_val)
    2068 !---------------------------------------------------------------------
    2069 !- Read the required variables in the database for LOGICALS
    2070 !---------------------------------------------------------------------
    2071   IMPLICIT NONE
    2072 !-
    2073   INTEGER :: pos, size_of_in
    2074   CHARACTER(LEN=*) :: target
    2075   LOGICAL,DIMENSION(:) :: tmp_ret_val
    2076 !---------------------------------------------------------------------
    2077   IF (keytype(pos) /= 4) THEN
    2078     WRITE(*,*) 'FATAL ERROR : Wrong data type for keyword ',target
    2079     STOP 'getdbrl'
    2080   ENDIF
    2081 !-
    2082   IF (keymemlen(pos) /= size_of_in) THEN
    2083     WRITE(*,*) 'FATAL ERROR : Wrong array length for keyword ',target
    2084     STOP 'getdbrl'
    2085   ELSE
    2086     tmp_ret_val(1:size_of_in) = &
    2087  &    logicmem(keymemstart(pos):keymemstart(pos)+keymemlen(pos)-1)
    2088   ENDIF
    2089 !---------------------
    2090 END SUBROUTINE getdbrl
    2091 !-
    20921416!===
    20931417!-
    … …  
    20961420  IMPLICIT NONE
    20971421!-
    2098   INTEGER,ALLOCATABLE :: tmp_int(:)
     1422  TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab
    20991423  CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:)
    21001424!-
    21011425  INTEGER :: ier
    2102 !---------------------------------------------------------------------
    2103 !-
    2104 ! Either nothing exists in these arrays and it is easy to do
    2105 !-
     1426  CHARACTER(LEN=20) :: c_tmp
     1427!---------------------------------------------------------------------
    21061428  IF (keymemsize == 0) THEN
    2107 !-
    2108     ALLOCATE(keysig(memslabs),stat=ier)
     1429!---
     1430!-- Nothing exists in memory arrays and it is easy to do.
     1431!---
     1432    WRITE (UNIT=c_tmp,FMT=*) memslabs
     1433    ALLOCATE(key_tab(memslabs),stat=ier)
    21091434    IF (ier /= 0) THEN
    2110       WRITE(*,*) &
    2111  &      'getin_allockeys : Can not allocate keysig to size ', &
    2112  &      memslabs
    2113       STOP
    2114     ENDIF
    2115 !-
    2116     ALLOCATE(keystr(memslabs),stat=ier)
    2117     IF (ier /= 0) THEN
    2118       WRITE(*,*) &
    2119  &      'getin_allockeys : Can not allocate keystr to size ', &
    2120  &      memslabs
    2121       STOP
    2122     ENDIF
    2123 !-
    2124     ALLOCATE(keystatus(memslabs),stat=ier)
    2125     IF (ier /= 0) THEN
    2126       WRITE(*,*) &
    2127  &      'getin_allockeys : Can not allocate keystatus to size ', &
    2128  &      memslabs
    2129       STOP
    2130     ENDIF
    2131 !-
    2132     ALLOCATE(keytype(memslabs),stat=ier)
    2133     IF (ier /= 0) THEN
    2134       WRITE(*,*) &
    2135  &      'getin_allockeys : Can not allocate keytype to size ', &
    2136  &      memslabs
    2137       STOP
    2138     ENDIF
    2139 !-
    2140     ALLOCATE(keycompress(memslabs),stat=ier)
    2141     IF (ier /= 0) THEN
    2142       WRITE(*,*) &
    2143  &      'getin_allockeys : Can not allocate keycompress to size ', &
    2144  &      memslabs
    2145       STOP
    2146     ENDIF
    2147 !-
    2148     ALLOCATE(keyfromfile(memslabs),stat=ier)
    2149     IF (ier /= 0) THEN
    2150       WRITE(*,*) &
    2151  &      'getin_allockeys : Can not allocate keyfromfile to size ', &
    2152  &      memslabs
    2153       STOP
    2154     ENDIF
    2155 !-
    2156     ALLOCATE(keymemstart(memslabs),stat=ier)
    2157     IF (ier /= 0) THEN
    2158       WRITE(*,*) &
    2159  &      'getin_allockeys : Can not allocate keymemstart to size ', &
    2160  &      memslabs
    2161       STOP
    2162     ENDIF
    2163 !-
    2164     ALLOCATE(keymemlen(memslabs),stat=ier)
    2165     IF (ier /= 0) THEN
    2166       WRITE(*,*) &
    2167  &      'getin_allockeys : Can not allocate keymemlen to size ', &
    2168  &      memslabs
    2169       STOP
    2170     ENDIF
    2171 !-
     1435      CALL ipslerr (3,'getin_allockeys', &
     1436 &     'Can not allocate key_tab', &
     1437 &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1438    ENDIF
    21721439    nb_keys = 0
    21731440    keymemsize = memslabs
    2174     keycompress(:) = -1
    2175 !-
     1441    key_tab(:)%keycompress = -1
     1442!---
    21761443  ELSE
    2177 !-
     1444!---
    21781445!-- There is something already in the memory,
    21791446!-- we need to transfer and reallocate.
    2180 !-
    2181     ALLOCATE(tmp_str(keymemsize),stat=ier)
     1447!---
     1448    WRITE (UNIT=c_tmp,FMT=*) keymemsize
     1449    ALLOCATE(tmp_key_tab(keymemsize),stat=ier)
    21821450    IF (ier /= 0) THEN
    2183       WRITE(*,*) &
    2184  &      'getin_allockeys : Can not allocate tmp_str to size ', &
    2185  &      keymemsize
    2186       STOP
    2187     ENDIF
    2188 !-
    2189     ALLOCATE(tmp_int(keymemsize),stat=ier)
     1451      CALL ipslerr (3,'getin_allockeys', &
     1452 &     'Can not allocate tmp_key_tab', &
     1453 &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1454    ENDIF
     1455    WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs
     1456    tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize)
     1457    DEALLOCATE(key_tab)
     1458    ALLOCATE(key_tab(keymemsize+memslabs),stat=ier)
    21901459    IF (ier /= 0) THEN
    2191       WRITE(*,*) &
    2192  &      'getin_allockeys : Can not allocate tmp_int to size ', &
    2193  &      keymemsize
    2194       STOP
    2195     ENDIF
    2196 !-
    2197     tmp_int(1:keymemsize) = keysig(1:keymemsize)
    2198     DEALLOCATE(keysig)
    2199     ALLOCATE(keysig(keymemsize+memslabs),stat=ier)
    2200     IF (ier /= 0) THEN
    2201       WRITE(*,*) &
    2202  &      'getin_allockeys : Can not allocate keysig to size ', &
    2203  &      keymemsize+memslabs
    2204       STOP
    2205     ENDIF
    2206     keysig(1:keymemsize) = tmp_int(1:keymemsize)
    2207 !-
    2208     tmp_str(1:keymemsize) = keystr(1:keymemsize)
    2209     DEALLOCATE(keystr)
    2210     ALLOCATE(keystr(keymemsize+memslabs),stat=ier)
    2211     IF (ier /= 0) THEN
    2212       WRITE(*,*) &
    2213  &      'getin_allockeys : Can not allocate keystr to size ', &
    2214  &      keymemsize+memslabs
    2215       STOP
    2216     ENDIF
    2217     keystr(1:keymemsize) = tmp_str(1:keymemsize)
    2218 !-
    2219     tmp_int(1:keymemsize) = keystatus(1:keymemsize)
    2220     DEALLOCATE(keystatus)
    2221     ALLOCATE(keystatus(keymemsize+memslabs),stat=ier)
    2222     IF (ier /= 0) THEN
    2223       WRITE(*,*) &
    2224  &      'getin_allockeys : Can not allocate keystatus to size ', &
    2225  &      keymemsize+memslabs
    2226       STOP
    2227     ENDIF
    2228     keystatus(1:keymemsize) = tmp_int(1:keymemsize)
    2229 !-
    2230     tmp_int(1:keymemsize) = keytype(1:keymemsize)
    2231     DEALLOCATE(keytype)
    2232     ALLOCATE(keytype(keymemsize+memslabs),stat=ier)
    2233     IF (ier /= 0) THEN
    2234       WRITE(*,*) &
    2235  &      'getin_allockeys : Can not allocate keytype to size ', &
    2236  &      keymemsize+memslabs
    2237       STOP
    2238     ENDIF
    2239     keytype(1:keymemsize) = tmp_int(1:keymemsize)
    2240 !-
    2241     tmp_int(1:keymemsize) = keycompress(1:keymemsize)
    2242     DEALLOCATE(keycompress)
    2243     ALLOCATE(keycompress(keymemsize+memslabs),stat=ier)
    2244     IF (ier /= 0) THEN
    2245       WRITE(*,*) &
    2246  &      'getin_allockeys : Can not allocate keycompress to size ', &
    2247  &      keymemsize+memslabs
    2248       STOP
    2249     ENDIF
    2250     keycompress(:) = -1
    2251     keycompress(1:keymemsize) = tmp_int(1:keymemsize)
    2252 !-
    2253     tmp_int(1:keymemsize) = keyfromfile(1:keymemsize)
    2254     DEALLOCATE(keyfromfile)
    2255     ALLOCATE(keyfromfile(keymemsize+memslabs),stat=ier)
    2256     IF (ier /= 0) THEN
    2257       WRITE(*,*) &
    2258  &      'getin_allockeys : Can not allocate keyfromfile to size ', &
    2259  &      keymemsize+memslabs
    2260       STOP
    2261     ENDIF
    2262     keyfromfile(1:keymemsize) = tmp_int(1:keymemsize)
    2263 !-
    2264     tmp_int(1:keymemsize) = keymemstart(1:keymemsize)
    2265     DEALLOCATE(keymemstart)
    2266     ALLOCATE(keymemstart(keymemsize+memslabs),stat=ier)
    2267     IF (ier /= 0) THEN
    2268       WRITE(*,*) &
    2269  &      'getin_allockeys : Can not allocate keymemstart to size ', &
    2270  &      keymemsize+memslabs
    2271       STOP
    2272     ENDIF
    2273     keymemstart(1:keymemsize) = tmp_int(1:keymemsize)
    2274 !-
    2275     tmp_int(1:keymemsize) = keymemlen(1:keymemsize)
    2276     DEALLOCATE(keymemlen)
    2277     ALLOCATE(keymemlen(keymemsize+memslabs),stat=ier)
    2278     IF (ier /= 0) THEN
    2279       WRITE(*,*) &
    2280  &      'getin_allockeys : Can not allocate keymemlen to size ', &
    2281  &      keymemsize+memslabs
    2282       STOP
    2283     ENDIF
    2284     keymemlen(1:keymemsize) = tmp_int(1:keymemsize)
    2285 !-
     1460      CALL ipslerr (3,'getin_allockeys', &
     1461 &     'Can not allocate key_tab', &
     1462 &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1463    ENDIF
     1464    key_tab(:)%keycompress = -1
     1465    key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize)
     1466    DEALLOCATE(tmp_key_tab)
    22861467    keymemsize = keymemsize+memslabs
    2287 !-
    2288     DEALLOCATE(tmp_int)
    2289     DEALLOCATE(tmp_str)
    22901468  ENDIF
    22911469!-----------------------------
    … …  
    22971475!---------------------------------------------------------------------
    22981476!- Allocate the memory of the data base for all 4 types of memory
    2299 !-
    2300 !- 1 = INTEGER
    2301 !- 2 = REAL
    2302 !- 3 = CHAR
    2303 !- 4 = LOGICAL
    2304 !---------------------------------------------------------------------
    2305   IMPLICIT NONE
    2306 !-
    2307   INTEGER :: type, len_wanted
     1477!- INTEGER / REAL / CHARACTER / LOGICAL
     1478!---------------------------------------------------------------------
     1479  IMPLICIT NONE
     1480!-
     1481  INTEGER :: type,len_wanted
    23081482!-
    23091483  INTEGER,ALLOCATABLE :: tmp_int(:)
     1484  REAL,ALLOCATABLE :: tmp_real(:)
    23101485  CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:)
    2311   REAL,ALLOCATABLE :: tmp_real(:)
    23121486  LOGICAL,ALLOCATABLE :: tmp_logic(:)
    23131487  INTEGER :: ier
     1488  CHARACTER(LEN=20) :: c_tmp
    23141489!---------------------------------------------------------------------
    23151490  SELECT CASE (type)
    2316   CASE(1)
    2317     IF (intmemsize == 0) THEN
    2318       ALLOCATE(intmem(memslabs),stat=ier)
     1491  CASE(k_i)
     1492    IF (i_memsize == 0) THEN
     1493      ALLOCATE(i_mem(memslabs),stat=ier)
    23191494      IF (ier /= 0) THEN
    2320         WRITE(*,*) &
    2321  &    'getin_allocmem : Unable to allocate db-memory intmem to ', &
    2322  &    memslabs
    2323         STOP
    2324       ENDIF
    2325       intmemsize=memslabs
     1495        WRITE (UNIT=c_tmp,FMT=*) memslabs
     1496        CALL ipslerr (3,'getin_allocmem', &
     1497 &       'Unable to allocate db-memory', &
     1498 &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1499      ENDIF
     1500      i_memsize=memslabs
    23261501    ELSE
    2327       ALLOCATE(tmp_int(intmemsize),stat=ier)
     1502      ALLOCATE(tmp_int(i_memsize),stat=ier)
    23281503      IF (ier /= 0) THEN
    2329         WRITE(*,*) &
    2330  &    'getin_allocmem : Unable to allocate tmp_int to ', &
    2331  &    intmemsize
    2332         STOP
    2333       ENDIF
    2334       tmp_int(1:intmemsize) = intmem(1:intmemsize)
    2335       DEALLOCATE(intmem)
    2336       ALLOCATE(intmem(intmemsize+MAX(memslabs,len_wanted)),stat=ier)
     1504        WRITE (UNIT=c_tmp,FMT=*) i_memsize
     1505        CALL ipslerr (3,'getin_allocmem', &
     1506 &       'Unable to allocate tmp_int', &
     1507 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1508      ENDIF
     1509      tmp_int(1:i_memsize) = i_mem(1:i_memsize)
     1510      DEALLOCATE(i_mem)
     1511      ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier)
    23371512      IF (ier /= 0) THEN
    2338         WRITE(*,*) &
    2339  &    'getin_allocmem : Unable to re-allocate db-memory intmem to ', &
    2340  &    intmemsize+MAX(memslabs,len_wanted)
    2341         STOP
    2342       ENDIF
    2343       intmem(1:intmemsize) = tmp_int(1:intmemsize)
    2344       intmemsize = intmemsize+MAX(memslabs,len_wanted)
     1513        WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted)
     1514        CALL ipslerr (3,'getin_allocmem', &
     1515 &       'Unable to re-allocate db-memory', &
     1516 &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1517      ENDIF
     1518      i_mem(1:i_memsize) = tmp_int(1:i_memsize)
     1519      i_memsize = i_memsize+MAX(memslabs,len_wanted)
    23451520      DEALLOCATE(tmp_int)
    23461521    ENDIF
    2347   CASE(2)
    2348     IF (realmemsize == 0) THEN
    2349       ALLOCATE(realmem(memslabs),stat=ier)
     1522  CASE(k_r)
     1523    IF (r_memsize == 0) THEN
     1524      ALLOCATE(r_mem(memslabs),stat=ier)
    23501525      IF (ier /= 0) THEN
    2351         WRITE(*,*) &
    2352  &    'getin_allocmem : Unable to allocate db-memory realmem to ', &
    2353  &    memslabs
    2354         STOP
    2355       ENDIF
    2356       realmemsize =  memslabs
     1526        WRITE (UNIT=c_tmp,FMT=*) memslabs
     1527        CALL ipslerr (3,'getin_allocmem', &
     1528 &       'Unable to allocate db-memory', &
     1529 &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1530      ENDIF
     1531      r_memsize =  memslabs
    23571532    ELSE
    2358       ALLOCATE(tmp_real(realmemsize),stat=ier)
     1533      ALLOCATE(tmp_real(r_memsize),stat=ier)
    23591534      IF (ier /= 0) THEN
    2360         WRITE(*,*) &
    2361  &    'getin_allocmem : Unable to allocate tmp_real to ', &
    2362  &    realmemsize
    2363         STOP
    2364       ENDIF
    2365       tmp_real(1:realmemsize) = realmem(1:realmemsize)
    2366       DEALLOCATE(realmem)
    2367       ALLOCATE(realmem(realmemsize+MAX(memslabs,len_wanted)),stat=ier)
     1535        WRITE (UNIT=c_tmp,FMT=*) r_memsize
     1536        CALL ipslerr (3,'getin_allocmem', &
     1537 &       'Unable to allocate tmp_real', &
     1538 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1539      ENDIF
     1540      tmp_real(1:r_memsize) = r_mem(1:r_memsize)
     1541      DEALLOCATE(r_mem)
     1542      ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier)
    23681543      IF (ier /= 0) THEN
    2369         WRITE(*,*) &
    2370  &    'getin_allocmem : Unable to re-allocate db-memory realmem to ', &
    2371  &    realmemsize+MAX(memslabs,len_wanted)
    2372         STOP
    2373       ENDIF
    2374       realmem(1:realmemsize) = tmp_real(1:realmemsize)
    2375       realmemsize = realmemsize+MAX(memslabs,len_wanted)
     1544        WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted)
     1545        CALL ipslerr (3,'getin_allocmem', &
     1546 &       'Unable to re-allocate db-memory', &
     1547 &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1548      ENDIF
     1549      r_mem(1:r_memsize) = tmp_real(1:r_memsize)
     1550      r_memsize = r_memsize+MAX(memslabs,len_wanted)
    23761551      DEALLOCATE(tmp_real)
    23771552    ENDIF
    2378   CASE(3)
    2379     IF (charmemsize == 0) THEN
    2380       ALLOCATE(charmem(memslabs),stat=ier)
     1553  CASE(k_c)
     1554    IF (c_memsize == 0) THEN
     1555      ALLOCATE(c_mem(memslabs),stat=ier)
    23811556      IF (ier /= 0) THEN
    2382         WRITE(*,*) &
    2383  &    'getin_allocmem : Unable to allocate db-memory charmem to ', &
    2384  &    memslabs
    2385         STOP
    2386       ENDIF
    2387       charmemsize = memslabs
     1557        WRITE (UNIT=c_tmp,FMT=*) memslabs
     1558        CALL ipslerr (3,'getin_allocmem', &
     1559 &       'Unable to allocate db-memory', &
     1560 &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1561      ENDIF
     1562      c_memsize = memslabs
    23881563    ELSE
    2389       ALLOCATE(tmp_char(charmemsize),stat=ier)
     1564      ALLOCATE(tmp_char(c_memsize),stat=ier)
    23901565      IF (ier /= 0) THEN
    2391         WRITE(*,*) &
    2392  &    'getin_allocmem : Unable to allocate tmp_char to ', &
    2393  &    charmemsize
    2394         STOP
    2395       ENDIF
    2396       tmp_char(1:charmemsize) = charmem(1:charmemsize)
    2397       DEALLOCATE(charmem)
    2398       ALLOCATE(charmem(charmemsize+MAX(memslabs,len_wanted)),stat=ier)
     1566        WRITE (UNIT=c_tmp,FMT=*) c_memsize
     1567        CALL ipslerr (3,'getin_allocmem', &
     1568 &       'Unable to allocate tmp_char', &
     1569 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1570      ENDIF
     1571      tmp_char(1:c_memsize) = c_mem(1:c_memsize)
     1572      DEALLOCATE(c_mem)
     1573      ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier)
    23991574      IF (ier /= 0) THEN
    2400         WRITE(*,*) &
    2401  &    'getin_allocmem : Unable to re-allocate db-memory charmem to ', &
    2402  &    charmemsize+MAX(memslabs,len_wanted)
    2403         STOP
    2404       ENDIF
    2405       charmem(1:charmemsize) = tmp_char(1:charmemsize)
    2406       charmemsize = charmemsize+MAX(memslabs,len_wanted)
     1575        WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted)
     1576        CALL ipslerr (3,'getin_allocmem', &
     1577 &       'Unable to re-allocate db-memory', &
     1578 &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1579      ENDIF
     1580      c_mem(1:c_memsize) = tmp_char(1:c_memsize)
     1581      c_memsize = c_memsize+MAX(memslabs,len_wanted)
    24071582      DEALLOCATE(tmp_char)
    24081583    ENDIF
    2409   CASE(4)
    2410     IF (logicmemsize == 0) THEN
    2411       ALLOCATE(logicmem(memslabs),stat=ier)
     1584  CASE(k_l)
     1585    IF (l_memsize == 0) THEN
     1586      ALLOCATE(l_mem(memslabs),stat=ier)
    24121587      IF (ier /= 0) THEN
    2413         WRITE(*,*) &
    2414  &    'getin_allocmem : Unable to allocate db-memory logicmem to ', &
    2415  &    memslabs
    2416         STOP
    2417       ENDIF
    2418       logicmemsize = memslabs
     1588        WRITE (UNIT=c_tmp,FMT=*) memslabs
     1589        CALL ipslerr (3,'getin_allocmem', &
     1590 &       'Unable to allocate db-memory', &
     1591 &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1592      ENDIF
     1593      l_memsize = memslabs
    24191594    ELSE
    2420       ALLOCATE(tmp_logic(logicmemsize),stat=ier)
     1595      ALLOCATE(tmp_logic(l_memsize),stat=ier)
    24211596      IF (ier /= 0) THEN
    2422         WRITE(*,*) &
    2423  &    'getin_allocmem : Unable to allocate tmp_logic to ', &
    2424  &    logicmemsize
    2425         STOP
    2426       ENDIF
    2427       tmp_logic(1:logicmemsize) = logicmem(1:logicmemsize)
    2428       DEALLOCATE(logicmem)
    2429       ALLOCATE(logicmem(logicmemsize+MAX(memslabs,len_wanted)),stat=ier)
     1597        WRITE (UNIT=c_tmp,FMT=*) l_memsize
     1598        CALL ipslerr (3,'getin_allocmem', &
     1599 &       'Unable to allocate tmp_logic', &
     1600 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1601      ENDIF
     1602      tmp_logic(1:l_memsize) = l_mem(1:l_memsize)
     1603      DEALLOCATE(l_mem)
     1604      ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier)
    24301605      IF (ier /= 0) THEN
    2431         WRITE(*,*) &
    2432  &    'getin_allocmem : Unable to re-allocate db-memory logicmem to ', &
    2433  &    logicmemsize+MAX(memslabs,len_wanted)
    2434         STOP
    2435       ENDIF
    2436       logicmem(1:logicmemsize) = tmp_logic(1:logicmemsize)
    2437       logicmemsize = logicmemsize+MAX(memslabs,len_wanted)
     1606        WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted)
     1607        CALL ipslerr (3,'getin_allocmem', &
     1608 &       'Unable to re-allocate db-memory', &
     1609 &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
     1610      ENDIF
     1611      l_mem(1:l_memsize) = tmp_logic(1:l_memsize)
     1612      l_memsize = l_memsize+MAX(memslabs,len_wanted)
    24381613      DEALLOCATE(tmp_logic)
    24391614    ENDIF
    24401615  CASE DEFAULT
    2441     WRITE(*,*) 'getin_allocmem : Unknown type : ',type
    2442     STOP
     1616    CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ')
    24431617  END SELECT
    24441618!----------------------------
    … …  
    24471621!===
    24481622!-
     1623SUBROUTINE getin_alloctxt ()
     1624!---------------------------------------------------------------------
     1625  IMPLICIT NONE
     1626!-
     1627  CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:)
     1628  CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:)
     1629  INTEGER,ALLOCATABLE :: tmp_int(:)
     1630!-
     1631  INTEGER :: ier
     1632  CHARACTER(LEN=20) :: c_tmp1,c_tmp2
     1633!---------------------------------------------------------------------
     1634  IF (i_txtsize == 0) THEN
     1635!---
     1636!-- Nothing exists in memory arrays and it is easy to do.
     1637!---
     1638    WRITE (UNIT=c_tmp1,FMT=*) i_txtslab
     1639    ALLOCATE(fichier(i_txtslab),stat=ier)
     1640    IF (ier /= 0) THEN
     1641      CALL ipslerr (3,'getin_alloctxt', &
     1642 &     'Can not allocate fichier', &
     1643 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
     1644    ENDIF
     1645!---
     1646    ALLOCATE(targetlist(i_txtslab),stat=ier)
     1647    IF (ier /= 0) THEN
     1648      CALL ipslerr (3,'getin_alloctxt', &
     1649 &     'Can not allocate targetlist', &
     1650 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
     1651    ENDIF
     1652!---
     1653    ALLOCATE(fromfile(i_txtslab),stat=ier)
     1654    IF (ier /= 0) THEN
     1655      CALL ipslerr (3,'getin_alloctxt', &
     1656 &     'Can not allocate fromfile', &
     1657 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
     1658    ENDIF
     1659!---
     1660    ALLOCATE(compline(i_txtslab),stat=ier)
     1661    IF (ier /= 0) THEN
     1662      CALL ipslerr (3,'getin_alloctxt', &
     1663 &     'Can not allocate compline', &
     1664 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
     1665    ENDIF
     1666!---
     1667    nb_lines = 0
     1668    i_txtsize = i_txtslab
     1669  ELSE
     1670!---
     1671!-- There is something already in the memory,
     1672!-- we need to transfer and reallocate.
     1673!---
     1674    WRITE (UNIT=c_tmp1,FMT=*) i_txtsize
     1675    WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab
     1676    ALLOCATE(tmp_fic(i_txtsize),stat=ier)
     1677    IF (ier /= 0) THEN
     1678      CALL ipslerr (3,'getin_alloctxt', &
     1679 &     'Can not allocate tmp_fic', &
     1680 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
     1681    ENDIF
     1682    tmp_fic(1:i_txtsize) = fichier(1:i_txtsize)
     1683    DEALLOCATE(fichier)
     1684    ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier)
     1685    IF (ier /= 0) THEN
     1686      CALL ipslerr (3,'getin_alloctxt', &
     1687 &     'Can not allocate fichier', &
     1688 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
     1689    ENDIF
     1690    fichier(1:i_txtsize) = tmp_fic(1:i_txtsize)
     1691    DEALLOCATE(tmp_fic)
     1692!---
     1693    ALLOCATE(tmp_tgl(i_txtsize),stat=ier)
     1694    IF (ier /= 0) THEN
     1695      CALL ipslerr (3,'getin_alloctxt', &
     1696 &     'Can not allocate tmp_tgl', &
     1697 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
     1698    ENDIF
     1699    tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize)
     1700    DEALLOCATE(targetlist)
     1701    ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier)
     1702    IF (ier /= 0) THEN
     1703      CALL ipslerr (3,'getin_alloctxt', &
     1704 &     'Can not allocate targetlist', &
     1705 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
     1706    ENDIF
     1707    targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize)
     1708    DEALLOCATE(tmp_tgl)
     1709!---
     1710    ALLOCATE(tmp_int(i_txtsize),stat=ier)
     1711    IF (ier /= 0) THEN
     1712      CALL ipslerr (3,'getin_alloctxt', &
     1713 &     'Can not allocate tmp_int', &
     1714 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
     1715    ENDIF
     1716    tmp_int(1:i_txtsize) = fromfile(1:i_txtsize)
     1717    DEALLOCATE(fromfile)
     1718    ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier)
     1719    IF (ier /= 0) THEN
     1720      CALL ipslerr (3,'getin_alloctxt', &
     1721 &     'Can not allocate fromfile', &
     1722 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
     1723    ENDIF
     1724    fromfile(1:i_txtsize) = tmp_int(1:i_txtsize)
     1725!---
     1726    tmp_int(1:i_txtsize) = compline(1:i_txtsize)
     1727    DEALLOCATE(compline)
     1728    ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier)
     1729    IF (ier /= 0) THEN
     1730      CALL ipslerr (3,'getin_alloctxt', &
     1731 &     'Can not allocate compline', &
     1732 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
     1733    ENDIF
     1734    compline(1:i_txtsize) = tmp_int(1:i_txtsize)
     1735    DEALLOCATE(tmp_int)
     1736!---
     1737    i_txtsize = i_txtsize+i_txtslab
     1738  ENDIF
     1739!----------------------------
     1740END SUBROUTINE getin_alloctxt
     1741!-
     1742!===
     1743!-
    24491744SUBROUTINE getin_dump (fileprefix)
    24501745!---------------------------------------------------------------------
    2451 !- This subroutine will dump the content of the database into  file
    2452 !- which has the same format as the run.def. The idea is that the user
    2453 !- can see which parameters were used and re-use the file for another
    2454 !- run.
    2455 !-
    2456 !- The argument file allows the user to change the name of the file
    2457 !- in which the data will be archived
    2458 !---------------------------------------------------------------------
    24591746  IMPLICIT NONE
    24601747!-
    24611748  CHARACTER(*),OPTIONAL :: fileprefix
    24621749!-
    2463   CHARACTER(LEN=80) :: usedfileprefix = "used"
     1750  CHARACTER(LEN=80) :: usedfileprefix
    24641751  INTEGER :: ikey,if,iff,iv
    2465   CHARACTER(LEN=3) :: tmp3
    2466   CHARACTER(LEN=100) :: tmp_str, used_filename
     1752  CHARACTER(LEN=20) :: c_tmp
     1753  CHARACTER(LEN=100) :: tmp_str,used_filename
    24671754  LOGICAL :: check = .FALSE.
    24681755!---------------------------------------------------------------------
    24691756  IF (PRESENT(fileprefix)) THEN
    2470     usedfileprefix = fileprefix(1:MIN(len_trim(fileprefix),80))
     1757    usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80))
     1758  ELSE
     1759    usedfileprefix = "used"
    24711760  ENDIF
    24721761!-
    … …  
    24791768      WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys
    24801769    ENDIF
    2481     OPEN(unit=76,file=used_filename)
    2482 !-
     1770    OPEN (UNIT=22,FILE=used_filename)
     1771!---
    24831772!-- If this is the first file we need to add the list
    24841773!-- of file which belong to it
    2485 !-
    2486     IF ( (if == 1) .AND. (nbfiles > 1) ) THEN
    2487       WRITE(76,*) '# '
    2488       WRITE(76,*) '# This file is linked to the following files :'
    2489       WRITE(76,*) '# '
     1774    IF ( (if == 1).AND.(nbfiles > 1) ) THEN
     1775      WRITE(22,*) '# '
     1776      WRITE(22,*) '# This file is linked to the following files :'
     1777      WRITE(22,*) '# '
    24901778      DO iff=2,nbfiles
    2491         WRITE(76,*) 'INCLUDEDEF = ',TRIM(filelist(iff))
     1779        WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff))
    24921780      ENDDO
    2493       WRITE(76,*) '# '
     1781      WRITE(22,*) '# '
    24941782    ENDIF
    24951783!---
    24961784    DO ikey=1,nb_keys
    2497 !-
    2498 !---- Is this key form this file ?
    2499 !-
    2500       IF (keyfromfile(ikey) == if) THEN
    2501 !-
    2502 !---- Write some comments
    2503 !-
    2504         WRITE(76,*) '#'
    2505         SELECT CASE (keystatus(ikey))
     1785!-----
     1786!---- Is this key from this file ?
     1787      IF (key_tab(ikey)%keyfromfile == if) THEN
     1788!-------
     1789!------ Write some comments
     1790        WRITE(22,*) '#'
     1791        SELECT CASE (key_tab(ikey)%keystatus)
    25061792        CASE(1)
    2507           WRITE(76,*) '# Values of ', &
    2508  &          TRIM(keystr(ikey)),' comes from the run.def.'
     1793          WRITE(22,*) '# Values of ', &
     1794 &          TRIM(key_tab(ikey)%keystr),' comes from the run.def.'
    25091795        CASE(2)
    2510           WRITE(76,*) '# Values of ', &
    2511  &          TRIM(keystr(ikey)),' are all defaults.'
     1796          WRITE(22,*) '# Values of ', &
     1797 &          TRIM(key_tab(ikey)%keystr),' are all defaults.'
    25121798        CASE(3)
    2513           WRITE(76,*) '# Values of ', &
    2514  &          TRIM(keystr(ikey)),' are a mix of run.def and defaults.'
     1799          WRITE(22,*) '# Values of ', &
     1800 &          TRIM(key_tab(ikey)%keystr), &
     1801 &          ' are a mix of run.def and defaults.'
    25151802        CASE DEFAULT
    2516           WRITE(76,*) '# Dont know from where the value of ', &
    2517  &          TRIM(keystr(ikey)),' comes.'
     1803          WRITE(22,*) '# Dont know from where the value of ', &
     1804 &          TRIM(key_tab(ikey)%keystr),' comes.'
    25181805        END SELECT
    2519         WRITE(76,*) '#'
    2520 !-
    2521 !---- Write the values
    2522 !-
    2523         SELECT CASE (keytype(ikey))
    2524 !-
    2525         CASE(1)
    2526           IF (keymemlen(ikey) == 1) THEN
    2527             IF (keycompress(ikey) < 0) THEN
    2528               WRITE(76,*) &
    2529  &              TRIM(keystr(ikey)),' = ',intmem(keymemstart(ikey))
     1806        WRITE(22,*) '#'
     1807!-------
     1808!------ Write the values
     1809        SELECT CASE (key_tab(ikey)%keytype)
     1810        CASE(k_i)
     1811          IF (key_tab(ikey)%keymemlen == 1) THEN
     1812            IF (key_tab(ikey)%keycompress < 0) THEN
     1813              WRITE(22,*) &
     1814 &              TRIM(key_tab(ikey)%keystr), &
     1815 &              ' = ',i_mem(key_tab(ikey)%keymemstart)
    25301816            ELSE
    2531               WRITE(76,*) &
    2532  &              TRIM(keystr(ikey)),' = ',keycompress(ikey), &
    2533  &              ' * ',intmem(keymemstart(ikey))
     1817              WRITE(22,*) &
     1818 &              TRIM(key_tab(ikey)%keystr), &
     1819 &              ' = ',key_tab(ikey)%keycompress, &
     1820 &              ' * ',i_mem(key_tab(ikey)%keymemstart)
    25341821            ENDIF
    25351822          ELSE
    2536             DO iv=0,keymemlen(ikey)-1
    2537               WRITE(tmp3,'(I3.3)') iv+1
    2538               WRITE(76,*) &
    2539  &              TRIM(keystr(ikey)),'__',tmp3, &
    2540  &              ' = ',intmem(keymemstart(ikey)+iv)
     1823            DO iv=0,key_tab(ikey)%keymemlen-1
     1824              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
     1825              WRITE(22,*) &
     1826 &              TRIM(key_tab(ikey)%keystr), &
     1827 &              '__',TRIM(ADJUSTL(c_tmp)), &
     1828 &              ' = ',i_mem(key_tab(ikey)%keymemstart+iv)
    25411829            ENDDO
    25421830          ENDIF
    2543 !-
    2544         CASE(2)
    2545           IF (keymemlen(ikey) == 1) THEN
    2546             IF (keycompress(ikey) < 0) THEN
    2547               WRITE(76,*) &
    2548  &              TRIM(keystr(ikey)),' = ',realmem(keymemstart(ikey))
     1831        CASE(k_r)
     1832          IF (key_tab(ikey)%keymemlen == 1) THEN
     1833            IF (key_tab(ikey)%keycompress < 0) THEN
     1834              WRITE(22,*) &
     1835 &              TRIM(key_tab(ikey)%keystr), &
     1836 &              ' = ',r_mem(key_tab(ikey)%keymemstart)
    25491837            ELSE
    2550               WRITE(76,*) &
    2551  &              TRIM(keystr(ikey)),' = ',keycompress(ikey),&
    2552                    & ' * ',realmem(keymemstart(ikey))
     1838              WRITE(22,*) &
     1839 &              TRIM(key_tab(ikey)%keystr), &
     1840 &              ' = ',key_tab(ikey)%keycompress, &
     1841                   & ' * ',r_mem(key_tab(ikey)%keymemstart)
    25531842            ENDIF
    25541843          ELSE
    2555             DO iv=0,keymemlen(ikey)-1
    2556               WRITE(tmp3,'(I3.3)') iv+1
    2557               WRITE(76,*) &
    2558  &              TRIM(keystr(ikey)),'__',tmp3, &
    2559  &              ' = ',realmem(keymemstart(ikey)+iv)
     1844            DO iv=0,key_tab(ikey)%keymemlen-1
     1845              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
     1846              WRITE(22,*) &
     1847 &              TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), &
     1848 &              ' = ',r_mem(key_tab(ikey)%keymemstart+iv)
    25601849            ENDDO
    25611850          ENDIF
    2562         CASE(3)
    2563           IF (keymemlen(ikey) == 1) THEN
    2564             tmp_str = charmem(keymemstart(ikey))
    2565             WRITE(76,*) TRIM(keystr(ikey)),' = ',TRIM(tmp_str)
     1851        CASE(k_c)
     1852          IF (key_tab(ikey)%keymemlen == 1) THEN
     1853            tmp_str = c_mem(key_tab(ikey)%keymemstart)
     1854            WRITE(22,*) TRIM(key_tab(ikey)%keystr), &
     1855 &              ' = ',TRIM(tmp_str)
    25661856          ELSE
    2567             DO iv=0,keymemlen(ikey)-1
    2568               WRITE(tmp3,'(I3.3)') iv+1
    2569               tmp_str = charmem(keymemstart(ikey)+iv)
    2570               WRITE(76,*) &
    2571  &              TRIM(keystr(ikey)),'__',tmp3,' = ',TRIM(tmp_str)
     1857            DO iv=0,key_tab(ikey)%keymemlen-1
     1858              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
     1859              tmp_str = c_mem(key_tab(ikey)%keymemstart+iv)
     1860              WRITE(22,*) &
     1861 &              TRIM(key_tab(ikey)%keystr), &
     1862 &              '__',TRIM(ADJUSTL(c_tmp)), &
     1863 &              ' = ',TRIM(tmp_str)
    25721864            ENDDO
    25731865          ENDIF
    2574         CASE(4)
    2575           IF (keymemlen(ikey) == 1) THEN
    2576             IF (logicmem(keymemstart(ikey))) THEN
    2577               WRITE(76,*) TRIM(keystr(ikey)),' = TRUE '
     1866        CASE(k_l)
     1867          IF (key_tab(ikey)%keymemlen == 1) THEN
     1868            IF (l_mem(key_tab(ikey)%keymemstart)) THEN
     1869              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE '
    25781870            ELSE
    2579               WRITE(76,*) TRIM(keystr(ikey)),' = FALSE '
     1871              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE '
    25801872            ENDIF
    25811873          ELSE
    2582             DO iv=0,keymemlen(ikey)-1
    2583               WRITE(tmp3,'(I3.3)') iv+1
    2584               IF (logicmem(keymemstart(ikey)+iv)) THEN
    2585                 WRITE(76,*) TRIM(keystr(ikey)),'__',tmp3,' = TRUE '
     1874            DO iv=0,key_tab(ikey)%keymemlen-1
     1875              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
     1876              IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN
     1877                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
     1878 &                          TRIM(ADJUSTL(c_tmp)),' = TRUE '
    25861879              ELSE
    2587                 WRITE(76,*) TRIM(keystr(ikey)),'__',tmp3,' = FALSE '
     1880                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
     1881 &                          TRIM(ADJUSTL(c_tmp)),' = FALSE '
    25881882              ENDIF
    25891883            ENDDO
    25901884          ENDIF
    2591 !-
    25921885        CASE DEFAULT
    2593           WRITE(*,*) &
    2594  &          'FATAL ERROR : Unknown type for variable ', &
    2595  &          TRIM(keystr(ikey))
    2596           STOP 'getin_dump'
     1886          CALL ipslerr (3,'getin_dump', &
     1887 &         'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), &
     1888 &         ' ',' ')
    25971889        END SELECT
    25981890      ENDIF
    25991891    ENDDO
    26001892!-
    2601     CLOSE(unit=76)
     1893    CLOSE(UNIT=22)
    26021894!-
    26031895  ENDDO
    26041896!------------------------
    26051897END SUBROUTINE getin_dump
    2606 !-
    2607 !===
    2608 !-
     1898!===
     1899SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v)
     1900!---------------------------------------------------------------------
     1901!- Returns the type of the argument (mutually exclusive)
     1902!---------------------------------------------------------------------
     1903  IMPLICIT NONE
     1904!-
     1905  INTEGER,INTENT(OUT) :: k_typ
     1906  CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp
     1907  INTEGER,DIMENSION(:),OPTIONAL          :: i_v
     1908  REAL,DIMENSION(:),OPTIONAL             :: r_v
     1909  LOGICAL,DIMENSION(:),OPTIONAL          :: l_v
     1910  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v
     1911!---------------------------------------------------------------------
     1912  k_typ = 0
     1913  IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) &
     1914 &    /= 1) THEN
     1915    CALL ipslerr (3,'get_qtyp', &
     1916 &   'Invalid number of optional arguments','(/= 1)',' ')
     1917  ENDIF
     1918!-
     1919  IF     (PRESENT(i_v)) THEN
     1920    k_typ = k_i
     1921    c_vtyp = 'INTEGER'
     1922  ELSEIF (PRESENT(r_v)) THEN
     1923    k_typ = k_r
     1924    c_vtyp = 'REAL'
     1925  ELSEIF (PRESENT(c_v)) THEN
     1926    k_typ = k_c
     1927    c_vtyp = 'CHARACTER'
     1928  ELSEIF (PRESENT(l_v)) THEN
     1929    k_typ = k_l
     1930    c_vtyp = 'LOGICAL'
     1931  ENDIF
     1932!----------------------
     1933END SUBROUTINE get_qtyp
     1934!===
     1935SUBROUTINE get_findkey (i_tab,c_key,pos)
     1936!---------------------------------------------------------------------
     1937!- This subroutine looks for a key in a table
     1938!---------------------------------------------------------------------
     1939!- INPUT
     1940!-   i_tab  : 1 -> search in key_tab(1:nb_keys)%keystr
     1941!-            2 -> search in targetlist(1:nb_lines)
     1942!-   c_key  : Name of the key we are looking for
     1943!- OUTPUT
     1944!-   pos    : -1 if key not found, else value in the table
     1945!---------------------------------------------------------------------
     1946  IMPLICIT NONE
     1947!-
     1948  INTEGER,INTENT(in) :: i_tab
     1949  CHARACTER(LEN=*),INTENT(in) :: c_key
     1950  INTEGER,INTENT(out) :: pos
     1951!-
     1952  INTEGER :: ikey_max,ikey
     1953  CHARACTER(LEN=l_n) :: c_q_key
     1954!---------------------------------------------------------------------
     1955  pos = -1
     1956  IF     (i_tab == 1) THEN
     1957    ikey_max = nb_keys
     1958  ELSEIF (i_tab == 2) THEN
     1959    ikey_max = nb_lines
     1960  ELSE
     1961    ikey_max = 0
     1962  ENDIF
     1963  IF ( ikey_max > 0 ) THEN
     1964    DO ikey=1,ikey_max
     1965      IF (i_tab == 1) THEN
     1966        c_q_key = key_tab(ikey)%keystr
     1967      ELSE
     1968        c_q_key = targetlist(ikey)
     1969      ENDIF
     1970      IF (TRIM(c_q_key) == TRIM(c_key)) THEN
     1971        pos = ikey
     1972        EXIT
     1973      ENDIF
     1974    ENDDO
     1975  ENDIF
     1976!-------------------------
     1977END SUBROUTINE get_findkey
     1978!===
     1979!------------------
    26091980END MODULE ioipsl_getincom

  • LMDZ4/branches/LMDZ4-dev/libf/bibio/ioipsl_stringop.F90

    r1185 r1186  
    1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    2 ! Module and routines in this file are taken from IOIPSL
    3 ! files stringop.f90
    4 ! Module names has been changed to avoid problems
    5 ! if compiling model with IOIPSL library
    6 ! Ehouarn - March 2009
    7 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     1!
     2! $Id$
     3!
     4! Module/Routines extracted from IOIPSL v2_1_8
    85!
    96MODULE ioipsl_stringop
    10 !---------------------------------------------------------------------
    11 !-
    12   INTEGER, DIMENSION(30) :: &
    13        & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, &
    14        & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/)
     7!-
     8!$Id: stringop.f90 386 2008-09-04 08:38:48Z bellier $
     9!-
     10! This software is governed by the CeCILL license
     11! See IOIPSL/IOIPSL_License_CeCILL.txt
     12!---------------------------------------------------------------------
     13!-
     14  INTEGER,DIMENSION(30) :: &
     15 & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, &
     16 & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/)
    1517!-
    1618!---------------------------------------------------------------------
    1719CONTAINS
    1820!=
    19    SUBROUTINE cmpblank (str)
    20 !---------------------------------------------------------------------
    21 !-
    22 !---------------------------------------------------------------------
    23    CHARACTER(LEN=*),INTENT(inout) :: str
    24 !-
    25    INTEGER :: lcc,ipb
    26 !---------------------------------------------------------------------
    27    lcc = LEN_TRIM(str)
    28    ipb = 1
    29    DO
    30      IF (ipb >= lcc)   EXIT
    31      IF (str(ipb:ipb+1) == '  ') THEN
    32        str(ipb+1:) = str(ipb+2:lcc)
    33        lcc = lcc-1
    34      ELSE
    35        ipb = ipb+1
    36      ENDIF
    37    ENDDO
    38 !-------------------------
    39    END SUBROUTINE cmpblank
    40 !=
    41    INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r)
     21SUBROUTINE cmpblank (str)
     22!---------------------------------------------------------------------
     23!- Compact blanks
     24!---------------------------------------------------------------------
     25  CHARACTER(LEN=*),INTENT(inout) :: str
     26!-
     27  INTEGER :: lcc,ipb
     28!---------------------------------------------------------------------
     29  lcc = LEN_TRIM(str)
     30  ipb = 1
     31  DO
     32    IF (ipb >= lcc)   EXIT
     33    IF (str(ipb:ipb+1) == '  ') THEN
     34      str(ipb+1:) = str(ipb+2:lcc)
     35      lcc = lcc-1
     36    ELSE
     37      ipb = ipb+1
     38    ENDIF
     39  ENDDO
     40!----------------------
     41END SUBROUTINE cmpblank
     42!===
     43INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r)
    4244!---------------------------------------------------------------------
    4345!- Finds number of occurences of c_r in c_c
    4446!---------------------------------------------------------------------
    45    IMPLICIT NONE
    46 !-
    47    CHARACTER(LEN=*),INTENT(in) :: c_c
    48    INTEGER,INTENT(IN) :: l_c
    49    CHARACTER(LEN=*),INTENT(in) :: c_r
    50    INTEGER,INTENT(IN) :: l_r
    51 !-
    52    INTEGER :: ipos,indx,ires
    53 !---------------------------------------------------------------------
    54    cntpos = 0
    55    ipos   = 1
    56    DO
    57      indx = INDEX(c_c(ipos:l_c),c_r(1:l_r))
    58      IF (indx > 0) THEN
    59        cntpos = cntpos+1
    60        ipos   = ipos+indx+l_r-1
    61      ELSE
    62        EXIT
    63      ENDIF
    64    ENDDO
     47  IMPLICIT NONE
     48!-
     49  CHARACTER(LEN=*),INTENT(in) :: c_c
     50  INTEGER,INTENT(IN) :: l_c
     51  CHARACTER(LEN=*),INTENT(in) :: c_r
     52  INTEGER,INTENT(IN) :: l_r
     53!-
     54  INTEGER :: ipos,indx
     55!---------------------------------------------------------------------
     56  cntpos = 0
     57  ipos   = 1
     58  DO
     59    indx = INDEX(c_c(ipos:l_c),c_r(1:l_r))
     60    IF (indx > 0) THEN
     61      cntpos = cntpos+1
     62      ipos   = ipos+indx+l_r-1
     63    ELSE
     64      EXIT
     65    ENDIF
     66  ENDDO
     67!------------------
     68END FUNCTION cntpos
     69!===
     70INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r)
     71!---------------------------------------------------------------------
     72!- Finds position of c_r in c_c
     73!---------------------------------------------------------------------
     74  IMPLICIT NONE
     75!-
     76  CHARACTER(LEN=*),INTENT(in) :: c_c
     77  INTEGER,INTENT(IN) :: l_c
     78  CHARACTER(LEN=*),INTENT(in) :: c_r
     79  INTEGER,INTENT(IN) :: l_r
     80!---------------------------------------------------------------------
     81  findpos = INDEX(c_c(1:l_c),c_r(1:l_r))
     82  IF (findpos == 0)  findpos=-1
     83!-------------------
     84END FUNCTION findpos
     85!===
     86SUBROUTINE find_str (str_tab,str,pos)
     87!---------------------------------------------------------------------
     88!- This subroutine looks for a string in a table
     89!---------------------------------------------------------------------
     90!- INPUT
     91!-   str_tab  : Table  of strings
     92!-   str      : Target we are looking for
     93!- OUTPUT
     94!-   pos      : -1 if str not found, else value in the table
     95!---------------------------------------------------------------------
     96  IMPLICIT NONE
     97!-
     98  CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab
     99  CHARACTER(LEN=*),INTENT(in) :: str
     100  INTEGER,INTENT(out) :: pos
     101!-
     102  INTEGER :: nb_str,i
     103!---------------------------------------------------------------------
     104  pos = -1
     105  nb_str=SIZE(str_tab)
     106  IF ( nb_str > 0 ) THEN
     107    DO i=1,nb_str
     108      IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN
     109        pos = i
     110        EXIT
     111      ENDIF
     112    ENDDO
     113  ENDIF
     114!----------------------
     115END SUBROUTINE find_str
     116!===
     117SUBROUTINE nocomma (str)
     118!---------------------------------------------------------------------
     119!- Replace commas with blanks
     120!---------------------------------------------------------------------
     121  IMPLICIT NONE
     122!-
     123  CHARACTER(LEN=*) :: str
     124!-
     125  INTEGER :: i
     126!---------------------------------------------------------------------
     127  DO i=1,LEN_TRIM(str)
     128    IF (str(i:i) == ',')   str(i:i) = ' '
     129  ENDDO
    65130!---------------------
    66    END FUNCTION cntpos
    67 !=
    68    INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r)
    69 !---------------------------------------------------------------------
    70 !- Finds position of c_r in c_c
    71 !---------------------------------------------------------------------
    72    IMPLICIT NONE
    73 !-
    74    CHARACTER(LEN=*),INTENT(in) :: c_c
    75    INTEGER,INTENT(IN) :: l_c
    76    CHARACTER(LEN=*),INTENT(in) :: c_r
    77    INTEGER,INTENT(IN) :: l_r
    78 !---------------------------------------------------------------------
    79     findpos = INDEX(c_c(1:l_c),c_r(1:l_r))
    80     IF (findpos == 0)   findpos=-1
    81 !----------------------
    82    END FUNCTION findpos
    83 !=
    84    SUBROUTINE find_str (nb_str,str_tab,str_len_tab,str,pos)
    85 !---------------------------------------------------------------------
    86 !- This subroutine looks for a string in a table
    87 !---------------------------------------------------------------------
    88 !- INPUT
    89 !-   nb_str      : length of table
    90 !-   str_tab     : Table  of strings
    91 !-   str_len_tab : Table  of string-length
    92 !-   str         : Target we are looking for
    93 !- OUTPUT
    94 !-   pos         : -1 if str not found, else value in the table
    95 !---------------------------------------------------------------------
    96    IMPLICIT NONE
    97 !-
    98    INTEGER :: nb_str
    99    CHARACTER(LEN=*),DIMENSION(nb_str) :: str_tab
    100    INTEGER,DIMENSION(nb_str) :: str_len_tab
    101    CHARACTER(LEN=*) :: str
    102    INTEGER :: pos
    103 !-
    104    INTEGER :: i,il
    105 !---------------------------------------------------------------------
    106    pos = -1
    107    il = LEN_TRIM(str)
    108    IF ( nb_str > 0 ) THEN
    109       DO i=1,nb_str
    110          IF (     (INDEX(str_tab(i),str(1:il)) > 0) &
    111               .AND.(str_len_tab(i) == il) ) THEN
    112             pos = i
    113             EXIT
    114          ENDIF
    115       ENDDO
    116    ENDIF
    117 !-------------------------
    118    END SUBROUTINE find_str
    119 !=
    120    SUBROUTINE nocomma (str)
    121 !---------------------------------------------------------------------
    122 !-
    123 !---------------------------------------------------------------------
    124    IMPLICIT NONE
    125 !-
    126    CHARACTER(LEN=*) :: str
    127 !-
    128    INTEGER :: i
    129 !---------------------------------------------------------------------
    130    DO i=1,LEN_TRIM(str)
    131      IF (str(i:i) == ',')   str(i:i) = ' '
    132    ENDDO
    133 !------------------------
    134    END SUBROUTINE nocomma
    135 !=
    136    SUBROUTINE strlowercase (str)
     131END SUBROUTINE nocomma
     132!===
     133SUBROUTINE strlowercase (str)
    137134!---------------------------------------------------------------------
    138135!- Converts a string into lowercase
    139136!---------------------------------------------------------------------
    140    IMPLICIT NONE
    141 !-
    142    CHARACTER(LEN=*) :: str
    143 !-
    144    INTEGER :: i,ic
    145 !---------------------------------------------------------------------
    146    DO i=1,LEN_TRIM(str)
    147      ic = IACHAR(str(i:i))
    148      IF ( (ic >= 65) .AND. (ic <= 90) )   str(i:i) = ACHAR(ic+32)
    149    ENDDO
    150 !-----------------------------
    151    END SUBROUTINE strlowercase
    152 !=
    153    SUBROUTINE struppercase (str)
     137  IMPLICIT NONE
     138!-
     139  CHARACTER(LEN=*) :: str
     140!-
     141  INTEGER :: i,ic
     142!---------------------------------------------------------------------
     143  DO i=1,LEN_TRIM(str)
     144    ic = IACHAR(str(i:i))
     145    IF ( (ic >= 65).AND.(ic <= 90) )  str(i:i) = ACHAR(ic+32)
     146  ENDDO
     147!--------------------------
     148END SUBROUTINE strlowercase
     149!===
     150SUBROUTINE struppercase (str)
    154151!---------------------------------------------------------------------
    155152!- Converts a string into uppercase
    156153!---------------------------------------------------------------------
    157    IMPLICIT NONE
    158 !-
    159    CHARACTER(LEN=*) :: str
    160 !-
    161    INTEGER :: i,ic
    162 !---------------------------------------------------------------------
    163    DO i=1,LEN_TRIM(str)
    164      ic = IACHAR(str(i:i))
    165      IF ( (ic >= 97) .AND. (ic <= 122) )   str(i:i) = ACHAR(ic-32)
    166    ENDDO
    167 !-----------------------------
    168    END SUBROUTINE struppercase
    169 !=
    170 !------------------
    171    SUBROUTINE gensig (str, sig)
     154  IMPLICIT NONE
     155!-
     156  CHARACTER(LEN=*) :: str
     157!-
     158  INTEGER :: i,ic
     159!---------------------------------------------------------------------
     160  DO i=1,LEN_TRIM(str)
     161    ic = IACHAR(str(i:i))
     162    IF ( (ic >= 97).AND.(ic <= 122) )  str(i:i) = ACHAR(ic-32)
     163  ENDDO
     164!--------------------------
     165END SUBROUTINE struppercase
     166!===
     167SUBROUTINE gensig (str,sig)
    172168!---------------------------------------------------------------------
    173169!- Generate a signature from the first 30 characters of the string
    … …  
    175171!- one needs to also verify the string.
    176172!---------------------------------------------------------------------
    177    IMPLICIT NONE
    178 !-
    179    CHARACTER(LEN=*) :: str
    180    INTEGER          :: sig
    181 !-
    182    INTEGER :: i
    183 !---------------------------------------------------------------------
    184    sig = 0
    185    DO i=1,MIN(len_trim(str),30)
    186       sig = sig  + prime(i)*IACHAR(str(i:i))
    187    ENDDO
    188 !-----------------------------
    189  END SUBROUTINE gensig
    190 !=
    191 !------------------
    192    SUBROUTINE find_sig (nb_sig, str_tab, str, sig_tab, sig, pos)
     173  IMPLICIT NONE
     174!-
     175  CHARACTER(LEN=*) :: str
     176  INTEGER          :: sig
     177!-
     178  INTEGER :: i
     179!---------------------------------------------------------------------
     180  sig = 0
     181  DO i=1,MIN(LEN_TRIM(str),30)
     182    sig = sig + prime(i)*IACHAR(str(i:i))
     183  ENDDO
     184!--------------------
     185END SUBROUTINE gensig
     186!===
     187SUBROUTINE find_sig (nb_sig,str_tab,str,sig_tab,sig,pos)
    193188!---------------------------------------------------------------------
    194189!- Find the string signature in a list of signatures
    … …  
    197192!-   nb_sig      : length of table of signatures
    198193!-   str_tab     : Table of strings
    199 !-   str         : Target string we are looking for 
     194!-   str         : Target string we are looking for
    200195!-   sig_tab     : Table of signatures
    201196!-   sig         : Target signature we are looking for
    … …  
    203198!-   pos         : -1 if str not found, else value in the table
    204199!---------------------------------------------------------------------
    205    IMPLICIT NONE
    206 !-
    207    INTEGER :: nb_sig
    208    CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab
    209    CHARACTER(LEN=*) :: str
    210    INTEGER, DIMENSION(nb_sig) :: sig_tab
    211    INTEGER :: sig
    212 !-
    213    INTEGER :: pos
    214    INTEGER, DIMENSION(nb_sig) :: loczeros
    215 !-
    216    INTEGER :: il, len
    217    INTEGER, DIMENSION(1) :: minpos
    218 !---------------------------------------------------------------------
    219 !-
    220    pos = -1
    221    il = LEN_TRIM(str)
    222 !-
    223    IF ( nb_sig > 0 ) THEN
    224       !
    225       loczeros = ABS(sig_tab(1:nb_sig)-sig)
    226       !
    227       IF ( COUNT(loczeros < 1) == 1 ) THEN
    228          !
    229          minpos = MINLOC(loczeros)
    230          len = LEN_TRIM(str_tab(minpos(1)))
    231          IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
    232                  .AND.(len == il) ) THEN
    233             pos = minpos(1)
    234          ENDIF
    235          !
    236       ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN
    237          !
    238          DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 )
    239             minpos = MINLOC(loczeros)
    240             len = LEN_TRIM(str_tab(minpos(1)))
    241             IF ( (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
    242                  .AND.(len == il) ) THEN
    243                pos = minpos(1)
    244             ELSE
    245                loczeros(minpos(1)) = 99999
    246             ENDIF
    247          ENDDO
    248          !
     200  IMPLICIT NONE
     201!-
     202  INTEGER :: nb_sig
     203  CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab
     204  CHARACTER(LEN=*) :: str
     205  INTEGER,DIMENSION(nb_sig) :: sig_tab
     206  INTEGER :: sig
     207!-
     208  INTEGER :: pos
     209  INTEGER,DIMENSION(nb_sig) :: loczeros
     210!-
     211  INTEGER :: il,len
     212  INTEGER,DIMENSION(1) :: minpos
     213!---------------------------------------------------------------------
     214  pos = -1
     215  il = LEN_TRIM(str)
     216!-
     217  IF ( nb_sig > 0 ) THEN
     218    loczeros = ABS(sig_tab(1:nb_sig)-sig)
     219    IF ( COUNT(loczeros < 1) == 1 ) THEN
     220      minpos = MINLOC(loczeros)
     221      len = LEN_TRIM(str_tab(minpos(1)))
     222      IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
     223          .AND.(len == il) ) THEN
     224        pos = minpos(1)
    249225      ENDIF
    250       !
    251    ENDIF
    252 !-
     226    ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN
     227      DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 )
     228        minpos = MINLOC(loczeros)
     229        len = LEN_TRIM(str_tab(minpos(1)))
     230        IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
     231            .AND.(len == il) ) THEN
     232          pos = minpos(1)
     233        ELSE
     234          loczeros(minpos(1)) = 99999
     235        ENDIF
     236      ENDDO
     237    ENDIF
     238  ENDIF
     239!-----------------------
    253240 END SUBROUTINE find_sig
    254 !=
     241!===
    255242!------------------
    256243END MODULE ioipsl_stringop

  • LMDZ4/branches/LMDZ4-dev/libf/bibio/write_field.F90

    r772 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44module write_field
    … …  
    7272       
    7373    subroutine WriteField_gen(name,Field,dimx,dimy,dimz)
    74     USE ioipsl
    7574    implicit none
    7675    include 'netcdf.inc'
    … …  
    109108       
    110109    subroutine CreateNewField(name,dimx,dimy,dimz)
    111     USE ioipsl
    112110    implicit none
    113111    include 'netcdf.inc' 
    … …  
    229227        write (id,spacing)
    230228      else
    231         write (id,'')
     229        write (id,'("")')
    232230        write (id,spacing)
    233231      endif

  • LMDZ4/branches/LMDZ4-dev/libf/bibio/writedynav.F

    r1114 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      subroutine writedynav( histid, time, vcov,
    55     ,                          ucov,teta,ppk,phi,q,masse,ps,phis)
    66
     7#ifdef CPP_IOIPSL
    78      USE ioipsl
     9#endif
    810      USE infotrac, ONLY : nqtot, ttext
    911      implicit none
    … …  
    4547#include "description.h"
    4648#include "serre.h"
     49#include "iniprint.h"
    4750
    4851C
    … …  
    5962
    6063
     64#ifdef CPP_IOIPSL
     65! This routine needs IOIPSL to work
    6166C   Variables locales
    6267C
    … …  
    138143C
    139144      if (ok_sync) call histsync(histid)
     145
     146#else
     147! tell the user this routine should be run with ioipsl
     148      write(lunout,*)"writedynav: Warning this routine should not be",
     149     &               " used without ioipsl"
     150#endif
     151! of #ifdef CPP_IOIPSL
    140152      return
    141153      end

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3d/bilan_dyn.F

    r693 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE bilan_dyn (ntrac,dt_app,dt_cum,
    … …  
    1010c             vQ..A=Cp T + L * ...
    1111
     12#ifdef CPP_IOIPSL
    1213      USE IOIPSL
     14#endif
    1315
    1416      IMPLICIT NONE

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3d/diagedyn.F

    r1140 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44
    … …  
    315315C
    316316#else
    317       write(lunout,*),'diagedyn: Needs Earth physics to function'
     317      write(lunout,*)'diagedyn: Needs Earth physics to function'
    318318#endif
    319319! #endif of #ifdef CPP_EARTH

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3d/dynredem.F

    r1114 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    55      SUBROUTINE dynredem0(fichnom,iday_end,phis)
     6#ifdef CPP_IOIPSL
    67      USE IOIPSL
     8#endif
    79      USE infotrac
    810      IMPLICIT NONE
    … …  
    5557
    5658c-----------------------------------------------------------------------
    57       modname='dynredem'
    58 
     59      modname='dynredem0'
     60
     61#ifdef CPP_IOIPSL
    5962      call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
    6063      call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
    61        
     64#else
     65! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used)
     66      yyears0=0
     67      mmois0=1
     68      jjour0=1
     69#endif       
    6270
    6371      DO l=1,length

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3d/getparam.F90

    r524 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44MODULE getparam
     5#ifdef CPP_IOIPSL
    56   USE IOIPSL
     7#else
     8! if not using IOIPSL, we still need to use (a local version of) getin
     9   USE ioipsl_getincom
     10#endif
     11
    612   INTERFACE getpar
    713     MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3d/guide_mod.F90

    r1170 r1186  
    11!
    2 ! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/guide.F,v 1.3.4.1 2006/11/06 15:51:16 fairhead Exp $
     2! $Id$
    33!
    44MODULE guide_mod
    … …  
    99!=======================================================================
    1010
    11   USE ioipsl
    1211  USE getparam
    1312  USE Write_Field

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/bilan_dyn_p.F

    r985 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      SUBROUTINE bilan_dyn_p (ntrac,dt_app,dt_cum,
    … …  
    1010c             vQ..A=Cp T + L * ...
    1111
     12#ifdef CPP_IOIPSL
    1213      USE IOIPSL
     14#endif
    1315      USE parallel
    1416      USE mod_hallo

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/diagedyn.F

    r1140 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44
    … …  
    315315C
    316316#else
    317       write(lunout,*),'diagedyn: Needs Earth physics to function'
     317      write(lunout,*)'diagedyn: Needs Earth physics to function'
    318318#endif
    319319! #endif of #ifdef CPP_EARTH

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/dynredem.F

    r1114 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    55      SUBROUTINE dynredem0(fichnom,iday_end,phis)
     6#ifdef CPP_IOIPSL
    67      USE IOIPSL
     8#endif
    79      USE infotrac
    810      IMPLICIT NONE
    … …  
    5557
    5658c-----------------------------------------------------------------------
    57       modname='dynredem'
    58 
     59      modname='dynredem0'
     60
     61#ifdef CPP_IOIPSL
    5962      call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
    6063      call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
    61        
     64#else
     65! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used)
     66      yyears0=0
     67      mmois0=1
     68      jjour0=1
     69#endif       
    6270
    6371      DO l=1,length
    … …  
    457465      dims4(3) = idim_s
    458466      dims4(4) = idim_tim
    459 
     467      IF(nqtot.GE.1) THEN
    460468      DO iq=1,nqtot
    461469cIM 220306 BEG
    … …  
    468476      ierr = NF_PUT_ATT_TEXT (nid, nvarid, "title", 12,ttext(iq))
    469477      ENDDO
     478      ENDIF
    470479c
    471480      dims4(1) = idim_rlonv
    … …  
    631640      END IF
    632641
     642      IF(nqtot.GE.1) THEN
    633643      do iq=1,nqtot
    634644
    … …  
    701711     
    702712      ENDDO
     713      ENDIF
    703714c
    704715      ierr = NF_INQ_VARID(nid, "masse", nvarid)

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/dynredem_p.F

    r1114 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44c
    55      SUBROUTINE dynredem0_p(fichnom,iday_end,phis)
     6#ifdef CPP_IOIPSL
    67      USE IOIPSL
     8#endif
    79      USE parallel
    810      USE infotrac
    … …  
    5759      if (mpi_rank==0) then
    5860     
    59       modname='dynredem'
    60 
     61      modname='dynredem0_p'
     62
     63#ifdef CPP_IOIPSL
    6164      call ymds2ju(annee_ref, 1, iday_end, 0.0, zjulian)
    6265      call ju2ymds(zjulian, yyears0, mmois0, jjour0, hours)
    63        
     66#else
     67! set yyears0, mmois0, jjour0 to 0,1,1 (hours is not used)
     68      yyears0=0
     69      mmois0=1
     70      jjour0=1
     71#endif               
    6472
    6573      DO l=1,length

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/getparam.F90

    r774 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44MODULE getparam
     5#ifdef CPP_IOIPSL
    56   USE IOIPSL
     7#else
     8! if not using IOIPSL, we still need to use (a local version of) getin
     9   USE ioipsl_getincom
     10#endif
     11
    612   INTERFACE getpar
    713     MODULE PROCEDURE ini_getparam,fin_getparam,getparamr,getparami,getparaml

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/initdynav_p.F

    r1114 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    4 c
    5 c
    64      subroutine initdynav_p(infile,day0,anne0,tstep,t_ops,t_wrt,fileid)
    75
     6#ifdef CPP_IOIPSL
     7! This routine needs IOIPSL
    88       USE IOIPSL
     9#endif
    910       use parallel
    1011       use Write_field
    … …  
    5051#include "description.h"
    5152#include "serre.h"
     53#include "iniprint.h"
    5254
    5355C   Arguments
    … …  
    5759      real tstep, t_ops, t_wrt
    5860      integer fileid
     61
     62#ifdef CPP_IOIPSL
     63! This routine needs IOIPSL
     64C   Variables locales
     65C
    5966      integer thoriid, zvertiid
    60 
    61 C   Variables locales
    62 C
    6367      integer tau0
    6468      real zjulian
    … …  
    193197C
    194198      call histend(fileid)
     199#else
     200      write(lunout,*)'initdynav_p: Needs IOIPSL to function'
     201#endif
     202! #endif of #ifdef CPP_IOIPSL
    195203      return
    196204      end

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/initfluxsto_p.F

    r1114 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      subroutine initfluxsto_p
    … …  
    66     .                    fileid,filevid,filedid)
    77
     8#ifdef CPP_IOIPSL
     9! This routine needs IOIPSL
    810       USE IOIPSL
     11#endif
    912       use parallel
    1013       use Write_field
    … …  
    5053#include "description.h"
    5154#include "serre.h"
     55#include "iniprint.h"
    5256
    5357C   Arguments
    5458C
    5559      character*(*) infile
    56       integer*4 itau
    5760      real tstep, t_ops, t_wrt
    5861      integer fileid, filevid,filedid
    59       integer ndex(1)
     62
     63#ifdef CPP_IOIPSL
     64! This routine needs IOIPSL
     65C   Variables locales
     66C
    6067      real nivd(1)
    61 
    62 C   Variables locales
    63 C
    6468      integer tau0
    6569      real zjulian
    … …  
    285289      endif
    286290       
     291#else
     292      write(lunout,*)'initfluxsto_p: Needs IOIPSL to function'
     293#endif
     294! #endif of #ifdef CPP_IOIPSL
    287295      return
    288296      end

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/inithist_p.F

    r1114 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      subroutine inithist_p(infile,day0,anne0,tstep,t_ops,t_wrt,
    55     .                      fileid,filevid)
    66
     7#ifdef CPP_IOIPSL
     8! This routine needs IOIPSL
    79       USE IOIPSL
     10#endif
    811       use parallel
    912       use Write_field
    … …  
    5053#include "description.h"
    5154#include "serre.h"
     55#include "iniprint.h"
    5256
    5357C   Arguments
    … …  
    5862      integer fileid, filevid
    5963
     64#ifdef CPP_IOIPSL
     65! This routine needs IOIPSL
    6066C   Variables locales
    6167C
    … …  
    244250      call histend(fileid)
    245251      call histend(filevid)
     252#else
     253      write(lunout,*)'inithist_p: Needs IOIPSL to function'
     254#endif
     255! #endif of #ifdef CPP_IOIPSL
    246256      return
    247257      end

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/mod_const_para.F90

    r1014 r1186  
     1!
     2! $Id$
     3!
    14MODULE mod_const_mpi
    25
    … …  
    811
    912  SUBROUTINE Init_const_mpi
     13#ifdef CPP_IOIPSL
    1014    USE IOIPSL
     15#else
     16! if not using IOIPSL, we still need to use (a local version of) getin
     17    USE ioipsl_getincom
     18#endif
    1119
    1220    IMPLICIT NONE

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/writedynav_p.F

    r1118 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      subroutine writedynav_p( histid, time, vcov,
    55     ,                          ucov,teta,ppk,phi,q,masse,ps,phis)
    66
     7#ifdef CPP_IOIPSL
     8! This routine needs IOIPSL
    79      USE ioipsl
     10#endif
    811      USE parallel
    912      USE misc_mod
    … …  
    4750#include "description.h"
    4851#include "serre.h"
     52#include "iniprint.h"
    4953
    5054C
    … …  
    6165
    6266
     67#ifdef CPP_IOIPSL
     68! This routine needs IOIPSL
    6369C   Variables locales
    6470C
    … …  
    156162C
    157163      if (ok_sync) call histsync(histid)
     164#else
     165      write(lunout,*)'writedynav_p: Needs IOIPSL to function'
     166#endif
     167! #endif of #ifdef CPP_IOIPSL
    158168      return
    159169      end

  • LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/writehist_p.F

    r1114 r1186  
    11!
    2 ! $Header$
     2! $Id$
    33!
    44      subroutine writehist_p( histid, histvid, time, vcov,
    55     ,                          ucov,teta,phi,q,masse,ps,phis)
    66
     7#ifdef CPP_IOIPSL
     8! This routine needs IOIPSL
    79      USE ioipsl
     10#endif
    811      USE parallel
    912      USE misc_mod
    … …  
    4851#include "description.h"
    4952#include "serre.h"
     53#include "iniprint.h"
    5054
    5155C
    … …  
    6165      integer time
    6266
    63 
     67#ifdef CPP_IOIPSL
     68! This routine needs IOIPSL
    6469C   Variables locales
    6570C
    … …  
    144149        call histsync(histvid)
    145150      endif
     151#else
     152      write(lunout,*)'writehist_p: Needs IOIPSL to function'
     153#endif
     154! #endif of #ifdef CPP_IOIPSL
    146155      return
    147156      end
Note: See TracChangeset for help on using the changeset viewer.