phase with CY49R1

src/fiat/drhook/dr_hook_init.F90

@@ -61,7 +61,7 @@ SUBROUTINE DR_HOOK_ASSERT_MPI_INITIALIZED_()
   INTEGER :: ILEN
   INTEGER(KIND=C_INT) :: IERR
   LOGICAL :: LMPI_INITIALIZED
-  INTEGER, PARAMETER :: NVARS = 5
+  INTEGER, PARAMETER :: NVARS = 4
   CHARACTER(LEN=32), DIMENSION(NVARS) :: CMPIRUN_DETECT
   CHARACTER(LEN=4) :: CLENV_DR_HOOK_ASSERT_MPI_INITIALIZED
   INTEGER :: IVAR

src/fiat/drhook/drhook.c

@@ -560,7 +560,7 @@ static volatile sig_atomic_t signal_handler_called = 0;
 static volatile sig_atomic_t signal_handler_ignore_atexit = 0;
 static volatile sig_atomic_t unlimited_corefile_retcode = 9999;
 static volatile unsigned long long int saved_corefile_hardlimit = 0;
-static int allow_coredump = -1; /* -1 denotes ALL MPI-tasks, 1..NPES == myproc, 0 = coredump will not be enabled by DrHook at init */
+static int allow_coredump = 0; /* -1 denotes ALL MPI-tasks, 1..NPES == myproc, 0 = coredump will not be enabled by DrHook at init */
 static drhook_sig_t siglist[1+NSIG] = { 0 };
 static char *a_out = NULL;
 static char *mon_out = NULL;

src/fiat/gstats/gstats_print.F90

@@ -441,7 +441,8 @@ SUBROUTINE GSTATS_PRINT(KULOUT,PAVEAVE,KLEN)
        &'  RECVS  AVG(kb) TOTAL(MB) MB/s '
 
       DO JNUM=501,1000
-        IF(NUMSEND(JNUM) /= 0 .OR. NUMRECV(JNUM) /= 0 ) THEN
+        IF((NUMSEND(JNUM) /= 0 .OR. NUMRECV(JNUM) /= 0 ) &
+           .AND. TIMESUM(JNUM) > 0.0_JPRD) THEN
            SENDRATE=SENDBYTES(JNUM)*1.E-6_JPRD/TIMESUM(JNUM)
            RECVRATE=RECVBYTES(JNUM)*1.E-6_JPRD/TIMESUM(JNUM)
            IF(NUMSEND(JNUM) /= 0) THEN
@@ -585,7 +586,8 @@ SUBROUTINE GSTATS_PRINT(KULOUT,PAVEAVE,KLEN)
      &'   NUM   ROUTINE                              '//&
      &'  SUM(s)  SEND(GB)  RECV(GB)    GB/s'
     DO JNUM=501,1000
-       IF(TOTSENDBYTES(JNUM).GT.0.0_JPRD.OR.TOTRECVBYTES(JNUM).GT.0.0_JPRD) THEN
+       IF((TOTSENDBYTES(JNUM).GT.0.0_JPRD.OR.TOTRECVBYTES(JNUM).GT.0.0_JPRD) &
+          .AND. MAXCOMMTIME(JNUM) > 0.0_JPRD) THEN
           WRITE(KULOUT,'(I6,1X,A40,f6.1,2F10.1,F8.1)') &
            &  JNUM,CCDESC(JNUM),MAXCOMMTIME(JNUM),&
            &  TOTSENDBYTES(JNUM)*1.E-9_JPRD, &

src/fiat/mpl/internal/mpl_gatherv_mod.F90

@@ -92,7 +92,7 @@ MODULE MPL_GATHERV_MOD
 
 INTERFACE MPL_GATHERV
 MODULE PROCEDURE MPL_GATHERV_REAL8,MPL_GATHERV_REAL4,MPL_GATHERV_INT,&
-               & MPL_GATHERV_INT_SCALAR
+               & MPL_GATHERV_INT_SCALAR,MPL_GATHERV_CHAR_SCALAR
 END INTERFACE
 
 PUBLIC MPL_GATHERV
@@ -363,6 +363,84 @@ SUBROUTINE MPL_GATHERV_REAL8(PSENDBUF,KROOT,PRECVBUF,KRECVCOUNTS,KSENDCOUNT,KREC
 
 END SUBROUTINE MPL_GATHERV_REAL8
 
+SUBROUTINE MPL_GATHERV_CHAR_SCALAR(CSENDBUF,KROOT,CRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, &
+                            & KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING)
+
+
+#ifdef USE_8_BYTE_WORDS
+  USE MPI4TO8, ONLY : &
+    MPI_GATHERV => MPI_GATHERV8
+#endif
+
+
+!CHARACTER*(*)                       :: CDBUF
+CHARACTER*(*)                       :: CSENDBUF
+INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVCOUNTS(:),KSENDCOUNT
+INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KROOT
+CHARACTER*(*),OPTIONAL              :: CRECVBUF(:)
+INTEGER(KIND=JPIM),INTENT(IN),OPTIONAL :: KRECVDISPL(:),KCOMM,KMP_TYPE
+INTEGER(KIND=JPIM),INTENT(OUT),OPTIONAL :: KERROR,KREQUEST
+CHARACTER*(*),INTENT(IN),OPTIONAL :: CDSTRING
+
+INTEGER(KIND=JPIM) :: IRECVDISPL(MPL_NUMPROC)
+INTEGER(KIND=JPIM) :: IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE
+INTEGER(KIND=JPIM) :: IRECVBUFSIZE,ISENDCOUNT
+INTEGER(KIND=JPIM) :: IDUM,IST,IEND,JK !,ICOUNT
+
+IF(PRESENT(KSENDCOUNT)) THEN
+  ISENDCOUNT=KSENDCOUNT
+ELSE
+  ISENDCOUNT = LEN(CSENDBUF)
+ENDIF
+
+CALL MPL_GATHERV_PREAMB1(IERROR,IPL_NUMPROC,IPL_MYRANK,ICOMM,IROOT,IMP_TYPE,KCOMM,KROOT,KMP_TYPE,KREQUEST)
+
+IF(IPL_MYRANK == IROOT) THEN
+  IF( .NOT. PRESENT(CRECVBUF)) CALL MPL_MESSAGE(&
+   & CDMESSAGE='MPL_GATHERV:RECVBUF MISSING',CDSTRING=CDSTRING,LDABORT=LLABORT)
+  IRECVBUFSIZE = LEN(CRECVBUF)*SIZE(CRECVBUF)
+#ifndef NAG
+  IF( (LOC(CRECVBUF(UBOUND(CRECVBUF,1))) - LOC(CRECVBUF(LBOUND(CRECVBUF,1)))) /= (IRECVBUFSIZE-LEN(CRECVBUF) ) .AND. &
+    & IRECVBUFSIZE > 0 ) THEN
+    CALL MPL_MESSAGE(CDMESSAGE='MPL_GATHERV: RECVBUF NOT CONTIGUOUS ',LDABORT=LLABORT)
+  ENDIF
+#endif
+  CALL MPL_GATHERV_PREAMB2(IPL_NUMPROC,IPL_MYRANK,IRECVBUFSIZE,ISENDCOUNT,&
+       & KRECVCOUNTS,IRECVDISPL,KRECVDISPL,CDSTRING)
+
+  IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN
+    CALL MPI_GATHERV(CSENDBUF,ISENDCOUNT,INT(MPI_CHARACTER),CRECVBUF(1),KRECVCOUNTS,&
+     &  IRECVDISPL,INT(MPI_CHARACTER),IROOT-1,ICOMM,IERROR)
+  ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN
+    CALL MPI_IGATHERV(CSENDBUF,ISENDCOUNT,INT(MPI_CHARACTER),CRECVBUF(1),KRECVCOUNTS,&
+     &  IRECVDISPL,INT(MPI_CHARACTER),IROOT-1,ICOMM,KREQUEST,IERROR)
+  ENDIF
+  IF(LMPLSTATS) THEN
+    CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_CHARACTER))
+    CALL MPL_RECVSTATS(SUM(KRECVCOUNTS),INT(MPI_CHARACTER))
+  ENDIF
+ELSE
+  IF(IMP_TYPE == JP_BLOCKING_STANDARD .OR. IMP_TYPE == JP_BLOCKING_BUFFERED) THEN
+    CALL MPI_GATHERV(CSENDBUF,ISENDCOUNT,INT(MPI_CHARACTER),ZDUM_JPRD,1, &
+     &  1,INT(MPI_CHARACTER),IROOT-1,ICOMM,IERROR)
+  ELSEIF(IMP_TYPE == JP_NON_BLOCKING_STANDARD .OR. IMP_TYPE == JP_NON_BLOCKING_BUFFERED) THEN
+    CALL MPI_IGATHERV(CSENDBUF,ISENDCOUNT,INT(MPI_CHARACTER),ZDUM_JPRD,1, &
+     &  1,INT(MPI_CHARACTER),IROOT-1,ICOMM,KREQUEST,IERROR)
+  ENDIF
+  IF(LMPLSTATS) THEN
+    CALL MPL_SENDSTATS(ISENDCOUNT,INT(MPI_CHARACTER))
+  ENDIF
+ENDIF
+
+IF(PRESENT(KERROR)) THEN
+  KERROR=IERROR
+ELSE
+  IF(IERROR /= 0 ) CALL MPL_MESSAGE(IERROR,'MPL_GATHERV',CDSTRING,&
+   & LDABORT=LLABORT)
+ENDIF
+
+END SUBROUTINE MPL_GATHERV_CHAR_SCALAR
+
 SUBROUTINE MPL_GATHERV_INT(KSENDBUF,KROOT,KRECVBUF,KRECVCOUNTS,KSENDCOUNT,KRECVDISPL, &
                             &  KMP_TYPE,KCOMM,KERROR,KREQUEST,CDSTRING)
 

src/fiat/system/internal/linux_bind.c

@@ -1,4 +1,5 @@
 /*
+ * (C) Copyright 2005- ECMWF.
  * (C) Copyright 2005- Meteo France.
  * 
  * This software is licensed under the terms of the Apache Licence Version 2.0
@@ -29,12 +30,12 @@ static char * getcpumask (char *buffer, size_t size)
   cpu_set_t mask;
   unsigned int ncpu;
   unsigned int icpu;
-  
+
   ncpu = sysconf (_SC_NPROCESSORS_CONF);
-  
+
   sched_getaffinity (0, sizeof (mask), &mask);
 
-  for (icpu = 0; icpu < ncpu; icpu++) 
+  for (icpu = 0; icpu < ncpu; icpu++)
     buffer[icpu] = CPU_ISSET (icpu, &mask) ? '1' : '0';
 
   buffer[ncpu] = '\0';
@@ -78,11 +79,11 @@ void linux_bind_dump_ (int * prank, int * psize)
   }
 
 #ifdef _OPENMP
-#pragma omp parallel 
+#pragma omp parallel
 #endif
   {
     char buffer[1024];
-    int iomp = 
+    int iomp =
 #ifdef _OPENMP
       omp_get_thread_num ()
 #else
@@ -97,7 +98,7 @@ void linux_bind_dump_ (int * prank, int * psize)
 #ifdef _OPENMP
 #pragma omp critical
 #endif
-            fprintf (fp, "\n                                                    mask = %s iomp = %2d", 
+            fprintf (fp, "\n                                                    mask = %s iomp = %2d",
                      getcpumask (buffer, sizeof (buffer)), iomp);
           }
 #ifdef _OPENMP
@@ -151,12 +152,12 @@ void linux_bind_ (int * prank, int * psize)
     }
 
 #ifdef _OPENMP
-#pragma omp parallel 
+#pragma omp parallel
 #endif
   {
     char * c;
     cpu_set_t mask;
-    int iomp = 
+    int iomp =
 #ifdef _OPENMP
       omp_get_thread_num ()
 #else
@@ -183,7 +184,7 @@ void linux_bind_ (int * prank, int * psize)
     for (icpu = 0; isdigit (*c); icpu++, c++)
       if (*c != '0')
         CPU_SET (icpu, &mask);
-     
+
     sched_setaffinity (0, sizeof (mask), &mask);
 
 end_parallel:

src/fiat/system/internal/linuxtrbk.c

@@ -1,6 +1,6 @@
 /*
  * (C) Copyright 2005- ECMWF.
- * 
+ *
  * This software is licensed under the terms of the Apache Licence Version 2.0
  * which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
  * In applying this licence, ECMWF does not waive the privileges and immunities
@@ -11,7 +11,7 @@
 
 /* linuxtrbk.c : Print traceback on linux */
 
-/* 
+/*
    Author: Sami Saarinen, ECMWF, 28-Apr-2006
    The code "nicked" from ifsaux/support/drhook.c
 
@@ -117,7 +117,7 @@ LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr)
   int sigcontextptr_given = sigcontextptr ? 1 : 0;
   static int recur = 0;
   const char *a_out = ec_argv()[0];
-  fprintf(stderr,"%s %s [LinuxTraceBack] Backtrace(s) for program '%s' : sigcontextptr=%p\n", 
+  fprintf(stderr,"%s %s [LinuxTraceBack] Backtrace(s) for program '%s' : sigcontextptr=%p\n",
       pfx,ts,a_out ? a_out : "/dev/null", sigcontextptr);
 
   if (++recur > 1) {
@@ -156,9 +156,9 @@ LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr)
   const char *ts    = timestr ? timestr : drhook_TIMESTR(0);
   const char *a_out = ec_argv()[0];
   const char *s1    = strlen(pfx) ? " " : "";
-  const char *s2    = strlen(ts)  ? " " : ""; 
- 
-  fprintf(stderr,"%s%s%s%s[LinuxTraceBack] Backtrace(s) for program '%s' : sigcontextptr=%p\n", 
+  const char *s2    = strlen(ts)  ? " " : "";
+
+  fprintf(stderr,"%s%s%s%s[LinuxTraceBack] Backtrace(s) for program '%s' : sigcontextptr=%p\n",
     pfx,s1,ts,s2,a_out ? a_out : "/dev/null", sigcontextptr);
 
   if (++recur > 1) {
@@ -174,7 +174,7 @@ LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr)
 
 #if (defined(__GNUC__) || defined(__PGI))
   if (sigcontextptr) {
-    /* To have a desired effect, 
+    /* To have a desired effect,
        compile with -g (and maybe -O1 or greater to get some optimization)
        and link with -g -Wl,-export-dynamic */
     char *linuxtrbk_fullpath = getenv("LINUXTRBK_FULLPATH");
@@ -188,7 +188,7 @@ LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr)
     if (trace_size > 1) {
       /* overwrite sigaction with caller's address */
 #ifdef __powerpc64__
-      trace[1] = uc ? (void *) uc->uc_mcontext.regs->nip : NULL;   // Trick from PAPI_overflow() 
+      trace[1] = uc ? (void *) uc->uc_mcontext.regs->nip : NULL;   // Trick from PAPI_overflow()
 #elif defined(__x86_64__) && defined(REG_RIP) // gcc specific
       trace[1] = uc ? (void *) uc->uc_mcontext.gregs[REG_RIP] : NULL; // RIP: x86_64 specific ; only available in 64-bit mode */
 #elif defined(__i386__) && defined(REG_EIP) // gcc specific
@@ -252,7 +252,7 @@ LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr)
                 *plus = '\0';
                 cxx = cxxdemangle(leftB + 1,&istat);
                 if (cxx) *leftB = '\0';
-                fprintf(stderr, "%s%s%s%s[LinuxTraceBack] [%*.*d]: %s%s%s+%s : %s%s at %s\n", 
+                fprintf(stderr, "%s%s%s%s[LinuxTraceBack] [%*.*d]: %s%s%s+%s : %s%s at %s\n",
                   pfx,s1,ts,s2, ndigits, ndigits, i,
                   last_slash,
                   cxx ? "(" : "",
@@ -264,7 +264,7 @@ LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr)
                 if (cxx) free(cxx);
               }
               else {
-                fprintf(stderr, "%s%s%s%s[LinuxTraceBack] [%*.*d]: %s : %s%s at %s\n", 
+                fprintf(stderr, "%s%s%s%s[LinuxTraceBack] [%*.*d]: %s : %s%s at %s\n",
                   pfx,s1,ts,s2, ndigits, ndigits, i,
                   last_slash,
                   cxxfunc ? cxxfunc : func,
@@ -277,8 +277,8 @@ LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr)
           }
           if (!ok) {
               char *cxx = cxxdemangle(strings[i],NULL);
-            fprintf(stderr, "%s%s%s%s[LinuxTraceBack] [%*.*d]: %s\n", 
-              pfx,s1,ts,s2, ndigits, ndigits, i, 
+            fprintf(stderr, "%s%s%s%s[LinuxTraceBack] [%*.*d]: %s\n",
+              pfx,s1,ts,s2, ndigits, ndigits, i,
               cxx ? cxx : strings[i]);
             if (cxx) free(cxx);
           }
@@ -324,7 +324,7 @@ LinuxTraceBack(const char *prefix, const char *timestr, void *sigcontextptr)
   recur--;
 }
 #endif
- 
+
 void linux_trbk_(void)
 {
   LinuxTraceBack(NULL,NULL,NULL);
@@ -354,10 +354,10 @@ void linux_trbk(void)
 void gdb_trbk_()
 {
   char *gdb = getenv("GNUDEBUGGER");
-  if (gdb && 
+  if (gdb &&
       (access(TOSTR(GNUDEBUGGER),X_OK) == 0) && /* GNUDEBUGGER was set */
-      (strequ(gdb,"1")    || 
-       strequ(gdb,"true") || 
+      (strequ(gdb,"1")    ||
+       strequ(gdb,"true") ||
        strequ(gdb,"TRUE"))) {
     char gdbcmd[65536];
     pid_t pid = getpid();
@@ -368,7 +368,7 @@ void gdb_trbk_()
     snprintf(gdbcmd,sizeof(gdbcmd),
        "set +eux; %s -batch -n -q -ex 'thread apply all bt' %s %ld < /dev/null",
        TOSTR(GNUDEBUGGER), a_out, (long int)pid);
-    
+
     /* fprintf(stderr,"%s\n",gdbcmd); */
     { int idummy = system(gdbcmd); }
   }
@@ -386,10 +386,10 @@ void gdb_trbk() { gdb_trbk_(); }
 void dbx_trbk_()
 {
   char *dbx = getenv("DBXDEBUGGER");
-  if (dbx && 
+  if (dbx &&
       (access(TOSTR(DBXDEBUGGER),X_OK) == 0) && /* DBXDEBUGGER was set */
-      (strequ(dbx,"1")    || 
-       strequ(dbx,"true") || 
+      (strequ(dbx,"1")    ||
+       strequ(dbx,"true") ||
        strequ(dbx,"TRUE"))) {
     pid_t pid = getpid();
     const char *a_out = ec_argv()[0];
@@ -410,7 +410,7 @@ void dbx_trbk_()
            " | %s%s - %d ",
            TOSTR(DBXDEBUGGER), qopt, pid);
     }
-    
+
     /* fprintf(stderr,"%s\n",dbxcmd); */
     { int idummy = system(dbxcmd); }
   }
@@ -429,26 +429,26 @@ static void InitBFD()
 #ifdef BFDLIB
   if (!abfd) {
     const char *a_out = ec_argv()[0];
- 
+
     bfd_init();
- 
+
     abfd = bfd_openr(a_out, 0);
     if (!abfd) {
       perror("bfd_openr failed: ");
       return;
     }
- 
+
     bfd_check_format(abfd,bfd_object);
- 
+
     unsigned int storage_needed = bfd_get_symtab_upper_bound(abfd);
     syms = (asymbol **) malloc(storage_needed);
     unsigned int cSymbols = bfd_canonicalize_symtab(abfd, syms);
- 
+
     text = bfd_get_section_by_name(abfd, ".text");
   }
 #endif
 }
- 
+
 static int ResolveViaBFD(void *address, BFD_t *b, const char *str)
 {
   int rc = -1;

src/fiat/util/qsortc.F90

@@ -1,5 +1,6 @@
+! (C) Copyright 2005- ECMWF.
 ! (C) Copyright 2005- Meteo France.
-! 
+!
 ! This software is licensed under the terms of the Apache Licence Version 2.0
 ! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
 ! In applying this licence, ECMWF does not waive the privileges and immunities
@@ -11,7 +12,7 @@
 SUBROUTINE QSORTC (N,ORD,A)
 USE EC_PARKIND, ONLY : JPIM
 IMPLICIT NONE
-      
+
 INTEGER(KIND=JPIM), INTENT(IN)    :: N
 INTEGER(KIND=JPIM), INTENT(INOUT) :: ORD(N)
 CHARACTER(LEN=*),   INTENT(IN)    :: A(N)