Changeset 1779

Timestamp:

Mar 3, 2016 8:01:28 AM (9 years ago)

Author:

raasch

Message:

pmc array management changed from linked list to sequential loop; further small changes and cosmetics for the pmc

Location:

palm/trunk

Files:

• SCRIPTS/mrun (modified) (8 diffs)
• SCRIPTS/subjob (modified) (1 diff)
• SOURCE/Makefile (modified) (2 diffs)
• SOURCE/check_open.f90 (modified) (25 diffs)
• SOURCE/init_grid.f90 (modified) (4 diffs)
• SOURCE/init_pegrid.f90 (modified) (3 diffs)
• SOURCE/interaction_droplets_ptq.f90 (modified) (6 diffs)
• SOURCE/modules.f90 (modified) (2 diffs)
• SOURCE/palm.f90 (modified) (2 diffs)
• SOURCE/pmc_client.f90 (modified) (30 diffs)
• SOURCE/pmc_general.f90 (modified) (8 diffs)
• SOURCE/pmc_handle_communicator.f90 (modified) (14 diffs)
• SOURCE/pmc_interface.f90 (modified) (22 diffs)
• SOURCE/pmc_mpi_wrapper.f90 (modified) (14 diffs)
• SOURCE/pmc_server.f90 (modified) (27 diffs)

palm/trunk/SCRIPTS/mrun

@@ -22 +22 @@
 # Current revisions:
 # ------------------
-# 
+# test: implementing an execute mechanism where the execute command is given in the
+# configuration file
+# ROPTS removed from execution commands
+# Warnings about missing optional files or user code changed to informative messages
 # 
 # Former revisions:
@@ -245 +248 @@
  exclude=""
  executable=""
+ execute_command="none"
  execution_error=false
  fftw_inc=""
@@ -671 +675 @@
     while read line
     do
-       if [[ "$line" != ""  &&  $(echo $line | cut -c1) != "#" &&  $(echo $line | cut -d" " -s -f4) = $cond1 && $(echo $line | cut -d" " -s -f4)  = $cond2 ]]
+       echo line=\"$line\"
+       if [[ "$line" != ""  &&  $(echo $line | cut -c1) != "#" &&  $(echo $line | cut -d" " -s -f4) = $cond1 && $(echo $line | cut -d" " -s -f5)  = $cond2 ]]
        then
           coupled_mode="mpi2"
@@ -1594 +1599 @@
        if [[ ! -d $add_source_path ]]
        then
-          printf "\n\n  +++ WARNING: additional source code directory"
+          printf "\n\n  *** INFORMATIVE: additional source code directory"
           printf "\n      \"$add_source_path\" "
           printf "\n      does not exist or is not a directory."
@@ -1893 +1898 @@
 
 
-
     # DETERMINE COMPILE- AND LINK-OPTIONS
  fopts="$fopts $netcdf_inc $fftw_inc $dvr_inc"
  lopts="$lopts $netcdf_lib $fftw_lib $dvr_lib"
- ROPTS="$ropts"
-# if [[ ( $(echo $host | cut -c1-3) = nec  ||  $(echo $host | cut -c1-3) = ibm  ||  $host = lckyoto  ||  $host = lctit  ||  $host = lcflow  ||  $host = lcxe6 ||  $host = lcxt5m || $host = lck || $host = lckiaps || $host = lckordi || $host = lcsb || $host )  &&  -n $numprocs ]]
-# then
-    XOPT="-X $numprocs"
-# fi
-
+ XOPT="-X $numprocs"
 
 
@@ -2875 +2874 @@
           if [[ "${extin[$i]}" = ""  ||  "${extin[$i]}" = " " ]]
           then
-             printf "\n  +++ WARNING: input file \"${pathin[$i]}/${afname}${endin[$i]}\" "
-             printf "\n               is not available!"
+             printf "\n  *** INFORMATIVE: input file \"${pathin[$i]}/${afname}${endin[$i]}\" "
+             printf "\n                   is not available!"
           else
-             printf "\n  +++ WARNING: input file \"${pathin[$i]}/${afname}${endin[$i]}.${extin[$i]}\" "
-             printf "\n               is not available!"
+             printf "\n  *** INFORMATIVE: input file \"${pathin[$i]}/${afname}${endin[$i]}.${extin[$i]}\" "
+             printf "\n                   is not available!"
           fi
           continue
@@ -3259 +3258 @@
     PATH=$PATH:$TEMPDIR
 
-       # MPI DEBUG OPTION (ARGUMENT CHECKING, SLOWS DOWN EXECUTION DUE TO INCREASED LATENCY)
-    if [[ "$mpi_debug" = true ]]
-    then
-       export MPI_CHECK_ARGS=1
-       printf "\n  +++ MPI_CHECK_ARGS=$MPI_CHECK_ARGS"
-    fi
-
-    if [[ "$totalview" = true ]]
-    then
-       printf "\n *** totalview debugger will be used"
-       tv_opt="-tv"
+
+    if [[ $execute_command != "none" ]]
+    then
+
+        printf "\n  +++ branch still not realized"
+        locat=execution
+        exit
+
     else
-       tv_opt=""
-    fi
-
-    if [[ "$cond1" = debug  ||  "$cond2" = debug ]]
-    then
-
-          #Interactive ALLINEA DEBUG seesion
-       if [[ "$ENVIRONMENT" != BATCH ]]
-       then
-          if [[ $host = lccrayb || $host = lccrayh ]]
-          then
-             if [[ "$allinea" = true ]]
-             then
-                echo "--- aprun  -n $ii  -N $tasks_per_node  a.out  $ROPTS  < runfile_atmos"
-
-                ddt  aprun  -n $ii  -N $tasks_per_node  a.out  $ROPTS  
-                wait
-             fi         
-          fi
-       fi
-
-       if [[ "$ENVIRONMENT" = BATCH ]]
-       then
-          continue
-       fi
-       if [[ $localhost = ibmh ]]
-       then
-
-             # SETUP THE IBM MPI ENVIRONMENT
-          export MP_SHARED_MEMORY=yes
-          export AIXTHREADS_SCOPE=S
-          export OMP_NUM_THREADS=$threads_per_task
-          export AUTHSTATE=files
-          export XLFRTEOPTS="nlwidth=132:err_recovery=no"    # RECORD-LENGTH OF NAMELIST-OUTPUT
-
-             # FOLLOWING OPTIONS ARE MANDATORY FOR TOTALVIEW
-          export MP_ADAPTER_USE=shared
-          export MP_CPU_USE=multiple
-          export MP_TIMEOUT=1200
-
-          unset  MP_TASK_AFFINITY
-
-             # SO FAR, TOTALVIEW NEEDS HOSTFILE MECHANISM FOR EXECUTION
-          #(( ii = 1 ))
-          #while (( ii <= $numprocs ))
-          #do
-          #   echo  $localhost_realname  >>  hostfile
-          #   (( ii = ii + 1 ))
-          #done
-          #export MP_HOSTFILE=hostfile
-
-          if [[ "$LOADLBATCH" = yes ]]
-          then
-             totalview   poe  a.out  $ROPTS
-          else
-             echo totalview   poe  -a a.out  -procs $numprocs  -rmpool 0  -nodes 1   $ROPTS
-             export TVDSVRLAUNCHCMD=ssh
-             totalview   poe  -a a.out  -procs $numprocs  -rmpool 0  -nodes 1   $ROPTS
-          fi
-
-       fi  # END DEBUG MODE
-
-    else
-
-          # NORMAL EXECUTION
-       if [[ -n $numprocs ]]
-       then
-
-             # RUNNING THE PROGRAM ON PARALLEL MACHINES
-          if [[ $(echo $host | cut -c1-3) = ibm ]]
+
+          # MPI DEBUG OPTION (ARGUMENT CHECKING, SLOWS DOWN EXECUTION DUE TO INCREASED LATENCY)
+       if [[ "$mpi_debug" = true ]]
+       then
+          export MPI_CHECK_ARGS=1
+          printf "\n  +++ MPI_CHECK_ARGS=$MPI_CHECK_ARGS"
+       fi
+
+       if [[ "$totalview" = true ]]
+       then
+          printf "\n *** totalview debugger will be used"
+          tv_opt="-tv"
+       else
+          tv_opt=""
+       fi
+
+       if [[ "$cond1" = debug  ||  "$cond2" = debug ]]
+       then
+
+             #Interactive ALLINEA DEBUG seesion
+          if [[ "$ENVIRONMENT" != BATCH ]]
+          then
+             if [[ $host = lccrayb || $host = lccrayh ]]
+             then
+                if [[ "$allinea" = true ]]
+                then
+                   echo "--- aprun  -n $ii  -N $tasks_per_node  a.out  < runfile_atmos"
+
+                   ddt  aprun  -n $ii  -N $tasks_per_node  a.out
+                   wait
+                fi         
+             fi
+          fi
+
+          if [[ $localhost = ibmh ]]
           then
 
                 # SETUP THE IBM MPI ENVIRONMENT
-             if [[ $host != ibmh  &&  $host != ibmkisti ]]
-             then
-                export MP_SHARED_MEMORY=yes
-                export AIXTHREAD_SCOPE=S
-                export OMP_NUM_THREADS=$threads_per_task
-                export XLSMPOPTS="spins=0:yields=0:stack=20000000"
-                export AUTHSTATE=files
-                export XLFRTEOPTS="nlwidth=132:err_recovery=no"    # RECORD-LENGTH OF NAMELIST-OUTPUT
-                #  export MP_PRINTENV=yes
-
-                   # TUNING-VARIABLES TO IMPROVE COMMUNICATION SPEED
-                   # DO NOT SHOW SIGNIFICANT EFFECTS (SEP 04, FEDERATION-SWITCH)
-                export MP_WAIT_MODE=poll
-                [[ $node_usage = not_shared ]]  &&  export MP_SINGLE_THREAD=yes
+             export MP_SHARED_MEMORY=yes
+             export AIXTHREADS_SCOPE=S
+             export OMP_NUM_THREADS=$threads_per_task
+             export AUTHSTATE=files
+             export XLFRTEOPTS="nlwidth=132:err_recovery=no"    # RECORD-LENGTH OF NAMELIST-OUTPUT
+
+                # FOLLOWING OPTIONS ARE MANDATORY FOR TOTALVIEW
+             export MP_ADAPTER_USE=shared
+             export MP_CPU_USE=multiple
+             export MP_TIMEOUT=1200
+
+             unset  MP_TASK_AFFINITY
+
+             if [[ "$LOADLBATCH" = yes ]]
+             then
+                totalview   poe  a.out
+             else
+                echo totalview   poe  -a a.out  -procs $numprocs  -rmpool 0  -nodes 1
+                export TVDSVRLAUNCHCMD=ssh
+                totalview   poe  -a a.out  -procs $numprocs  -rmpool 0  -nodes 1
              fi
 
-             if [[ $host = ibmkisti ]]
-             then
-                export LANG=en_US
-                export MP_SHARED_MEMORY=yes
-                if [[ $threads_per_task = 1 ]]
+          fi  # END DEBUG MODE
+
+       else
+
+             # NORMAL EXECUTION
+          if [[ -n $numprocs ]]
+          then
+
+                # RUNNING THE PROGRAM ON PARALLEL MACHINES
+             if [[ $(echo $host | cut -c1-3) = ibm ]]
+             then
+
+                   # SETUP THE IBM MPI ENVIRONMENT
+                if [[ $host != ibmh  &&  $host != ibmkisti ]]
                 then
-                   export MP_SINGLE_THREAD=yes
-                   export MEMORY_AFFINITY=MCM
+                   export MP_SHARED_MEMORY=yes
+                   export AIXTHREAD_SCOPE=S
+                   export OMP_NUM_THREADS=$threads_per_task
+                   export XLSMPOPTS="spins=0:yields=0:stack=20000000"
+                   export AUTHSTATE=files
+                   export XLFRTEOPTS="nlwidth=132:err_recovery=no"    # RECORD-LENGTH OF NAMELIST-OUTPUT
+                   #  export MP_PRINTENV=yes
+
+                      # TUNING-VARIABLES TO IMPROVE COMMUNICATION SPEED
+                      # DO NOT SHOW SIGNIFICANT EFFECTS (SEP 04, FEDERATION-SWITCH)
+                   export MP_WAIT_MODE=poll
+                   [[ $node_usage = not_shared ]]  &&  export MP_SINGLE_THREAD=yes
+                fi
+
+                if [[ $host = ibmkisti ]]
+                then
+                   export LANG=en_US
+                   export MP_SHARED_MEMORY=yes
+                   if [[ $threads_per_task = 1 ]]
+                   then
+                      export MP_SINGLE_THREAD=yes
+                      export MEMORY_AFFINITY=MCM
+                   else
+                      export OMP_NUM_THREADS=$threads_per_task
+                   fi
+                fi
+
+                if [[ "$LOADLBATCH" = yes ]]
+                then
+                   printf "\n--- Control: OMP_NUM_THREADS = \"$OMP_NUM_THREADS\" \n"
+                   if [[ "$cond1" = hpmcount  ||  "$cond2" = hpmcount ]]
+                   then
+                      /opt/optibm/HPM_2_4_1/bin/hpmcount  a.out
+                   else
+                      if [[ $run_coupled_model = false ]]
+                      then
+                         if [[ "$ocean_file_appendix" = true ]]
+                         then
+                            echo "precursor_ocean"  >  runfile_atmos
+                         else
+                            echo "precursor_atmos"  >  runfile_atmos
+                         fi
+                      else
+                         (( iia = $numprocs_atmos / $threads_per_task ))
+                         (( iio = $numprocs_ocean / $threads_per_task ))
+                         printf "\n      coupled run ($iia atmosphere, $iio ocean)"
+                         printf "\n      using $coupled_mode coupling"
+                         printf "\n\n"
+                         echo "coupled_run $iia $iio"  >  runfile_atmos
+                      fi
+                      poe ./a.out  <  runfile_atmos
+                   fi
                 else
-                   export OMP_NUM_THREADS=$threads_per_task
+                   if [[ $localhost = ibmh  ||  $localhost = ibms ]]
+                   then
+                      poe  a.out  -procs $numprocs  -nodes 1  -rmpool 0
+                   elif [[ $localhost = ibmkisti  ||  $localhost = ibmku ]]
+                   then
+                      if [[ -f $hostfile ]]
+                      then
+                         cp  $hostfile  hostfile
+                      else
+                         (( ii = 1 ))
+                         while (( ii <= $numprocs ))
+                         do
+                            echo  $localhost_realname  >>  hostfile
+                            (( ii = ii + 1 ))
+                         done
+                      fi
+                      export MP_HOSTFILE=hostfile
+                      if [[ $run_coupled_model = false ]]
+                      then
+                         if [[ "$ocean_file_appendix" = true ]]
+                         then
+                            echo "precursor_ocean"  >  runfile_atmos
+                         else
+                            echo "precursor_atmos"  >  runfile_atmos
+                         fi
+                      else
+                         (( iia = $numprocs_atmos / $threads_per_task ))
+                         (( iio = $numprocs_ocean / $threads_per_task ))
+                         printf "\n      coupled run ($iia atmosphere, $iio ocean)"
+                         printf "\n      using $coupled_mode coupling"
+                         printf "\n\n"
+                         echo "coupled_run $iia $iio"  >  runfile_atmos
+                      fi
+
+                      poe  ./a.out  -procs $numprocs  <  runfile_atmos 
+
+                   else
+                      if [[ "$host_file" = "" ]]
+                      then
+                         printf "\n  +++ no hostfile given in configuration file"
+                         locat=config_file
+                         exit
+                      else
+                         eval host_file=$host_file
+                      fi
+                      export MP_HOSTFILE=$host_file
+                      poe  a.out  -procs $numprocs  -tasks_per_node $numprocs
+                   fi
                 fi
-             fi
-
-             if [[ "$LOADLBATCH" = yes ]]
-             then
-                printf "\n--- Control: OMP_NUM_THREADS = \"$OMP_NUM_THREADS\" \n"
-                if [[ "$cond1" = hpmcount  ||  "$cond2" = hpmcount ]]
+
+             elif [[ $host = nech ]]  # running on NEC machines
+             then
+
+                (( ii = nodes ))
+                if [[ $ii = 1 ]]
                 then
-                   /opt/optibm/HPM_2_4_1/bin/hpmcount  a.out  $ROPTS
+                   export F_ERRCNT=0        # acceptable number of errors before program is stopped
+                   export MPIPROGINF=YES
+                   #  export F_TRACE=YES|FMT1|FMT2  # output of ftrace informations to job protocol
+                   echo "*** execution on single node with mpirun"
+                   mpirun  -np $numprocs  ./a.out
                 else
-                   if [[ $run_coupled_model = false ]]
-                   then
-                      if [[ "$ocean_file_appendix" = true ]]
-                      then
-                         echo "precursor_ocean"  >  runfile_atmos
-                      else
-                         echo "precursor_atmos"  >  runfile_atmos
-                      fi
-                   else
-                      (( iia = $numprocs_atmos / $threads_per_task ))
-                      (( iio = $numprocs_ocean / $threads_per_task ))
-                      printf "\n      coupled run ($iia atmosphere, $iio ocean)"
-                      printf "\n      using $coupled_mode coupling"
-                      printf "\n\n"
-                      echo "coupled_run $iia $iio"  >  runfile_atmos
-                   fi
-                   poe ./a.out  $ROPTS  <  runfile_atmos
+                   (( i = 0 ))
+                   while (( i < ii ))
+                   do
+                      echo "-h $i  -p $tasks_per_node  -e ./mpi_exec_shell"  >>  multinode_config
+                      (( i = i + 1 ))
+                   done
+
+                   echo "#!/bin/sh"                         >   mpi_exec_shell
+                   echo " "                                 >>  mpi_exec_shell
+                   echo "set -u"                            >>  mpi_exec_shell
+                   echo "F_ERRCNT=0"                        >>  mpi_exec_shell
+                   echo "MPIPROGINV=YES"                    >>  mpi_exec_shell
+                   echo "OMP_NUM_THREADS=$threads_per_task" >>  mpi_exec_shell 
+                   echo "cpurest=$cpurest"                  >>  mpi_exec_shell
+                   echo "fname=$fname"                      >>  mpi_exec_shell
+                   echo "localhost=$localhost"              >>  mpi_exec_shell
+                   echo "return_address=$return_address"    >>  mpi_exec_shell
+                   echo "return_username=$return_username"  >>  mpi_exec_shell
+                   echo "tasks_per_node=$tasks_per_node"    >>  mpi_exec_shell
+                   echo "write_binary=$write_binary"        >>  mpi_exec_shell
+                   echo "use_seperate_pe_for_dvrp_output=$use_seperate_pe_for_dvrp_output"  >>  mpi_exec_shell
+                   echo "  "                                >>  mpi_exec_shell
+                   echo "export F_ERRCNT"                   >>  mpi_exec_shell
+                   echo "export MPIPROGINV"                 >>  mpi_exec_shell
+                   echo "export OMP_NUM_THREADS"            >>  mpi_exec_shell
+                   echo "export cpurest"                    >>  mpi_exec_shell
+                   echo "export fname"                      >>  mpi_exec_shell
+                   echo "export localhost"                  >>  mpi_exec_shell
+                   echo "export return_address"             >>  mpi_exec_shell
+                   echo "export return_username"            >>  mpi_exec_shell
+                   echo "export tasks_per_node"             >>  mpi_exec_shell
+                   echo "export write_binary"               >>  mpi_exec_shell
+                   echo "export use_seperate_pe_for_dvrp_output"  >>  mpi_exec_shell
+                   echo " "                                 >>  mpi_exec_shell
+                   echo "exec  ./a.out"                     >>  mpi_exec_shell
+
+                   chmod u+x  mpi_exec_shell
+                   export MPIPROGINF=YES
+                   mpirun  -f multinode_config  &
+                   wait
+
                 fi
-             else
-                if [[ $localhost = ibmh  ||  $localhost = ibms ]]
-                then
-                   poe  a.out  -procs $numprocs  -nodes 1  -rmpool 0  $ROPTS
-                elif [[ $localhost = ibmkisti  ||  $localhost = ibmku ]]
+
+             elif [[ $(echo $host | cut -c1-2) = lc  &&  $host != lckyoto &&  $host != lctit ]]
+             then
+
+                   # COPY HOSTFILE FROM SOURCE DIRECTORY OR CREATE IT, IF IT
+                   # DOES NOT EXIST
+                if [[  $host != lcbullhh  && $host != lccrayb  &&  $host != lccrayf  && $host != lccrayh  &&  $host != lckyuh  &&  $host != lckyut ]]
                 then
                    if [[ -f $hostfile ]]
                    then
                       cp  $hostfile  hostfile
+                      (( ii = $numprocs / $threads_per_task ))
+                      [[ $ii = 0 ]]  &&  (( ii = 1 ))
                    else
                       (( ii = 1 ))
-                      while (( ii <= $numprocs ))
+                      while (( ii <= $numprocs / $threads_per_task ))
                       do
                          echo  $localhost_realname  >>  hostfile
                          (( ii = ii + 1 ))
                       done
+                      if (( $numprocs / $threads_per_task == 0 ))
+                      then
+                         echo  $localhost_realname  >>  hostfile
+                      fi
                    fi
-                   export MP_HOSTFILE=hostfile
-                   if [[ $run_coupled_model = false ]]
+                   eval zeile=\"`head -n $ii  hostfile`\"
+                   printf "\n  *** running on: $zeile"
+                fi
+
+                (( ii = $numprocs / $threads_per_task ))
+                [[ $ii = 0 ]]  &&  (( ii = 1 ))
+                export OMP_NUM_THREADS=$threads_per_task
+
+                if [[ $threads_per_task != 1 ]]
+                then
+                      # INCREASE STACK SIZE TO UNLIMITED, BECAUSE OTHERWISE LARGE RUNS
+                      # MAY ABORT
+                   ulimit -s unlimited
+                   printf "\n      threads per task: $threads_per_task  stacksize: unlimited"
+                fi
+                if [[ $run_coupled_model = false ]]
+                then
+                   if [[ "$ocean_file_appendix" = true ]]
                    then
-                      if [[ "$ocean_file_appendix" = true ]]
+                      echo "precursor_ocean"  >  runfile_atmos
+                   else
+                      echo "precursor_atmos"  >  runfile_atmos
+                   fi
+                   printf "\n\n"
+
+                   if [[ $host = lccrayb || $host = lccrayh ]]
+                   then
+                       echo "--- aprun  -n $ii  -N $tasks_per_node  a.out  <  runfile_atmos"
+                       aprun  -n $ii  -N $tasks_per_node  a.out  <  runfile_atmos
+                   elif [[ $host = lcbullhh ]]
+                   then
+                      export OMPI_MCA_pml=cm
+                      export OMPI_MCA_mtl=mxm
+                      export OMPI_MCA_coll=^ghc
+                      export OMPI_MCA_mtl_mxm_np=0
+                      export MXM_RDMA_PORTS=mlx5_0:1
+                      export MXM_LOG_LEVEL=ERROR 
+                      export OMP_NUM_THREADS=$threads_per_task
+                      export KMP_AFFINITY=verbose,granularity=core,compact,1
+                      export KMP_STACKSIZE=64m
+
+                      srun  --nodes=$nodes --ntasks-per-node=$tasks_per_node ./a.out  <  runfile_atmos
+
+                   elif [[ $host = lccrayf ]]
+                   then
+                       aprun  -j1  -n $ii  -N $tasks_per_node  -m ${memory}M  a.out  <  runfile_atmos
+                   elif [[ $host = lcxe6  ||  $host = lcxt5m ]]
+                   then
+                       aprun  -n $ii  -N $tasks_per_node  a.out  <  runfile_atmos
+                   elif [[ $host = lcflow ]]
+                   then
+                      mpirun -np $ii a.out  < runfile_atmos
+                   elif [[ $host = lcsb ]]
+                   then
+                      mpirun_rsh -hostfile $PBS_NODEFILE -np `cat $PBS_NODEFILE | wc -l` a.out  < runfile_atmos
+                   elif [[ $host = lckiaps ]]
+                   then
+                      mpirun -np $ii  -f $PBS_NODEFILE  a.out  <  runfile_atmos
+                   elif [[ $host = lckyu* ]]
+                   then
+                      mpiexec -n $ii --stdin runfile_atmos  ./a.out
+                   else
+                      mpiexec  -machinefile hostfile  -n $ii  a.out  <  runfile_atmos
+                   fi
+
+                else
+
+                       # CURRENTLY THERE IS NO FULL MPI-2 SUPPORT ON ICE AND XT4
+                   (( iia = $numprocs_atmos / $threads_per_task ))
+                   (( iio = $numprocs_ocean / $threads_per_task ))
+                   printf "\n      coupled run ($iia atmosphere, $iio ocean)"
+                   printf "\n      using $coupled_mode coupling"
+                   printf "\n\n"
+
+                   if [[ $coupled_mode = "mpi2" ]]
+                   then
+                      echo "atmosphere_to_ocean $iia $iio"  >  runfile_atmos
+                      echo "ocean_to_atmosphere $iia $iio"  >  runfile_ocean
+
+                      if [[ $host = lccrayf  ||  $host = lcxe6  ||  $host = lcxt5m ]]
                       then
-                         echo "precursor_ocean"  >  runfile_atmos
+
+                         aprun  -n $iia  -N $tasks_per_node  a.out < runfile_atmos  &
+                         aprun  -n $iio  -N $tasks_per_node  a.out < runfile_ocean  &
+
                       else
-                         echo "precursor_atmos"  >  runfile_atmos
+                             # WORKAROUND BECAUSE mpiexec WITH -env option IS NOT AVAILABLE ON SOME SYSTEMS
+                          mpiexec  -machinefile hostfile  -n $iia  a.out  <  runfile_atmos &
+                          mpiexec  -machinefile hostfile  -n $iio  a.out  <  runfile_ocean &
+#                          mpiexec  -machinefile hostfile  -n $iia  -env coupling_mode atmosphere_to_ocean  a.out  &
+#                          mpiexec  -machinefile hostfile  -n $iio  -env coupling_mode ocean_to_atmosphere  a.out  &
                       fi
+                      wait
+
                    else
-                      (( iia = $numprocs_atmos / $threads_per_task ))
-                      (( iio = $numprocs_ocean / $threads_per_task ))
-                      printf "\n      coupled run ($iia atmosphere, $iio ocean)"
-                      printf "\n      using $coupled_mode coupling"
-                      printf "\n\n"
+
                       echo "coupled_run $iia $iio"  >  runfile_atmos
+
+                      if [[ $host = lccrayf  ||  $host = lcxe6  ||  $host = lcxt5m ]]
+                      then
+
+                         aprun  -n $ii  -N $tasks_per_node  a.out < runfile_atmos
+
+                      elif [[ $host = lck || $host = lckordi ]]
+                      then
+
+                         mpiexec -n $ii  ./a.out  <  runfile_atmos  &
+
+                      elif [[ $host = lckyu* ]]
+                      then
+
+                         mpiexec -n $ii --stdin runfile_atmos  ./a.out
+
+                      elif [[ $host = lcmuk ]] 
+                      then
+
+                         mpiexec  -machinefile hostfile  -n $ii  a.out  <  runfile_atmos
+
+                      fi
+                      wait
                    fi
 
-                   poe  ./a.out  -procs $numprocs $ROPTS  <  runfile_atmos 
-
+                fi
+
+             elif [[ $host = lckyoto ]]
+             then
+                set -xv
+                export P4_RSHCOMMAND=plesh
+                echo "     P4_RSHCOMMAND = $P4_RSHCOMMAND"
+                if [[ "$ENVIRONMENT" = BATCH ]]
+                then
+                   if [[ "$cond2" = fujitsu ]]
+                   then
+                      mpiexec  -n $numprocs  ./a.out  # for fujitsu-compiler
+                   elif [[ "cond2" = pgi ]]
+                   then
+                      mpirun  -np $numprocs  -machinefile ${QSUB_NODEINF}  ./a.out
+                   else
+                      mpirun_rsh -np $numprocs -hostfile ${QSUB_NODEINF} MV2_USE_SRQ=0 ./a.out  ||  /bin/true
+                   fi
                 else
-                   if [[ "$host_file" = "" ]]
+                   if [[ "$cond2" = "" ]]
                    then
-                      printf "\n  +++ no hostfile given in configuration file"
-                      locat=config_file
-                      exit
+                      mpiruni_rsh -np $numprocs ./a.out  # for intel
                    else
-                      eval host_file=$host_file
-                   fi
-                   export MP_HOSTFILE=$host_file
-                   poe  a.out  -procs $numprocs  -tasks_per_node $numprocs  $ROPTS
-                fi
-             fi
-          elif [[ $host = nech ]]
-          then
-             (( ii = nodes ))
-             if [[ $ii = 1 ]]
-             then
-                export F_ERRCNT=0        # acceptable number of errors before program is stopped
-                export MPIPROGINF=YES
-                #  export F_TRACE=YES|FMT1|FMT2  # output of ftrace informations to job protocol
-                echo "*** execution on single node with mpirun"
-                mpirun  -np $numprocs  ./a.out  $ROPTS
-             else
-                (( i = 0 ))
-                while (( i < ii ))
-                do
-                   echo "-h $i  -p $tasks_per_node  -e ./mpi_exec_shell"  >>  multinode_config
-                   (( i = i + 1 ))
-                done
-
-                echo "#!/bin/sh"                         >   mpi_exec_shell
-                echo " "                                 >>  mpi_exec_shell
-                echo "set -u"                            >>  mpi_exec_shell
-                echo "F_ERRCNT=0"                        >>  mpi_exec_shell
-                echo "MPIPROGINV=YES"                    >>  mpi_exec_shell
-                echo "OMP_NUM_THREADS=$threads_per_task" >>  mpi_exec_shell 
-                echo "cpurest=$cpurest"                  >>  mpi_exec_shell
-                echo "fname=$fname"                      >>  mpi_exec_shell
-                echo "localhost=$localhost"              >>  mpi_exec_shell
-                echo "return_address=$return_address"    >>  mpi_exec_shell
-                echo "return_username=$return_username"  >>  mpi_exec_shell
-                echo "tasks_per_node=$tasks_per_node"    >>  mpi_exec_shell
-                echo "write_binary=$write_binary"        >>  mpi_exec_shell
-                echo "use_seperate_pe_for_dvrp_output=$use_seperate_pe_for_dvrp_output"  >>  mpi_exec_shell
-                echo "  "                                >>  mpi_exec_shell
-                echo "export F_ERRCNT"                   >>  mpi_exec_shell
-                echo "export MPIPROGINV"                 >>  mpi_exec_shell
-                echo "export OMP_NUM_THREADS"            >>  mpi_exec_shell
-                echo "export cpurest"                    >>  mpi_exec_shell
-                echo "export fname"                      >>  mpi_exec_shell
-                echo "export localhost"                  >>  mpi_exec_shell
-                echo "export return_address"             >>  mpi_exec_shell
-                echo "export return_username"            >>  mpi_exec_shell
-                echo "export tasks_per_node"             >>  mpi_exec_shell
-                echo "export write_binary"               >>  mpi_exec_shell
-                echo "export use_seperate_pe_for_dvrp_output"  >>  mpi_exec_shell
-                echo " "                                 >>  mpi_exec_shell
-                echo "exec  ./a.out"                     >>  mpi_exec_shell
-
-                chmod u+x  mpi_exec_shell
-                export MPIPROGINF=YES
-                mpirun  -f multinode_config  &
-                wait
-
-             fi
-          elif [[ $(echo $host | cut -c1-2) = lc  &&  $host != lckyoto &&  $host != lctit ]]
-          then
-
-                # COPY HOSTFILE FROM SOURCE DIRECTORY OR CREATE IT, IF IT
-                # DOES NOT EXIST
-             if [[  $host != lcbullhh  && $host != lccrayb  &&  $host != lccrayf  && $host != lccrayh  &&  $host != lckyuh  &&  $host != lckyut ]]
-
-             then
-                if [[ -f $hostfile ]]
-                then
-                   cp  $hostfile  hostfile
-                   (( ii = $numprocs / $threads_per_task ))
-                   [[ $ii = 0 ]]  &&  (( ii = 1 ))
-                else
-                   (( ii = 1 ))
-                   while (( ii <= $numprocs / $threads_per_task ))
-                   do
-                      echo  $localhost_realname  >>  hostfile
-                      (( ii = ii + 1 ))
-                   done
-                   if (( $numprocs / $threads_per_task == 0 ))
-                   then
-                      echo  $localhost_realname  >>  hostfile
+                      mpirun  -np $numprocs  ./a.out
                    fi
                 fi
-                eval zeile=\"`head -n $ii  hostfile`\"
-                printf "\n  *** running on: $zeile"
+                set +xv
+
+             elif [[ $host = lctit ]]
+             then
+                export OMP_NUM_THREADS=$threads_per_task
+                echo "OMP_NUM_THREADS=$OMP_NUM_THREADS"
+                if [[ "$threads_per_task" != 1 ]]
+                then
+                   export MV2_ENABLE_AFFINITY=0
+                fi
+                echo "----- PBS_NODEFILE content:"
+                cat $PBS_NODEFILE
+                echo "-----"
+                (( ii = $numprocs / $threads_per_task ))
+                echo "mpirun  -np $ii  -hostfile $PBS_NODEFILE ./a.out"
+                mpirun  -np $ii  -hostfile $PBS_NODEFILE  ./a.out
+
+             else
+                mpprun  -n $numprocs  a.out
              fi
-
-             (( ii = $numprocs / $threads_per_task ))
-             [[ $ii = 0 ]]  &&  (( ii = 1 ))
-             export OMP_NUM_THREADS=$threads_per_task
-
-             if [[ $threads_per_task != 1 ]]
-             then
-                   # INCREASE STACK SIZE TO UNLIMITED, BECAUSE OTHERWISE LARGE RUNS
-                   # MAY ABORT
-                ulimit -s unlimited
-                printf "\n      threads per task: $threads_per_task  stacksize: unlimited"
-             fi
-             if [[ $run_coupled_model = false ]]
-             then
-                if [[ "$ocean_file_appendix" = true ]]
-                then
-                   echo "precursor_ocean"  >  runfile_atmos
-                else
-                   echo "precursor_atmos"  >  runfile_atmos
-                fi
-                printf "\n\n"
-
-                if [[ $host = lccrayb || $host = lccrayh ]]
-                then
-                    echo "--- aprun  -n $ii  -N $tasks_per_node  a.out  $ROPTS  < runfile_atmos"
-                    aprun  -n $ii  -N $tasks_per_node  a.out  $ROPTS  < runfile_atmos
-#                    aprun  -n $ii  -ss  -r2  -j1  a.out  $ROPTS  < runfile_atmos
-
-                elif [[ $host = lcbullhh ]]
-                then
-                   export OMPI_MCA_pml=cm
-                   export OMPI_MCA_mtl=mxm
-                   export OMPI_MCA_coll=^ghc
-                   export OMPI_MCA_mtl_mxm_np=0
-                   export MXM_RDMA_PORTS=mlx5_0:1
-                   export MXM_LOG_LEVEL=ERROR 
-                   export OMP_NUM_THREADS=$threads_per_task
-                   export KMP_AFFINITY=verbose,granularity=core,compact,1
-                   export KMP_STACKSIZE=64m
-
-                   srun  --nodes=$nodes --ntasks-per-node=$tasks_per_node ./a.out  
-
-                elif [[ $host = lccrayf ]]
-                then
-                    aprun  -j1  -n $ii  -N $tasks_per_node  -m ${memory}M  a.out  $ROPTS  < runfile_atmos
-                elif [[ $host = lcxe6  ||  $host = lcxt5m ]]
-                then
-                    aprun  -n $ii  -N $tasks_per_node  a.out  $ROPTS  < runfile_atmos
-                elif [[ $host = lcflow ]]
-                then
-                   mpirun -np $ii a.out  < runfile_atmos  $ROPTS
-                elif [[ $host = lcsb ]]
-                then
-                   mpirun_rsh -hostfile $PBS_NODEFILE -np `cat $PBS_NODEFILE | wc -l` a.out  < runfile_atmos  $ROPTS
-                elif [[ $host = lckiaps ]]
-                then
-                   mpirun -np $ii  -f $PBS_NODEFILE  a.out  <  runfile_atmos  $ROPTS
-                elif [[ $host = lckyu* ]]
-                then
-                   mpiexec -n $ii --stdin runfile_atmos  ./a.out  $ROPTS
-                else
-                   mpiexec  -machinefile hostfile  -n $ii  a.out  <  runfile_atmos  $ROPTS
-                fi
-             else
-
-                    # CURRENTLY THERE IS NO FULL MPI-2 SUPPORT ON ICE AND XT4
-                (( iia = $numprocs_atmos / $threads_per_task ))
-                (( iio = $numprocs_ocean / $threads_per_task ))
-                printf "\n      coupled run ($iia atmosphere, $iio ocean)"
-                printf "\n      using $coupled_mode coupling"
-                printf "\n\n"
-
-                if [[ $coupled_mode = "mpi2" ]]
-                then
-                   echo "atmosphere_to_ocean $iia $iio"  >  runfile_atmos
-                   echo "ocean_to_atmosphere $iia $iio"  >  runfile_ocean
-
-                   if [[ $host = lccrayf  ||  $host = lcxe6  ||  $host = lcxt5m ]]
-                   then
-
-                      aprun  -n $iia  -N $tasks_per_node  a.out < runfile_atmos  $ROPTS  &
-                      aprun  -n $iio  -N $tasks_per_node  a.out < runfile_ocean  $ROPTS  &
-
-                   else
-                          # WORKAROUND BECAUSE mpiexec WITH -env option IS NOT AVAILABLE ON SOME SYSTEMS
-                       mpiexec  -machinefile hostfile  -n $iia  a.out  $ROPTS  <  runfile_atmos &
-                       mpiexec  -machinefile hostfile  -n $iio  a.out  $ROPTS  <  runfile_ocean &
-#                       mpiexec  -machinefile hostfile  -n $iia  -env coupling_mode atmosphere_to_ocean  a.out  $ROPTS  &
-#                       mpiexec  -machinefile hostfile  -n $iio  -env coupling_mode ocean_to_atmosphere  a.out  $ROPTS  &
-                   fi
-                   wait
-
-                else
-
-                   echo "coupled_run $iia $iio"  >  runfile_atmos
-
-                   if [[ $host = lccrayf  ||  $host = lcxe6  ||  $host = lcxt5m ]]
-                   then
-
-                      aprun  -n $ii  -N $tasks_per_node  a.out < runfile_atmos  $ROPTS
-
-                   elif [[ $host = lck || $host = lckordi ]]
-                   then
-
-                      mpiexec -n $ii  ./a.out  $ROPTS < runfile_atmos &
-
-                   elif [[ $host = lckyu* ]]
-                   then
-
-                      mpiexec -n $ii --stdin runfile_atmos  ./a.out  $ROPTS
-
-                   elif [[ $host = lcmuk ]] 
-                   then
-
-                      mpiexec  -machinefile hostfile  -n $ii  a.out  <  runfile_atmos  $ROPTS
-
-                   fi
-                   wait
-                fi
-
-             fi
-
-          elif [[ $host = lckyoto ]]
-          then
-             set -xv
-             export P4_RSHCOMMAND=plesh
-             echo "     P4_RSHCOMMAND = $P4_RSHCOMMAND"
-             if [[ "$ENVIRONMENT" = BATCH ]]
-             then
-                if [[ "$cond2" = fujitsu ]]
-                then
-                   mpiexec  -n $numprocs  ./a.out  $ROPTS  # for fujitsu-compiler
-                elif [[ "cond2" = pgi ]]
-                then
-                   mpirun  -np $numprocs  -machinefile ${QSUB_NODEINF}  ./a.out  $ROPTS
-                else
-                   mpirun_rsh -np $numprocs -hostfile ${QSUB_NODEINF} MV2_USE_SRQ=0 ./a.out ${ROPTS} || /bin/true
-                fi
-             else
-                if [[ "$cond2" = "" ]]
-                then
-                   mpiruni_rsh -np $numprocs ./a.out  $ROPTS  # for intel
-                else
-                   mpirun  -np $numprocs  ./a.out  $ROPTS
-                fi
-             fi
-             set +xv
-
-          elif [[ $host = lctit ]]
-          then
-             export OMP_NUM_THREADS=$threads_per_task
-             echo "OMP_NUM_THREADS=$OMP_NUM_THREADS"
-             if [[ "$threads_per_task" != 1 ]]
-             then
-                export MV2_ENABLE_AFFINITY=0
-             fi
-             echo "----- PBS_NODEFILE content:"
-             cat $PBS_NODEFILE
-             echo "-----"
-             (( ii = $numprocs / $threads_per_task ))
-             echo "mpirun  -np $ii  -hostfile $PBS_NODEFILE ./a.out  $ROPTS"
-             mpirun  -np $ii  -hostfile $PBS_NODEFILE ./a.out  $ROPTS
-
           else
-             mpprun  -n $numprocs  a.out  $ROPTS
-          fi
-      else
-          a.out  $ROPTS
-       fi
-    fi
+             a.out
+          fi
+
+       fi  # end normal (non-debug) execution
+
+    fi  # end explicit execute_command or host-specific execute actions
 
     if [[ $? != 0 ]]
@@ -3762 +3762 @@
       then
          printf "\n\n\n *** post-processing: now executing \"aprun  -n 1  -N 1 combine_plot_fields${block}.x\" ..."
-         aprun  -n 1  -N 1 combine_plot_fields${block}.x #$ROPTS < runfile_atmos 
+         aprun  -n 1  -N 1 combine_plot_fields${block}.x
       else
          printf "\n\n\n *** post-processing: now executing \"combine_plot_fields${block}.x\" ..."

palm/trunk/SCRIPTS/subjob

@@ -152 +152 @@
 
  typeset  -i   cputime=0  memory=0  Memory=0  minuten  resttime  sekunden  stunden
- typeset  -i   inumprocs  mpi_tasks=0  nodes=0  processes_per_node=0 tasks_per_node=0  threads_per_task=1
+ typeset  -i   numprocs  mpi_tasks=0  nodes=0  processes_per_node=0 tasks_per_node=0  threads_per_task=1
 
 

palm/trunk/SOURCE/Makefile

@@ -20 +20 @@
 # Current revisions:
 # ------------------
-# 
+# dependencies changed for init_peprid
 # 
 # Former revisions:
@@ -383 +383 @@
 init_masks.o: modules.o mod_kinds.o
 init_ocean.o: modules.o eqn_state_seawater.o mod_kinds.o
-init_pegrid.o: modules.o mod_kinds.o pmc_interface.o
+init_pegrid.o: modules.o mod_kinds.o
 init_pt_anomaly.o: modules.o mod_kinds.o
 init_rankine.o: modules.o mod_kinds.o

palm/trunk/SOURCE/check_open.f90

@@ -19 +19 @@
 ! Current revisions:
 ! -----------------
-! 
+! coupling_char is trimmed at every place it occurs, because it can have
+! different length now
 ! 
 ! Former revisions:
@@ -274 +275 @@
 !--       check_namelist_files!
           IF ( check_restart == 2 ) THEN
-             OPEN ( 11, FILE='PARINF'//coupling_char, FORM='FORMATTED',        &
-                        STATUS='OLD' )
-          ELSE
-             OPEN ( 11, FILE='PARIN'//coupling_char, FORM='FORMATTED',         &
+             OPEN ( 11, FILE='PARINF'//TRIM( coupling_char ),                  &
+                        FORM='FORMATTED', STATUS='OLD' )
+          ELSE
+             OPEN ( 11, FILE='PARIN'//TRIM( coupling_char ), FORM='FORMATTED', &
                         STATUS='OLD' )
           END IF
 #else
 
-          OPEN ( 11, FILE='PARIN'//coupling_char, FORM='FORMATTED',            &
+          OPEN ( 11, FILE='PARIN'//TRIM( coupling_char ), FORM='FORMATTED',    &
                      STATUS='OLD' )
 #endif
@@ -289 +290 @@
 
           IF ( myid_char == '' )  THEN
-             OPEN ( 13, FILE='BININ'//coupling_char//myid_char,                &
+             OPEN ( 13, FILE='BININ'//TRIM( coupling_char )//myid_char,        &
                         FORM='UNFORMATTED', STATUS='OLD' )
           ELSE
@@ -296 +297 @@
 !--          only this file contains the global variables
              IF ( .NOT. openfile(file_id)%opened_before )  THEN
-                OPEN ( 13, FILE='BININ'//TRIM( coupling_char )//'/_000000',      &
+                OPEN ( 13, FILE='BININ'//TRIM( coupling_char )//'/_000000',    &
                            FORM='UNFORMATTED', STATUS='OLD' )
              ELSE
-                OPEN ( 13, FILE='BININ'//TRIM( coupling_char )//'/'//myid_char,&
-                           FORM='UNFORMATTED', STATUS='OLD' )
+                OPEN ( 13, FILE='BININ'//TRIM( coupling_char )//'/'//          &
+                           myid_char, FORM='UNFORMATTED', STATUS='OLD' )
              ENDIF
           ENDIF
@@ -307 +308 @@
 
           IF ( myid_char == '' )  THEN
-             OPEN ( 14, FILE='BINOUT'//coupling_char//myid_char,               &
+             OPEN ( 14, FILE='BINOUT'//TRIM( coupling_char )//myid_char,       &
                         FORM='UNFORMATTED', POSITION='APPEND' )
           ELSE
              IF ( myid == 0  .AND. .NOT. openfile(file_id)%opened_before )  THEN
-                CALL local_system( 'mkdir  BINOUT' // coupling_char )
+                CALL local_system( 'mkdir  BINOUT' // TRIM( coupling_char ) )
              ENDIF
 #if defined( __parallel ) && ! defined ( __check )
@@ -325 +326 @@
        CASE ( 15 )
 
-          OPEN ( 15, FILE='RUN_CONTROL'//coupling_char, FORM='FORMATTED' )
+          OPEN ( 15, FILE='RUN_CONTROL'//TRIM( coupling_char ),                &
+                     FORM='FORMATTED' )
 
        CASE ( 16 )
 
-          OPEN ( 16, FILE='LIST_PROFIL'//coupling_char, FORM='FORMATTED' )
+          OPEN ( 16, FILE='LIST_PROFIL'//TRIM( coupling_char ),                &
+                     FORM='FORMATTED' )
 
        CASE ( 17 )
 
-          OPEN ( 17, FILE='LIST_PROFIL_1D'//coupling_char, FORM='FORMATTED' )
+          OPEN ( 17, FILE='LIST_PROFIL_1D'//TRIM( coupling_char ),             &
+                     FORM='FORMATTED' )
 
        CASE ( 18 )
 
-          OPEN ( 18, FILE='CPU_MEASURES'//coupling_char, FORM='FORMATTED' )
+          OPEN ( 18, FILE='CPU_MEASURES'//TRIM( coupling_char ),               &
+                     FORM='FORMATTED' )
 
        CASE ( 19 )
 
-          OPEN ( 19, FILE='HEADER'//coupling_char, FORM='FORMATTED' )
+          OPEN ( 19, FILE='HEADER'//TRIM( coupling_char ), FORM='FORMATTED' )
 
        CASE ( 20 )
 
           IF ( myid == 0  .AND. .NOT. openfile(file_id)%opened_before )  THEN
-             CALL local_system( 'mkdir  DATA_LOG' // coupling_char )
+             CALL local_system( 'mkdir  DATA_LOG' // TRIM( coupling_char ) )
           ENDIF
           IF ( myid_char == '' )  THEN
-             OPEN ( 20, FILE='DATA_LOG'//TRIM( coupling_char )//'/_000000',      &
+             OPEN ( 20, FILE='DATA_LOG'//TRIM( coupling_char )//'/_000000',    &
                         FORM='UNFORMATTED', POSITION='APPEND' )
           ELSE
@@ -358 +363 @@
              CALL MPI_BARRIER( comm2d, ierr )
 #endif
-             OPEN ( 20, FILE='DATA_LOG'//TRIM( coupling_char )//'/'//myid_char,&
-                        FORM='UNFORMATTED', POSITION='APPEND' )
+             OPEN ( 20, FILE='DATA_LOG'//TRIM( coupling_char )//'/'//          &
+                        myid_char, FORM='UNFORMATTED', POSITION='APPEND' )
           ENDIF
 
@@ -368 +373 @@
                         FORM='UNFORMATTED', POSITION='APPEND' )
           ELSE
-             OPEN ( 21, FILE='PLOT2D_XY'//coupling_char,                       &
+             OPEN ( 21, FILE='PLOT2D_XY'//TRIM( coupling_char ),                       &
                         FORM='UNFORMATTED', POSITION='APPEND' )
           ENDIF
@@ -401 +406 @@
                         FORM='UNFORMATTED', POSITION='APPEND' )
           ELSE
-             OPEN ( 22, FILE='PLOT2D_XZ'//coupling_char, FORM='UNFORMATTED',   &
-                        POSITION='APPEND' )
+             OPEN ( 22, FILE='PLOT2D_XZ'//TRIM( coupling_char ),               &
+                        FORM='UNFORMATTED', POSITION='APPEND' )
           ENDIF
 
@@ -434 +439 @@
                         FORM='UNFORMATTED', POSITION='APPEND' )
           ELSE
-             OPEN ( 23, FILE='PLOT2D_YZ'//coupling_char, FORM='UNFORMATTED',   &
-                        POSITION='APPEND' )
+             OPEN ( 23, FILE='PLOT2D_YZ'//TRIM( coupling_char ),               &
+                        FORM='UNFORMATTED', POSITION='APPEND' )
           ENDIF
 
@@ -541 +546 @@
           ELSE
              IF ( myid == 0  .AND.  .NOT. openfile(80)%opened_before )  THEN
-                CALL local_system( 'mkdir  PARTICLE_INFOS' // coupling_char )
+                CALL local_system( 'mkdir  PARTICLE_INFOS' //                  &
+                                   TRIM( coupling_char ) )
              ENDIF
 #if defined( __parallel ) && ! defined ( __check )
@@ -565 +571 @@
        CASE ( 81 )
 
-             OPEN ( 81, FILE='PLOTSP_X_PAR'//coupling_char, FORM='FORMATTED',  &
-                        DELIM='APOSTROPHE', RECL=1500, POSITION='APPEND' )
+             OPEN ( 81, FILE='PLOTSP_X_PAR'//TRIM( coupling_char ),            &
+                        FORM='FORMATTED', DELIM='APOSTROPHE', RECL=1500,       &
+                        POSITION='APPEND' )
 
        CASE ( 82 )
 
-             OPEN ( 82, FILE='PLOTSP_X_DATA'//coupling_char, FORM='FORMATTED', &
-                        POSITION = 'APPEND' )
+             OPEN ( 82, FILE='PLOTSP_X_DATA'//TRIM( coupling_char ),           &
+                        FORM='FORMATTED', POSITION = 'APPEND' )
 
        CASE ( 83 )
 
-             OPEN ( 83, FILE='PLOTSP_Y_PAR'//coupling_char, FORM='FORMATTED',  &
-                        DELIM='APOSTROPHE', RECL=1500, POSITION='APPEND' )
+             OPEN ( 83, FILE='PLOTSP_Y_PAR'//TRIM( coupling_char ),            &
+                        FORM='FORMATTED', DELIM='APOSTROPHE', RECL=1500,       &
+                        POSITION='APPEND' )
 
        CASE ( 84 )
 
-             OPEN ( 84, FILE='PLOTSP_Y_DATA'//coupling_char, FORM='FORMATTED', &
-                        POSITION='APPEND' )
+             OPEN ( 84, FILE='PLOTSP_Y_DATA'//TRIM( coupling_char ),           &
+                        FORM='FORMATTED', POSITION='APPEND' )
 
        CASE ( 85 )
@@ -590 +598 @@
           ELSE
              IF ( myid == 0  .AND.  .NOT. openfile(85)%opened_before )  THEN
-                CALL local_system( 'mkdir  PARTICLE_DATA' // coupling_char )
+                CALL local_system( 'mkdir  PARTICLE_DATA' //                   &
+                                   TRIM( coupling_char ) )
              ENDIF
 #if defined( __parallel ) && ! defined ( __check )
@@ -622 +631 @@
 !--       Set filename depending on unit number
           IF ( file_id == 101 )  THEN
-             filename = 'DATA_2D_XY_NETCDF' // coupling_char
+             filename = 'DATA_2D_XY_NETCDF' // TRIM( coupling_char )
              av = 0
           ELSE
-             filename = 'DATA_2D_XY_AV_NETCDF' // coupling_char
+             filename = 'DATA_2D_XY_AV_NETCDF' // TRIM( coupling_char )
              av = 1
           ENDIF
@@ -684 +693 @@
 !--       Set filename depending on unit number
           IF ( file_id == 102 )  THEN
-             filename = 'DATA_2D_XZ_NETCDF' // coupling_char
+             filename = 'DATA_2D_XZ_NETCDF' // TRIM( coupling_char )
              av = 0
           ELSE
-             filename = 'DATA_2D_XZ_AV_NETCDF' // coupling_char
+             filename = 'DATA_2D_XZ_AV_NETCDF' // TRIM( coupling_char )
              av = 1
           ENDIF
@@ -746 +755 @@
 !--       Set filename depending on unit number
           IF ( file_id == 103 )  THEN
-             filename = 'DATA_2D_YZ_NETCDF' // coupling_char
+             filename = 'DATA_2D_YZ_NETCDF' // TRIM( coupling_char )
              av = 0
           ELSE
-             filename = 'DATA_2D_YZ_AV_NETCDF' // coupling_char
+             filename = 'DATA_2D_YZ_AV_NETCDF' // TRIM( coupling_char )
              av = 1
           ENDIF
@@ -807 +816 @@
 !
 !--       Set filename
-          filename = 'DATA_1D_PR_NETCDF' // coupling_char
+          filename = 'DATA_1D_PR_NETCDF' // TRIM( coupling_char )
 
 !
@@ -847 +856 @@
 !
 !--       Set filename
-          filename = 'DATA_1D_TS_NETCDF' // coupling_char
+          filename = 'DATA_1D_TS_NETCDF' // TRIM( coupling_char )
 
 !
@@ -889 +898 @@
 !--       Set filename depending on unit number
           IF ( file_id == 106 )  THEN
-             filename = 'DATA_3D_NETCDF' // coupling_char
+             filename = 'DATA_3D_NETCDF' // TRIM( coupling_char )
              av = 0
           ELSE
-             filename = 'DATA_3D_AV_NETCDF' // coupling_char
+             filename = 'DATA_3D_AV_NETCDF' // TRIM( coupling_char )
              av = 1
           ENDIF
@@ -952 +961 @@
 !
 !--       Set filename
-          filename = 'DATA_1D_SP_NETCDF' // coupling_char
+          filename = 'DATA_1D_SP_NETCDF' // TRIM( coupling_char )
 
 !
@@ -994 +1003 @@
 
           IF ( myid_char == '' )  THEN
-             filename = 'DATA_PRT_NETCDF' // coupling_char
+             filename = 'DATA_PRT_NETCDF' // TRIM( coupling_char )
           ELSE
              filename = 'DATA_PRT_NETCDF' // TRIM( coupling_char ) // '/' //   &
@@ -1055 +1064 @@
 !
 !--       Set filename
-          filename = 'DATA_1D_PTS_NETCDF' // coupling_char
+          filename = 'DATA_1D_PTS_NETCDF' // TRIM( coupling_char )
 
 !
@@ -1097 +1106 @@
        CASE ( 117 )
 
-          OPEN ( 117, FILE='PROGRESS'//coupling_char, STATUS='REPLACE', FORM='FORMATTED' )
+          OPEN ( 117, FILE='PROGRESS'//TRIM( coupling_char ),                  &
+                      STATUS='REPLACE', FORM='FORMATTED' )
 
 
@@ -1106 +1116 @@
              mid = file_id - 200
              WRITE ( mask_char,'(I2.2)')  mid
-             filename = 'DATA_MASK_' // mask_char // '_NETCDF' // coupling_char
+             filename = 'DATA_MASK_' // mask_char // '_NETCDF' //              &
+                        TRIM( coupling_char )
              av = 0
           ELSE
@@ -1112 +1123 @@
              WRITE ( mask_char,'(I2.2)')  mid
              filename = 'DATA_MASK_' // mask_char // '_AV_NETCDF' //           &
-                  coupling_char
+                        TRIM( coupling_char )
              av = 1
           ENDIF

palm/trunk/SOURCE/init_grid.f90

@@ -19 +19 @@
 ! Current revisions:
 ! -----------------
-! 
+! coupling_char is trimmed at every place it occurs, because it can have
+! different length now
 !
 ! Former revisions:
@@ -89 +90 @@
 !
 ! 1069 2012-11-28 16:18:43Z maronga
-! bugfix: added coupling_char to TOPOGRAPHY_DATA to allow topography in the ocean
-!          model in case of coupled runs
+! bugfix: added coupling_char to TOPOGRAPHY_DATA to allow topography in the
+!         ocean model in case of coupled runs
 !
 ! 1036 2012-10-22 13:43:42Z raasch
@@ -680 +681 @@
 !--             Arbitrary irregular topography data in PALM format (exactly
 !--             matching the grid size and total domain size)
-                OPEN( 90, FILE='TOPOGRAPHY_DATA'//coupling_char, STATUS='OLD', &
-                      FORM='FORMATTED', ERR=10 )
+                OPEN( 90, FILE='TOPOGRAPHY_DATA'//TRIM( coupling_char ),       &
+                          STATUS='OLD', FORM='FORMATTED', ERR=10 )
                 DO  j = ny, 0, -1
                    READ( 90, *, ERR=11, END=11 )  ( topo_height(j,i), i = 0,nx )
@@ -688 +689 @@
                 GOTO 12
           
- 10             message_string = 'file TOPOGRAPHY'//coupling_char//' does not exist'
+ 10             message_string = 'file TOPOGRAPHY'//TRIM( coupling_char )//    &
+                                 ' does not exist'
                 CALL message( 'init_grid', 'PA0208', 1, 2, 0, 6, 0 )
 
- 11             message_string = 'errors in file TOPOGRAPHY_DATA'//coupling_char
+ 11             message_string = 'errors in file TOPOGRAPHY_DATA'//            &
+                                 TRIM( coupling_char )
                 CALL message( 'init_grid', 'PA0209', 1, 2, 0, 6, 0 )
 

palm/trunk/SOURCE/init_pegrid.f90

@@ -19 +19 @@
 ! Current revisions:
 ! ------------------
-! 
+! changes regarding nested domain removed: virtual PE grid will be automatically
+! calculated for nested runs too
 !
 ! Former revisions:
@@ -154 +155 @@
     USE pegrid
  
-    USE pmc_interface,                                                         &
-        ONLY:  cpl_npex, cpl_npey, nested_run
-
     USE transpose_indices,                                                     &
         ONLY:  nxl_y, nxl_yd, nxl_z, nxr_y, nxr_yd, nxr_z, nyn_x, nyn_z, nys_x,&
@@ -217 +215 @@
                            .FALSE. )
 
-    IF ( nested_run )  THEN
-!
-!--    In case of nested-domain runs, the processor grid is explicitly given
-!--    by the user in the nestpar-NAMELIST
-       pdims(1) = cpl_npex
-       pdims(2) = cpl_npey
+!
+!--    Determine the processor topology or check it, if prescribed by the user
+    IF ( npex == -1  .AND.  npey == -1 )  THEN
+
+!
+!--       Automatic determination of the topology
+       numproc_sqr = SQRT( REAL( numprocs, KIND=wp ) )
+       pdims(1)    = MAX( numproc_sqr , 1 )
+       DO  WHILE ( MOD( numprocs , pdims(1) ) /= 0 )
+          pdims(1) = pdims(1) - 1
+       ENDDO
+       pdims(2) = numprocs / pdims(1)
+
+    ELSEIF ( npex /= -1  .AND.  npey /= -1 )  THEN
+
+!
+!--    Prescribed by user. Number of processors on the prescribed topology
+!--    must be equal to the number of PEs available to the job
+       IF ( ( npex * npey ) /= numprocs )  THEN
+          WRITE( message_string, * ) 'number of PEs of the prescribed ',   &
+              'topology (', npex*npey,') does not match & the number of ', &
+              'PEs available to the job (', numprocs, ')'
+          CALL message( 'init_pegrid', 'PA0221', 1, 2, 0, 6, 0 )
+       ENDIF
+       pdims(1) = npex
+       pdims(2) = npey
 
     ELSE
 !
-!--    Determine the processor topology or check it, if prescribed by the user
-       IF ( npex == -1  .AND.  npey == -1 )  THEN
-
-!
-!--       Automatic determination of the topology
-          numproc_sqr = SQRT( REAL( numprocs, KIND=wp ) )
-          pdims(1)    = MAX( numproc_sqr , 1 )
-          DO  WHILE ( MOD( numprocs , pdims(1) ) /= 0 )
-             pdims(1) = pdims(1) - 1
-          ENDDO
-          pdims(2) = numprocs / pdims(1)
-
-       ELSEIF ( npex /= -1  .AND.  npey /= -1 )  THEN
-
-!
-!--       Prescribed by user. Number of processors on the prescribed topology
-!--       must be equal to the number of PEs available to the job
-          IF ( ( npex * npey ) /= numprocs )  THEN
-             WRITE( message_string, * ) 'number of PEs of the prescribed ',   &
-                 'topology (', npex*npey,') does not match & the number of ', & 
-                 'PEs available to the job (', numprocs, ')'
-             CALL message( 'init_pegrid', 'PA0221', 1, 2, 0, 6, 0 )
-          ENDIF
-          pdims(1) = npex
-          pdims(2) = npey
-
-       ELSE
-!
-!--       If the processor topology is prescribed by the user, the number of
-!--       PEs must be given in both directions
-          message_string = 'if the processor topology is prescribed by th' //  &
-                   'e user& both values of "npex" and "npey" must be given' // &
-                   ' in the &NAMELIST-parameter file'
-          CALL message( 'init_pegrid', 'PA0222', 1, 2, 0, 6, 0 )
-
-       ENDIF
-
-    ENDIF
-
+!--    If the processor topology is prescribed by the user, the number of
+!--    PEs must be given in both directions
+       message_string = 'if the processor topology is prescribed by th' //  &
+                'e user& both values of "npex" and "npey" must be given' // &
+                ' in the &NAMELIST-parameter file'
+       CALL message( 'init_pegrid', 'PA0222', 1, 2, 0, 6, 0 )
+
+    ENDIF
 
 !

palm/trunk/SOURCE/interaction_droplets_ptq.f90

@@ -19 +19 @@
 ! Current revisions:
 ! -----------------
-! 
+! module procedure names shortened to avoid Intel compiler warnings about too
+! long names
 ! 
 ! Former revisions:
@@ -60 +61 @@
 
     INTERFACE interaction_droplets_ptq
-       MODULE PROCEDURE interaction_droplets_ptq
-       MODULE PROCEDURE interaction_droplets_ptq_ij
+!
+!--    Internal names shortened in order ro avoid Intel compiler messages
+!--    about too long names
+       MODULE PROCEDURE i_droplets_ptq
+       MODULE PROCEDURE i_droplets_ptq_ij
     END INTERFACE interaction_droplets_ptq
  
@@ -72 +76 @@
 !> Call for all grid points
 !------------------------------------------------------------------------------!
-    SUBROUTINE interaction_droplets_ptq
+    SUBROUTINE i_droplets_ptq
 
        USE arrays_3d,                                                          &
@@ -103 +107 @@
        ENDDO
 
-    END SUBROUTINE interaction_droplets_ptq
+    END SUBROUTINE i_droplets_ptq
 
 
@@ -111 +115 @@
 !> Call for grid point i,j
 !------------------------------------------------------------------------------!
-    SUBROUTINE interaction_droplets_ptq_ij( i, j )
+    SUBROUTINE i_droplets_ptq_ij( i, j )
 
        USE arrays_3d,                                                          &
@@ -139 +143 @@
        ENDDO
 
-    END SUBROUTINE interaction_droplets_ptq_ij
+    END SUBROUTINE i_droplets_ptq_ij
 
  END MODULE interaction_droplets_ptq_mod

palm/trunk/SOURCE/modules.f90

@@ -19 +19 @@
 ! Current revisions:
 ! ------------------
-!
+! coupling_char extended to LEN=3
 !
 ! Former revisions:
@@ -578 +578 @@
 
     CHARACTER (LEN=1)    ::  cycle_mg = 'w', timestep_reason = ' '
-    CHARACTER (LEN=2)    ::  coupling_char = ''
+    CHARACTER (LEN=3)    ::  coupling_char = ''
     CHARACTER (LEN=5)    ::  write_binary = 'false'
     CHARACTER (LEN=8)    ::  most_method = 'lookup', & !< NAMELIST parameter defining method to be used to calculate Okukhov length, 

palm/trunk/SOURCE/palm.f90

@@ -19 +19 @@
 ! Current revisions:
 ! -----------------
-!
+! setting of nest_domain and coupling_char moved to the pmci
 !
 ! Former revisions:
@@ -198 +198 @@
 !-- be changed in init_pegrid).
     IF ( nested_run )  THEN
-!--    TO_DO: move the following two settings somewehere to the pmc_interface
-       IF ( cpl_id >= 2 )  THEN
-          nest_domain = .TRUE.
-          WRITE( coupling_char, '(A1,I1.1)') '_', cpl_id
-       ENDIF
 
        CALL MPI_COMM_SIZE( comm_palm, numprocs, ierr )

palm/trunk/SOURCE/pmc_client.f90

@@ -20 +20 @@
 ! Current revisions:
 ! ------------------
-!
+! kind=dp replaced by wp, dim_order removed
+! array management changed from linked list to sequential loop
 !
 ! Former revisions:
@@ -50 +51 @@
     USE  kinds
     USE  PMC_general,   ONLY: ClientDef, DA_NameDef, DA_Namelen, PMC_STATUS_OK, PMC_DA_NAME_ERR, PeDef, ArrayDef, &
-                                         DA_Desclen, DA_Namelen, PMC_G_SetName, PMC_G_GetName
+                                         DA_Desclen, DA_Namelen, PMC_G_SetName, PMC_MAX_ARRAY
     USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_server_comm
     USE  PMC_MPI_wrapper,           ONLY: PMC_Send_to_Server, PMC_Recv_from_Server, PMC_Time,                     &
@@ -58 +59 @@
     SAVE
 
-!   data local to this MODULE
     Type(ClientDef)                       :: me
-!-- TO_DO: what is the meaning of this? Could variables declared in this module
-!--        also have single precision?
-!    INTEGER, PARAMETER                    :: dp = wp
-
-    INTEGER, save                         :: myIndex = 0                !Counter and unique number for Data Arrays
+
+    INTEGER                               :: next_array_in_list = 0
+    INTEGER                               :: myIndex = 0                !Counter and unique number for Data Arrays
 
     ! INTERFACE section
@@ -81 +79 @@
     END INTERFACE PMC_C_Get_2D_index_list
 
+    INTERFACE PMC_C_clear_next_array_list
+        MODULE procedure PMC_C_clear_next_array_list
+    END INTERFACE PMC_C_clear_next_array_list
+
     INTERFACE PMC_C_GetNextArray
         MODULE procedure PMC_C_GetNextArray
@@ -105 +107 @@
 
     PUBLIC PMC_ClientInit , PMC_Set_DataArray_Name, PMC_C_Get_2D_index_list
-    PUBLIC PMC_C_GetNextArray, PMC_C_Set_DataArray
-    PUBLIC PMC_C_setInd_and_AllocMem , PMC_C_GetBuffer, PMC_C_PutBuffer ! ,PMC_C_GetServerType
+    PUBLIC PMC_C_GetNextArray, PMC_C_Set_DataArray, PMC_C_clear_next_array_list
+    PUBLIC PMC_C_setInd_and_AllocMem , PMC_C_GetBuffer, PMC_C_PutBuffer
 
 CONTAINS
@@ -130 +132 @@
         CALL MPI_Intercomm_merge (me%inter_comm, .true., me%intra_comm, istat);
         CALL MPI_Comm_rank (me%intra_comm, me%intra_rank, istat);
-
         ALLOCATE (me%PEs(me%inter_npes))
 
+!
+!--     Allocate for all Server PEs an array of TYPE ArrayDef to store information of transfer array
         do i=1,me%inter_npes
-           NULLIFY(me%PEs(i)%Arrays)
+           ALLOCATE(me%PEs(i)%array_list(PMC_MAX_ARRAY))
         end do
 
@@ -142 +145 @@
     END SUBROUTINE PMC_ClientInit
 
-    SUBROUTINE PMC_Set_DataArray_Name (ServerArrayDesc, ServerArrayName, ClientArrayDesc, ClientArrayName, istat, LastEntry)
+    SUBROUTINE PMC_Set_DataArray_Name (ServerArrayDesc, ServerArrayName, ClientArrayDesc, ClientArrayName, istat)
         IMPLICIT none
         character(len=*),INTENT(IN)           :: ServerArrayName
@@ -149 +152 @@
         character(len=*),INTENT(IN)           :: ClientArrayDesc
         INTEGER,INTENT(OUT)                   :: istat
-        LOGICAL,INTENT(IN),optional           :: LastEntry
 
         !-- local variables
@@ -192 +194 @@
         CALL PMC_Bcast ( myName%NameOnClient, myPE, comm=m_to_server_comm)
 
-        if(present (LastEntry))   then
-            CALL PMC_Set_DataArray_Name_LastEntry ( LastEntry = LastEntry)
-        end if
-
         CALL PMC_G_SetName (me, myName%couple_index, myName%NameOnClient)
 
@@ -231 +229 @@
        INTEGER(KIND=MPI_ADDRESS_KIND)          :: disp            !: Displacement Unit (Integer = 4, floating poit = 8
        INTEGER,DIMENSION(me%inter_npes*2)      :: NrEle           !: Number of Elements of a horizontal slice
-       TYPE(PeDef),POINTER                     :: aPE             !: Pointer to PeDef strzcture
+       TYPE(PeDef),POINTER                     :: aPE             !: Pointer to PeDef structure
        INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize         !: Size of MPI window 2 (in bytes)
        INTEGER,DIMENSION(:),POINTER            :: myInd
@@ -299 +297 @@
     END SUBROUTINE PMC_C_Get_2D_index_list
 
+    SUBROUTINE PMC_C_clear_next_array_list
+       IMPLICIT none
+
+       next_array_in_list = 0
+
+       return
+    END SUBROUTINE PMC_C_clear_next_array_list
+
+!   List handling is still required to get minimal interaction with pmc_interface
     LOGICAL function PMC_C_GetNextArray (myName)
         character(len=*),INTENT(OUT)               :: myName
 
         !-- local variables
-        INTEGER                      :: MyCoupleIndex
-        LOGICAL                      :: MyLast                             !Last Array in List
-        character(len=DA_Namelen)    :: loName
-
-        loName = 'NoName '
-        MyLast = .true.
-
-        CALL PMC_G_GetName (me, MyCoupleIndex, loName, MyLast)
-
-        myName = trim(loName)
-
-        PMC_C_GetNextArray = .NOT. MyLast                        ! Return true if valid array
-
-        return
+       TYPE(PeDef),POINTER          :: aPE
+       TYPE(ArrayDef),POINTER       :: ar
+
+       next_array_in_list = next_array_in_list+1
+
+!--    Array Names are the same on all client PE, so take first PE to get the name
+       aPE => me%PEs(1)
+
+       if(next_array_in_list > aPE%Nr_arrays) then
+          PMC_C_GetNextArray = .false.             !all arrays done
+          return
+       end if
+
+       ar  => aPE%array_list(next_array_in_list)
+
+       myName = ar%name
+
+       PMC_C_GetNextArray =  .true.                ! Return true if legal array
+       return
     END function PMC_C_GetNextArray
 
     SUBROUTINE PMC_C_Set_DataArray_2d (array)
+
        IMPLICIT none
-!--    TO_DO: is double precision absolutely required here?
-       REAL(kind=dp),INTENT(IN),DIMENSION(:,:)    :: array
-       !-- local variables
-       INTEGER                           :: NrDims
-       INTEGER,DIMENSION (4)             :: dims
-       INTEGER                           :: dim_order
-       TYPE(c_ptr)                       :: array_adr
-       INTEGER                           :: i
-       TYPE(PeDef),POINTER               :: aPE
-       TYPE(ArrayDef),POINTER            :: ar
+
+       REAL(wp), INTENT(IN) ,DIMENSION(:,:) ::  array
+
+       INTEGER                              :: NrDims
+       INTEGER,DIMENSION (4)                :: dims
+       TYPE(c_ptr)                          :: array_adr
+       INTEGER                              :: i
+       TYPE(PeDef),POINTER                  :: aPE
+       TYPE(ArrayDef),POINTER               :: ar
 
 
@@ -338 +350 @@
        dims(1)   = size(array,1)
        dims(2)   = size(array,2)
-       dim_order = 2
 
        array_adr = c_loc(array)
@@ -344 +355 @@
        do i=1,me%inter_npes
           aPE => me%PEs(i)
-          ar  => aPE%Arrays
+          ar  => aPE%array_list(next_array_in_list)    !actual array is last array in list
           ar%NrDims    = NrDims
           ar%A_dim     = dims
-          ar%dim_order = dim_order
           ar%data      = array_adr
        end do
@@ -355 +365 @@
 
     SUBROUTINE PMC_C_Set_DataArray_3d (array)
+
        IMPLICIT none
-!--    TO_DO: is double precision absolutely required here?
-       REAL(kind=dp),INTENT(IN),DIMENSION(:,:,:)  :: array
-       !-- local variables
-       INTEGER                           :: NrDims
-       INTEGER,DIMENSION (4)             :: dims
-       INTEGER                           :: dim_order
-       TYPE(c_ptr)                       :: array_adr
-       INTEGER                           :: i
-       TYPE(PeDef),POINTER               :: aPE
-       TYPE(ArrayDef),POINTER            :: ar
+
+       REAL(wp),INTENT(IN),DIMENSION(:,:,:) ::  array
+
+       INTEGER                              ::  NrDims
+       INTEGER,DIMENSION (4)                ::  dims
+       TYPE(c_ptr)                          ::  array_adr
+       INTEGER                              ::  i
+       TYPE(PeDef),POINTER                  ::  aPE
+       TYPE(ArrayDef),POINTER               ::  ar
 
        dims = 1
@@ -373 +383 @@
        dims(2)   = size(array,2)
        dims(3)   = size(array,3)
-       dim_order =33
 
        array_adr = c_loc(array)
@@ -379 +388 @@
        do i=1,me%inter_npes
           aPE => me%PEs(i)
-          ar  => aPE%Arrays
+          ar  => aPE%array_list(next_array_in_list)    !actual array is last array in list
           ar%NrDims    = NrDims
           ar%A_dim     = dims
-          ar%dim_order = dim_order
           ar%data      = array_adr
        end do
@@ -393 +401 @@
       IMPLICIT none
 
-      INTEGER                                 :: i, ierr
+      INTEGER                                 :: i, ierr, j
       INTEGER                                 :: arlen, myIndex, tag
       INTEGER(idp)                            :: bufsize                   ! Size of MPI data Window
@@ -412 +420 @@
          tag = 200
 
-         do while (PMC_C_GetNextArray (myName))
-            ar  => aPE%Arrays
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
 
             ! Receive Index from client
@@ -419 +427 @@
             CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, MPI_STATUS_IGNORE, ierr)
 
-            if(ar%dim_order == 33) then                    ! PALM has k in first dimension
+            if(ar%NrDims == 3) then                    ! PALM has k in first dimension
                bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2)*ar%A_dim(3))    ! determine max, because client buffer is allocated only once
             else
@@ -442 +450 @@
          aPE => me%PEs(i)
 
-         do while (PMC_C_GetNextArray (myName))
-            ar  => aPE%Arrays
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
             ar%SendBuf = base_ptr
          end do
@@ -452 +460 @@
 
    SUBROUTINE PMC_C_GetBuffer (WaitTime)
+
       IMPLICIT none
-      REAL(kind=dp),INTENT(OUT),optional         :: WaitTime
+
+      REAL(wp), INTENT(OUT), optional   ::  WaitTime
 
       !-- local variables
-      INTEGER                                 :: ip, ij, ierr
-      INTEGER                                 :: nr                 ! Number of Elements to getb from server
-      INTEGER                                 :: myIndex
-      REAL(kind=dp)                           :: t1,t2
-      TYPE(PeDef),POINTER                     :: aPE
-      TYPE(ArrayDef),POINTER                  :: ar
-      INTEGER,DIMENSION(1)                    :: buf_shape
-      REAL(kind=wp),POINTER,DIMENSION(:)      :: buf
-      REAL(kind=wp),POINTER,DIMENSION(:,:)    :: data_2d
-      REAL(kind=wp),POINTER,DIMENSION(:,:,:)  :: data_3d
-      character(len=DA_Namelen)               :: myName
-      INTEGER(kind=MPI_ADDRESS_KIND)          :: target_disp
+      INTEGER                           ::  ip, ij, ierr, j
+      INTEGER                           ::  nr  ! Number of Elements to getb from server
+      INTEGER                           ::  myIndex
+      REAL(wp)                          ::  t1,t2
+      TYPE(PeDef),POINTER               ::  aPE
+      TYPE(ArrayDef),POINTER            ::  ar
+      INTEGER,DIMENSION(1)              ::  buf_shape
+      REAL(wp),POINTER,DIMENSION(:)     ::  buf
+      REAL(wp),POINTER,DIMENSION(:,:)   ::  data_2d
+      REAL(wp),POINTER,DIMENSION(:,:,:) ::  data_3d
+      character(len=DA_Namelen)         ::  myName
+      INTEGER(kind=MPI_ADDRESS_KIND)    ::  target_disp
 
       t1 = PMC_Time()
       CALL MPI_Barrier(me%intra_comm, ierr)                         ! Wait for server to fill buffer
-      t2 = PMC_Time()
-      if(present(WaitTime)) WaitTime = t2-t1
+      t2 = PMC_Time()-t1
+      if(present(WaitTime)) WaitTime = t2
 
       CALL MPI_Barrier(me%intra_comm, ierr)                         ! Wait for buffer is filled
@@ -479 +489 @@
          aPE => me%PEs(ip)
 
-         do while (PMC_C_GetNextArray (myName))
-            ar  => aPE%Arrays
-            if(ar%dim_order == 2) then
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            if(ar%NrDims == 2) then
                nr = aPE%NrEle
-            else if(ar%dim_order == 33) then
+            else if(ar%NrDims == 3) then
                nr = aPE%NrEle*ar%A_dim(1)
             end if
@@ -489 +499 @@
             buf_shape(1) = nr
             CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
-
+!
+!--         MPI passive target RMA
             if(nr > 0)   then
                target_disp = (ar%BufIndex-1)
@@ -498 +509 @@
 
             myIndex = 1
-            if(ar%dim_order == 2) then
+            if(ar%NrDims == 2) then
 
                CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
@@ -505 +516 @@
                   myIndex = myIndex+1
                end do
-            else if(ar%dim_order == 33) then
+            else if(ar%NrDims == 3) then
                CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
                do ij=1,aPE%NrEle
@@ -519 +530 @@
 
    SUBROUTINE PMC_C_PutBuffer (WaitTime)
+
       IMPLICIT none
-      REAL(kind=dp),INTENT(OUT),optional         :: WaitTime
+
+      REAL(wp), INTENT(OUT), optional   :: WaitTime
 
       !-- local variables
-      INTEGER                                 :: ip, ij, ierr
-      INTEGER                                 :: nr                 ! Number of Elements to getb from server
-      INTEGER                                 :: myIndex
-      REAL(kind=dp)                           :: t1,t2
-      TYPE(PeDef),POINTER                     :: aPE
-      TYPE(ArrayDef),POINTER                  :: ar
-      INTEGER,DIMENSION(1)                    :: buf_shape
-      REAL(kind=wp),POINTER,DIMENSION(:)      :: buf
-      REAL(kind=wp),POINTER,DIMENSION(:,:)    :: data_2d
-      REAL(kind=wp),POINTER,DIMENSION(:,:,:)  :: data_3d
-      character(len=DA_Namelen)               :: myName
-      INTEGER(kind=MPI_ADDRESS_KIND)          :: target_disp
+      INTEGER                           ::  ip, ij, ierr, j
+      INTEGER                           ::  nr  ! Number of Elements to getb from server
+      INTEGER                           ::  myIndex
+      REAL(wp)                          ::  t1,t2
+      TYPE(PeDef),POINTER               ::  aPE
+      TYPE(ArrayDef),POINTER            ::  ar
+      INTEGER,DIMENSION(1)              ::  buf_shape
+      REAL(wp),POINTER,DIMENSION(:)     ::  buf
+      REAL(wp),POINTER,DIMENSION(:,:)   ::  data_2d
+      REAL(wp),POINTER,DIMENSION(:,:,:) ::  data_3d
+      character(len=DA_Namelen)         ::  myName
+      INTEGER(kind=MPI_ADDRESS_KIND)    ::  target_disp
 
 
@@ -540 +553 @@
          aPE => me%PEs(ip)
 
-         do while (PMC_C_GetNextArray (myName))
-            ar  => aPE%Arrays
-            if(ar%dim_order == 2) then
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            if(ar%NrDims == 2) then
                nr = aPE%NrEle
-            else if(ar%dim_order == 33) then
+            else if(ar%NrDims == 3) then
                nr = aPE%NrEle*ar%A_dim(1)
             end if
@@ -552 +565 @@
 
             myIndex = 1
-            if(ar%dim_order == 2) then
+            if(ar%NrDims == 2) then
                CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
                do ij=1,aPE%NrEle
@@ -558 +571 @@
                   myIndex = myIndex+1
                end do
-            else if(ar%dim_order == 33) then
+            else if(ar%NrDims == 3) then
                CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
                do ij=1,aPE%NrEle
@@ -565 +578 @@
                end do
             end if
-
+!
+!--         MPI passiv target RMA
             if(nr > 0)   then
                target_disp = (ar%BufIndex-1)

palm/trunk/SOURCE/pmc_general.f90

@@ -20 +20 @@
 ! Current revisions:
 ! ------------------
-!
+! PMC_MPI_REAL removed, dim_order removed from type arraydef,
+! array management changed from linked list to sequential loop
 !
 ! Former revisions:
@@ -62 +63 @@
    INTEGER,parameter,PUBLIC              :: PMC_DA_NAME_ERR  = 10
 
+   INTEGER,parameter,PUBLIC              :: PMC_MAX_ARRAY    = 32  !Max Number of Array which can be coupled
    INTEGER,parameter,PUBLIC              :: PMC_MAX_MODELL   = 64
-!  TO_DO: the next variable doesn't seem to be used.  Remove?
-   INTEGER,parameter,PUBLIC              :: PMC_MPI_REAL     = MPI_DOUBLE_PRECISION
    INTEGER,parameter,PUBLIC              :: DA_Desclen       = 8
    INTEGER,parameter,PUBLIC              :: DA_Namelen       = 16
@@ -77 +77 @@
       INTEGER                       :: NrDims                      ! Number of Dimensions
       INTEGER,DIMENSION(4)          :: A_dim                       ! Size of dimensions
-      INTEGER                       :: dim_order                   ! Order of Dimensions: 2 = 2D array, 33 = 3D array
       TYPE(c_ptr)                   :: data                        ! Pointer of data in server space
       TYPE(c_ptr), DIMENSION(2)     :: po_data                     ! Base Pointers, PMC_S_Set_Active_data_array sets active pointer
@@ -91 +90 @@
 
    TYPE, PUBLIC :: PeDef
-      INTEGER(idp)                        :: NrEle                 ! Number of Elemets
-      TYPE (xy_ind), POINTER,DIMENSION(:) :: locInd                ! xy index local array for remote PE
-      TYPE( ArrayDef), POINTER            :: Arrays                ! Pointer to Data Array List (Type ArrayDef)
-      TYPE( ArrayDef), POINTER            :: ArrayStart            ! Pointer to Star of the List
+      INTEGER                                :: Nr_arrays=0        ! Number of arrays which will be transfered in this run
+      INTEGER                                :: NrEle              ! Number of Elemets, same for all arrays
+      TYPE (xy_ind), POINTER,DIMENSION(:)    :: locInd             ! xy index local array for remote PE
+      TYPE( ArrayDef), POINTER, DIMENSION(:) :: array_list         ! List of Data Arrays to be transfered
    END TYPE PeDef
 
@@ -122 +121 @@
     end INTERFACE PMC_G_SetName
 
-    INTERFACE PMC_G_GetName
-       MODULE procedure PMC_G_GetName
-    end INTERFACE PMC_G_GetName
-
     INTERFACE PMC_sort
        MODULE procedure sort_2d_i
     end INTERFACE PMC_sort
 
-    PUBLIC PMC_G_SetName, PMC_G_GetName, PMC_sort
+    PUBLIC PMC_G_SetName, PMC_sort
 
 
@@ -145 +140 @@
        TYPE(PeDef),POINTER                     :: aPE
 
+!
+!--    Assign array to next free index in array_list.
+!--    Set name of array in ArrayDef structure
        do i=1,myClient%inter_npes
           aPE => myClient%PEs(i)
-          ar  => aPE%Arrays
-          if(.not. associated (ar) )  then
-             ar => DA_List_append (ar, couple_index)
-             aPE%ArrayStart => ar
-         else
-             ar => DA_List_append (ar, couple_index)
-           endif
-          Ar%Name    = trim(aName) // " "
-          myClient%PEs(i)%Arrays => ar
+          aPE%Nr_arrays = aPE%Nr_arrays+1
+          aPE%array_list(aPE%Nr_arrays)%name        = aName
+          aPE%array_list(aPE%Nr_arrays)%coupleIndex = couple_index
        end do
 
@@ -161 +153 @@
     end SUBROUTINE PMC_G_SetName
 
-    SUBROUTINE PMC_G_GetName (myClient, couple_index, aName, aLast,Client_PeIndex)
-       IMPLICIT none
-
-       TYPE(ClientDef),INTENT(INOUT)           :: myClient
-       INTEGER,INTENT(OUT)                     :: couple_index
-       CHARACTER(LEN=*),INTENT(OUT)            :: aName
-       logical,INTENT(OUT)                     :: aLast
-       INTEGER,INTENT(IN),optional             :: Client_PeIndex
-
-       INTEGER                                 :: i,istart,istop
-       TYPE(PeDef),POINTER                     :: aPE
-       TYPE(ArrayDef),POINTER                  :: ar
-       logical,save                            :: first=.true.
-
-       aLast = .false.
-
-       if(present(Client_PeIndex))  then       !Loop over all Client PEs or just one selected via Client_PeIndex
-          istart = Client_PeIndex
-          istop  = Client_PeIndex
-       else
-          istart = 1
-          istop  = myClient%inter_npes
-       end if
-
-       do i=istart,istop
-          aPE => myClient%PEs(i)
-          ar  => aPE%Arrays
-          if(first)  then
-             ar => aPE%ArrayStart
-          else
-             ar => aPE%Arrays
-             ar => DA_List_next (ar)
-             if(.not. associated (ar) )  then
-                aLast = .true.
-                first = .true.                                  !Reset linked list to begin
-                aPE%Arrays => ar
-              end if
-          endif
-          aPE%Arrays => ar
-       end do
-       if(aLast) then
-          return
-       end if
-
-       couple_index = ar%coupleIndex
-       aName        = ar%Name
-       aLast        = .false.
-
-       first = .false.
-
-
-       return
-    END SUBROUTINE PMC_G_GetName
 
     SUBROUTINE sort_2d_i (array,sort_ind)
@@ -238 +177 @@
     END  SUBROUTINE sort_2d_i
 
-!   Private section
-!   linked List routines for Data Array handling
-
-    FUNCTION DA_List_append   (node, couple_index)
-       TYPE(ArrayDef),POINTER      :: DA_List_append
-       TYPE(ArrayDef),POINTER      :: node
-       INTEGER,INTENT(IN)          :: couple_index
-
-!--    local variables
-       TYPE(ArrayDef),POINTER      :: ar
-
-       if(.not. associated (node))   then
-          ALLOCATE(ar)
-          ar%coupleIndex = couple_index
-          NULLIFY(ar%next)
-          DA_List_append => ar
-       else
-          ALLOCATE(node%next)
-          node%next%coupleIndex = couple_index
-          NULLIFY(node%next%next)
-          DA_List_append => node%next
-       end if
-
-       return
-    END FUNCTION DA_List_append
-
-    FUNCTION DA_List_next   (node)
-       TYPE(ArrayDef),POINTER      :: DA_List_next
-       TYPE(ArrayDef),POINTER      :: node
-
-       DA_List_next => node%next
-
-       return
-    END FUNCTION DA_List_next
-
 #endif
 end MODULE pmc_general

palm/trunk/SOURCE/pmc_handle_communicator.f90

@@ -20 +20 @@
 ! Current revisions:
 ! ------------------
-!
+! only the total number of PEs is given in the nestpar-NAMELIST,
+! additional comments included
 !
 ! Former revisions:
@@ -62 +63 @@
       INTEGER  ::  id
       INTEGER  ::  parent_id
-      INTEGER  ::  npe_x
-      INTEGER  ::  npe_y
+      INTEGER  ::  npe_total
 
       REAL(wp) ::  lower_left_x
@@ -155 +155 @@
             start_pe(1) = 0
             DO  i = 2, m_nrofcpl+1
-               start_pe(i) = start_pe(i-1) +                                   &
-                             m_couplers(i-1)%npe_x * m_couplers(i-1)%npe_y
+               start_pe(i) = start_pe(i-1) + m_couplers(i-1)%npe_total
             ENDDO
 
@@ -162 +161 @@
 !--         The number of cores provided with the run must be the same as the
 !--         total sum of cores required by all nest domains
-!--         TO_DO: can we use > instead of /= ?
             IF ( start_pe(m_nrofcpl+1) /= m_world_npes )  THEN
-!--            TO_DO: this IF statement is redundant
-               IF ( m_world_rank == 0 )  THEN
-                  WRITE ( message_string, '(A,I6,A,I6,A)' )                    &
-                                  'nesting-setup requires more MPI procs (',   &
-                                  start_pe(m_nrofcpl+1), ') than provided (',  &
-                                  m_world_npes,')'
-                  CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 )
-               ENDIF
+               WRITE ( message_string, '(A,I6,A,I6,A)' )                       &
+                               'nesting-setup requires more MPI procs (',      &
+                               start_pe(m_nrofcpl+1), ') than provided (',     &
+                               m_world_npes,')'
+               CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 )
             ENDIF
 
@@ -210 +205 @@
          CALL MPI_BCAST( m_couplers(i)%id,           1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
          CALL MPI_BCAST( m_couplers(i)%Parent_id,    1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
-         CALL MPI_BCAST( m_couplers(i)%npe_x,        1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
-         CALL MPI_BCAST( m_couplers(i)%npe_y,        1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
+         CALL MPI_BCAST( m_couplers(i)%npe_total,    1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
          CALL MPI_BCAST( m_couplers(i)%lower_left_x, 1, MPI_REAL,    0, MPI_COMM_WORLD, istat )
          CALL MPI_BCAST( m_couplers(i)%lower_left_y, 1, MPI_REAL,    0, MPI_COMM_WORLD, istat )
@@ -233 +227 @@
       CALL MPI_COMM_SPLIT( MPI_COMM_WORLD, m_my_cpl_id, m_my_cpl_rank, comm,   &
                            istat )
-      IF ( istat /= MPI_SUCCESS )  THEN
-!
-!--      TO_DO: replace by message-call
-!--      TO_DO: Can this really happen, or is this just for the debugging phase?
-         IF ( m_world_rank == 0 )  WRITE (0,*) 'PMC: Error in MPI_Comm_split '
-         CALL MPI_ABORT( MPI_COMM_WORLD, ierr, istat )
-      ENDIF
-
 !
 !--   Get size and rank of the model running on this PE
@@ -256 +242 @@
 
 !
-!--   TO_DO: describe what is happening here, and why
+!--   Save the current model communicator for PMC internal use
       m_model_comm = comm
 
@@ -268 +254 @@
          IF ( m_couplers(i)%parent_id == m_my_cpl_id )  THEN
 !
-!--         Collect server PEs
-!--         TO_DO: explain in more details, what is done here
+!--         Collect server PEs.
+!--         Every model exept the root model has a parent model which acts as
+!--         server model. Create an intercommunicator to connect current PE to
+!--         all client PEs
             tag = 500 + i
             CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD, start_pe(i),   &
@@ -278 +266 @@
          ELSEIF ( i == m_my_cpl_id)  THEN
 !
-!--         Collect client PEs
-!--         TO_DO: explain in more detail, what is happening here
+!--         Collect client PEs.
+!--         Every model exept the root model has a paremt model which acts as
+!--         server model. Create an intercommunicator to connect current PE to
+!--         all server PEs
             tag = 500 + i
             CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD,                &
                                        start_pe(m_couplers(i)%parent_id),      &
                                        tag, m_to_server_comm, istat )
-         ENDIF
-
-         IF ( istat /= MPI_SUCCESS )  THEN
-!
-!--         TO_DO: replace by message-call
-!--         TO_DO: can this really happen, or is this just for debugging?
-            IF ( m_world_rank == 0 )  WRITE (0,*) 'PMC: Error in Coupler Setup '
-            CALL MPI_ABORT( MPI_COMM_WORLD, ierr, istat )
          ENDIF
 
@@ -309 +291 @@
          ENDIF
       ENDDO
-!--   TO_DO: explain why this is done
-      pmc_server_for_client(clientcount+1) = -1
-
 !
 !--   Get the size of the server model
-!--   TO_DO: what does "size" mean here? Number of PEs?
       IF ( m_my_cpl_id > 1 )  THEN
          CALL MPI_COMM_REMOTE_SIZE( m_to_server_comm, m_server_remote_size,    &
@@ -337 +315 @@
 !
 !-- Make module private variables available to palm
-!-- TO_DO: why can't they be available from the beginning, i.e. why do they
-!--        first have to be declared as different private variables?
    SUBROUTINE pmc_get_local_model_info( my_cpl_id, my_cpl_parent_id, cpl_name, &
-                                        npe_x, npe_y, lower_left_x,            &
-                                        lower_left_y )
+                                        npe_total, lower_left_x, lower_left_y )
 
       USE kinds
@@ -350 +325 @@
       INTEGER, INTENT(OUT), OPTIONAL          ::  my_cpl_id
       INTEGER, INTENT(OUT), OPTIONAL          ::  my_cpl_parent_id
-      INTEGER, INTENT(OUT), OPTIONAL          ::  npe_x
-      INTEGER, INTENT(OUT), OPTIONAL          ::  npe_y
+      INTEGER, INTENT(OUT), OPTIONAL          ::  npe_total
       REAL(wp), INTENT(OUT), OPTIONAL         ::  lower_left_x
       REAL(wp), INTENT(OUT), OPTIONAL         ::  lower_left_y
 
-!--   TO_DO: is the PRESENT clause really required here?
       IF ( PRESENT( my_cpl_id )           )  my_cpl_id        = m_my_cpl_id
       IF ( PRESENT( my_cpl_parent_id )    )  my_cpl_parent_id = m_couplers(my_cpl_id)%parent_id
       IF ( PRESENT( cpl_name )            )  cpl_name         = m_couplers(my_cpl_id)%name
-      IF ( PRESENT( npe_x )               )  npe_x            = m_couplers(my_cpl_id)%npe_x
-      IF ( PRESENT( npe_y )               )  npe_y            = m_couplers(my_cpl_id)%npe_y
+      IF ( PRESENT( npe_total )           )  npe_total        = m_couplers(my_cpl_id)%npe_total
       IF ( PRESENT( lower_left_x )        )  lower_left_x     = m_couplers(my_cpl_id)%lower_left_x
       IF ( PRESENT( lower_left_y )        )  lower_left_y     = m_couplers(my_cpl_id)%lower_left_y
@@ -378 +350 @@
 
 
-
-!-- TO_DO: what does this comment mean?
-! Private SUBROUTINEs
  SUBROUTINE read_coupling_layout( nesting_mode, pmc_status )
 
@@ -438 +407 @@
 
        IF ( m_couplers(i)%id /= -1  .AND.  i <= pmc_max_modell )  THEN
-          WRITE ( 0, '(A,A,1X,4I7,1X,2F10.2)' )  'Set up Model  ',             &
-                              TRIM( m_couplers(i)%name ), m_couplers(i)%id,    &
-                              m_couplers(i)%Parent_id, m_couplers(i)%npe_x,    &
-                              m_couplers(i)%npe_y, m_couplers(i)%lower_left_x, &
-                              m_couplers(i)%lower_left_y
+          WRITE ( 0, '(A,A,1X,3I7,1X,2F10.2)' )  'Set up Model  ',             &
+                             TRIM( m_couplers(i)%name ), m_couplers(i)%id,     &
+                             m_couplers(i)%Parent_id, m_couplers(i)%npe_total, &
+                             m_couplers(i)%lower_left_x,                       &
+                             m_couplers(i)%lower_left_y
        ELSE
 !

palm/trunk/SOURCE/pmc_interface.f90

@@ -20 +20 @@
 ! Current revisions:
 ! ------------------
-!
+! only the total number of PEs is given for the domains, npe_x and npe_y
+! replaced by npe_total,
+! array management changed from linked list to sequential loop
 !
 ! Former revisions:
@@ -59 +61 @@
 
     USE control_parameters,                                                    &
-        ONLY:  dt_3d, dz, humidity, message_string, nest_bound_l,              &
-               nest_bound_r, nest_bound_s, nest_bound_n, passive_scalar,       &
-               simulated_time, topography, volume_flow
+        ONLY:  coupling_char, dt_3d, dz, humidity, message_string,             &
+               nest_bound_l, nest_bound_r, nest_bound_s, nest_bound_n,         &
+               nest_domain, passive_scalar, simulated_time, topography,        &
+               volume_flow
 
     USE cpulog,                                                                &
@@ -88 +91 @@
 
     USE pmc_client,                                                            &
-        ONLY:  pmc_clientinit, pmc_c_getnextarray, pmc_c_get_2d_index_list,    &
-               pmc_c_getbuffer, pmc_c_putbuffer, pmc_c_setind_and_allocmem,    &
+        ONLY:  pmc_clientinit, pmc_c_clear_next_array_list,                    &
+               pmc_c_getnextarray, pmc_c_get_2d_index_list, pmc_c_getbuffer,   &
+               pmc_c_putbuffer, pmc_c_setind_and_allocmem,                     &
                pmc_c_set_dataarray, pmc_set_dataarray_name
 
@@ -104 +108 @@
 
     USE pmc_server,                                                            &
-        ONLY:  pmc_serverinit, pmc_s_fillbuffer, pmc_s_getdata_from_buffer,    &
-               pmc_s_getnextarray, pmc_s_setind_and_allocmem,                  &
-               pmc_s_set_active_data_array, pmc_s_set_dataarray,               &
-               pmc_s_set_2d_index_list
+        ONLY:  pmc_serverinit, pmc_s_clear_next_array_list, pmc_s_fillbuffer,  &
+               pmc_s_getdata_from_buffer, pmc_s_getnextarray,                  &
+               pmc_s_setind_and_allocmem, pmc_s_set_active_data_array,         &
+               pmc_s_set_dataarray, pmc_s_set_2d_index_list
 
 #endif
@@ -116 +120 @@
 !--        limit. Try to reduce as much as possible
 
-!-- TO_DO: shouldn't we use public as default here? Only a minority of the
-!-- variables is private.
+!-- TO_DO: are all of these variables following now really PUBLIC?
+!--        Klaus and I guess they are not
     PRIVATE    !:  Note that the default publicity is here set to private.
 
@@ -129 +133 @@
     INTEGER(iwp), PUBLIC, SAVE      ::  cpl_id  = 1            !:
     CHARACTER(LEN=32), PUBLIC, SAVE ::  cpl_name               !:
-    INTEGER(iwp), PUBLIC, SAVE      ::  cpl_npex               !:
-    INTEGER(iwp), PUBLIC, SAVE      ::  cpl_npey               !:
+    INTEGER(iwp), PUBLIC, SAVE      ::  cpl_npe_total          !:
     INTEGER(iwp), PUBLIC, SAVE      ::  cpl_parent_id          !:
 
@@ -266 +269 @@
 !-- Module private variables.
     INTEGER(iwp), DIMENSION(3)          ::  define_coarse_grid_int    !:
-    REAL(wp), DIMENSION(9)              ::  define_coarse_grid_real   !:
+    REAL(wp), DIMENSION(7)              ::  define_coarse_grid_real   !:
 
     TYPE coarsegrid_def
@@ -364 +367 @@
 !
 !--    This is not a nested run
-!
-!--    TO_DO: this wouldn't be required any more?
        world_comm = MPI_COMM_WORLD
        cpl_id     = 1
        cpl_name   = ""
-       cpl_npex   = 2
-       cpl_npey   = 2
-       lower_left_coord_x = 0.0_wp
-       lower_left_coord_y = 0.0_wp
+
        RETURN
-    ELSE
-!
-!--    Set the general steering switch which tells PALM that its a nested run
-       nested_run = .TRUE.
+
     ENDIF
 
+!
+!-- Set the general steering switch which tells PALM that its a nested run
+    nested_run = .TRUE.
+
+!
+!-- Get some variables required by the pmc-interface (and in some cases in the
+!-- PALM code out of the pmci) out of the pmc-core
     CALL pmc_get_local_model_info( my_cpl_id = cpl_id,                         &
                                    my_cpl_parent_id = cpl_parent_id,           &
                                    cpl_name = cpl_name,                        &
-                                   npe_x = cpl_npex, npe_y = cpl_npey,         &
+                                   npe_total = cpl_npe_total,                  &
                                    lower_left_x = lower_left_coord_x,          &
                                    lower_left_y = lower_left_coord_y )
+!
+!-- Set the steering switch which tells the models that they are nested (of
+!-- course the root domain (cpl_id = 1 ) is not nested)
+    IF ( cpl_id >= 2 )  THEN
+       nest_domain = .TRUE.
+       WRITE( coupling_char, '(A1,I2.2)') '_', cpl_id
+    ENDIF
+
 !
 !-- Message that communicators for nesting are initialized.
@@ -493 +503 @@
           define_coarse_grid_real(1) = lower_left_coord_x
           define_coarse_grid_real(2) = lower_left_coord_y
-!--       TO_DO: remove this?
-          define_coarse_grid_real(3) = 0             !  KK currently not used.
-          define_coarse_grid_real(4) = 0
-          define_coarse_grid_real(5) = dx
-          define_coarse_grid_real(6) = dy
-          define_coarse_grid_real(7) = lower_left_coord_x + ( nx + 1 ) * dx
-          define_coarse_grid_real(8) = lower_left_coord_y + ( ny + 1 ) * dy
-          define_coarse_grid_real(9) = dz
+          define_coarse_grid_real(3) = dx
+          define_coarse_grid_real(4) = dy
+          define_coarse_grid_real(5) = lower_left_coord_x + ( nx + 1 ) * dx
+          define_coarse_grid_real(6) = lower_left_coord_y + ( ny + 1 ) * dy
+          define_coarse_grid_real(7) = dz
 
           define_coarse_grid_int(1)  = nx
@@ -512 +519 @@
           yez = ( nbgp + 1 ) * dy 
           IF ( cl_coord_x(0) < define_coarse_grid_real(1) + xez )          nomatch = 1 
-          IF ( cl_coord_x(nx_cl + 1) > define_coarse_grid_real(7) - xez )  nomatch = 1 
+          IF ( cl_coord_x(nx_cl + 1) > define_coarse_grid_real(5) - xez )  nomatch = 1
           IF ( cl_coord_y(0) < define_coarse_grid_real(2) + yez )          nomatch = 1 
-          IF ( cl_coord_y(ny_cl + 1) > define_coarse_grid_real(8) - yez )  nomatch = 1
+          IF ( cl_coord_y(ny_cl + 1) > define_coarse_grid_real(6) - yez )  nomatch = 1
 
           DEALLOCATE( cl_coord_x )
@@ -521 +528 @@
 !
 !--       Send coarse grid information to client
-          CALL pmc_send_to_client( client_id, Define_coarse_grid_real, 9, 0,   &
+          CALL pmc_send_to_client( client_id, Define_coarse_grid_real,         &
+                                   SIZE(define_coarse_grid_real), 0,           &
                                    21, ierr )
           CALL pmc_send_to_client( client_id, Define_coarse_grid_int,  3, 0,   &
@@ -553 +561 @@
 !
 !--    Include couple arrays into server content
+       CALL pmc_s_clear_next_array_list
        DO  WHILE ( pmc_s_getnextarray( client_id, myname ) )
           CALL pmci_set_array_pointer( myname, client_id = client_id,          &
@@ -676 +685 @@
     IF ( .NOT. pmc_is_rootmodel() )  THEN
        CALL pmc_clientinit
-       
+!
+!--    Here and only here the arrays are defined, which actualy will be
+!--    exchanged between client and server.
+!--    Please check, if the arrays are in the list of possible exchange arrays
+!--    in subroutines:
+!--    pmci_set_array_pointer (for server arrays)
+!--    pmci_create_client_arrays (for client arrays)
        CALL pmc_set_dataarray_name( 'coarse', 'u'  ,'fine', 'u',  ierr )
        CALL pmc_set_dataarray_name( 'coarse', 'v'  ,'fine', 'v',  ierr )
@@ -709 +724 @@
 !
 !--       Receive Coarse grid information.
-          CALL pmc_recv_from_server( define_coarse_grid_real, 9, 0, 21, ierr )
+          CALL pmc_recv_from_server( define_coarse_grid_real,                  &
+                                     SIZE(define_coarse_grid_real), 0, 21, ierr )
           CALL pmc_recv_from_server( define_coarse_grid_int,  3, 0, 22, ierr )
 
@@ -719 +735 @@
           WRITE(0,*) 'startx_tot    = ',define_coarse_grid_real(1)
           WRITE(0,*) 'starty_tot    = ',define_coarse_grid_real(2)
-          WRITE(0,*) 'endx_tot      = ',define_coarse_grid_real(7)
-          WRITE(0,*) 'endy_tot      = ',define_coarse_grid_real(8)
-          WRITE(0,*) 'dx            = ',define_coarse_grid_real(5)
-          WRITE(0,*) 'dy            = ',define_coarse_grid_real(6)
-          WRITE(0,*) 'dz            = ',define_coarse_grid_real(9)
+          WRITE(0,*) 'endx_tot      = ',define_coarse_grid_real(5)
+          WRITE(0,*) 'endy_tot      = ',define_coarse_grid_real(6)
+          WRITE(0,*) 'dx            = ',define_coarse_grid_real(3)
+          WRITE(0,*) 'dy            = ',define_coarse_grid_real(4)
+          WRITE(0,*) 'dz            = ',define_coarse_grid_real(7)
           WRITE(0,*) 'nx_coarse     = ',define_coarse_grid_int(1)
           WRITE(0,*) 'ny_coarse     = ',define_coarse_grid_int(2)
@@ -729 +745 @@
        ENDIF
 
-       CALL MPI_BCAST( define_coarse_grid_real, 9, MPI_REAL, 0, comm2d, ierr )
+       CALL MPI_BCAST( define_coarse_grid_real, SIZE(define_coarse_grid_real), &
+                       MPI_REAL, 0, comm2d, ierr )
        CALL MPI_BCAST( define_coarse_grid_int, 3, MPI_INTEGER, 0, comm2d, ierr )
 
-       cg%dx = define_coarse_grid_real(5)
-       cg%dy = define_coarse_grid_real(6)
-       cg%dz = define_coarse_grid_real(9)
+       cg%dx = define_coarse_grid_real(3)
+       cg%dy = define_coarse_grid_real(4)
+       cg%dz = define_coarse_grid_real(7)
        cg%nx = define_coarse_grid_int(1)
        cg%ny = define_coarse_grid_int(2)
@@ -778 +795 @@
 !
 !--    Include couple arrays into client content.
+       CALL  pmc_c_clear_next_array_list
        DO  WHILE ( pmc_c_getnextarray( myname ) )
 !--       TO_DO: Klaus, why the c-arrays are still up to cg%nz??
@@ -880 +898 @@
            ENDIF
         ENDDO
-
-        WRITE( 0, * )  'Coarse area ', myid, icl, icr, jcs, jcn
 
         coarse_bound(1) = icl
@@ -3397 +3413 @@
 !
 !-- List of array names, which can be coupled
+!-- In case of 3D please change also the second array for the pointer version
     IF ( TRIM(name) == "u" )     p_3d => u
     IF ( TRIM(name) == "v" )     p_3d => v
@@ -3403 +3420 @@
     IF ( TRIM(name) == "pt" )    p_3d => pt
     IF ( TRIM(name) == "q" )     p_3d => q
-    !IF ( TRIM(name) == "z0" )    p_2d => z0
+!
+!-- This is just an example for a 2D array, not active for coupling
+!-- Please note, that z0 has to be declared as TARGET array in modules.f90
+!    IF ( TRIM(name) == "z0" )    p_2d => z0
 
 #if defined( __nopointer )
@@ -3431 +3451 @@
     IF ( TRIM(name) == "e" )     p_3d_sec => e_2
     IF ( TRIM(name) == "pt" )    p_3d_sec => pt_2
-    !IF ( TRIM(name) == "z0" )    p_2d_sec => z0_2
+    IF ( TRIM(name) == "q" )     p_3d_sec => q_2
 
     IF ( ASSOCIATED( p_3d ) )  THEN
@@ -3437 +3457 @@
                                  array_2 = p_3d_sec )
     ELSEIF ( ASSOCIATED( p_2d ) )  THEN
-       CALL pmc_s_set_dataarray( client_id, p_2d, array_2 = p_2d_sec )
+       CALL pmc_s_set_dataarray( client_id, p_2d )
     ELSE
 !

palm/trunk/SOURCE/pmc_mpi_wrapper.f90

@@ -20 +20 @@
 ! Current revisions:
 ! ------------------
-!
+! kind=dp replaced by wp
 !
 ! Former revisions:
@@ -53 +53 @@
    SAVE
 
-!-- TO_DO: what is the meaning of this? Could variables declared in this module
-!--        also have single precision?
-!   INTEGER, PARAMETER :: dp = wp
-
-
-   ! INTERFACE section
-
    INTERFACE PMC_Send_to_Server
       MODULE PROCEDURE PMC_Send_to_Server_INTEGER
@@ -159 +152 @@
 
    SUBROUTINE  PMC_Send_to_Server_real_r1 (buf, n, Server_rank, tag, ierr)
-      IMPLICIT     none
-!--   TO_DO: has buf always to be of dp-kind, or can wp used here
-!--          this effects all respective declarations in this file
-      REAL(kind=dp), DIMENSION(:), INTENT(IN)   :: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Server_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr)
+
+      IMPLICIT     none
+
+      REAL(wp), DIMENSION(:), INTENT(IN) ::  buf
+      INTEGER, INTENT(IN)                ::  n
+      INTEGER, INTENT(IN)                ::  Server_rank
+      INTEGER, INTENT(IN)                ::  tag
+      INTEGER, INTENT(OUT)               ::  ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
 
       return
@@ -175 +168 @@
 
    SUBROUTINE  PMC_Recv_from_Server_real_r1 (buf, n, Server_rank, tag, ierr)
-      IMPLICIT     none
-      REAL(kind=dp), DIMENSION(:), INTENT(OUT)  :: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Server_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, &
-         MPI_STATUS_IGNORE, ierr)
+
+      IMPLICIT     none
+
+      REAL(wp), DIMENSION(:), INTENT(OUT) ::  buf
+      INTEGER, INTENT(IN)                 ::  n
+      INTEGER, INTENT(IN)                 ::  Server_rank
+      INTEGER, INTENT(IN)                 ::  tag
+      INTEGER, INTENT(OUT)                ::  ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm,     &
+                     MPI_STATUS_IGNORE, ierr)
 
       return
@@ -190 +185 @@
 
    SUBROUTINE  PMC_Send_to_Server_real_r2 (buf, n, Server_rank, tag, ierr)
-      IMPLICIT     none
-      REAL(kind=dp), DIMENSION(:,:), INTENT(IN) :: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Server_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr)
+
+      IMPLICIT     none
+
+      REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf
+      INTEGER, INTENT(IN)                  ::  n
+      INTEGER, INTENT(IN)                  ::  Server_rank
+      INTEGER, INTENT(IN)                  ::  tag
+      INTEGER, INTENT(OUT)                 ::  ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
 
       return
@@ -204 +201 @@
 
    SUBROUTINE  PMC_Recv_from_Server_real_r2 (buf, n, Server_rank, tag, ierr)
-      IMPLICIT     none
-      REAL(kind=dp), DIMENSION(:,:),INTENT(OUT) :: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Server_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, &
+
+      IMPLICIT     none
+
+      REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf
+      INTEGER, INTENT(IN)                   ::  n
+      INTEGER, INTENT(IN)                   ::  Server_rank
+      INTEGER, INTENT(IN)                   ::  tag
+      INTEGER, INTENT(OUT)                  ::  ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
          MPI_STATUS_IGNORE, ierr)
 
@@ -219 +218 @@
 
    SUBROUTINE  PMC_Send_to_Server_real_r3 (buf, n, Server_rank, tag, ierr)
-      IMPLICIT     none
-      REAL(kind=dp), DIMENSION(:,:,:), INTENT(IN) :: buf
-      INTEGER, INTENT(IN)                         :: n
-      INTEGER, INTENT(IN)                         :: Server_rank
-      INTEGER, INTENT(IN)                         :: tag
-      INTEGER, INTENT(OUT)                        :: ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr)
+
+      IMPLICIT     none
+
+      REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf
+      INTEGER, INTENT(IN)                    ::  n
+      INTEGER, INTENT(IN)                    ::  Server_rank
+      INTEGER, INTENT(IN)                    ::  tag
+      INTEGER, INTENT(OUT)                   ::  ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
 
       return
@@ -233 +234 @@
 
    SUBROUTINE  PMC_Recv_from_Server_real_r3 (buf, n, Server_rank, tag, ierr)
-      IMPLICIT     none
-      REAL(kind=dp), DIMENSION(:,:,:),INTENT(OUT) :: buf
-      INTEGER, INTENT(IN)                         :: n
-      INTEGER, INTENT(IN)                         :: Server_rank
-      INTEGER, INTENT(IN)                         :: tag
-      INTEGER, INTENT(OUT)                        :: ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, &
+
+      IMPLICIT     none
+
+      REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf
+      INTEGER, INTENT(IN)                     ::  n
+      INTEGER, INTENT(IN)                     ::  Server_rank
+      INTEGER, INTENT(IN)                     ::  tag
+      INTEGER, INTENT(OUT)                    ::  ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
          MPI_STATUS_IGNORE, ierr)
 
@@ -296 +299 @@
 
    SUBROUTINE  PMC_Send_to_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
-      IMPLICIT     none
-      INTEGER, INTENT(IN)                       :: Client_id
-      REAL(kind=dp), DIMENSION(:), INTENT(IN)   :: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Client_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
+
+      IMPLICIT     none
+
+      INTEGER, INTENT(IN)                ::  Client_id
+      REAL(wp), DIMENSION(:), INTENT(IN) ::  buf
+      INTEGER, INTENT(IN)                ::  n
+      INTEGER, INTENT(IN)                ::  Client_rank
+      INTEGER, INTENT(IN)                ::  tag
+      INTEGER, INTENT(OUT)               ::  ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
          ierr)
 
@@ -312 +317 @@
 
    SUBROUTINE  PMC_Recv_from_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
-      IMPLICIT     none
-      INTEGER, INTENT(IN)                       :: Client_id
-      REAL(kind=dp), DIMENSION(:), INTENT(INOUT):: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Client_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
+
+      IMPLICIT     none
+
+      INTEGER, INTENT(IN)                   ::  Client_id
+      REAL(wp), DIMENSION(:), INTENT(INOUT) ::  buf
+      INTEGER, INTENT(IN)                   ::  n
+      INTEGER, INTENT(IN)                   ::  Client_rank
+      INTEGER, INTENT(IN)                   ::  tag
+      INTEGER, INTENT(OUT)                  ::  ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
          MPI_STATUS_IGNORE, ierr)
 
@@ -328 +335 @@
 
    SUBROUTINE  PMC_Send_to_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
-      IMPLICIT     none
-      INTEGER, INTENT(IN)                       :: Client_id
-      REAL(kind=dp), DIMENSION(:,:), INTENT(IN) :: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Client_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
+
+      IMPLICIT     none
+
+      INTEGER, INTENT(IN)                  ::  Client_id
+      REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf
+      INTEGER, INTENT(IN)                  ::  n
+      INTEGER, INTENT(IN)                  ::  Client_rank
+      INTEGER, INTENT(IN)                  ::  tag
+      INTEGER, INTENT(OUT)                 ::  ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
          ierr)
 
@@ -344 +353 @@
 
    SUBROUTINE  PMC_Recv_from_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
-      IMPLICIT     none
-      INTEGER, INTENT(IN)                       :: Client_id
-      REAL(kind=dp), DIMENSION(:,:), INTENT(OUT):: buf
-      INTEGER, INTENT(IN)                       :: n
-      INTEGER, INTENT(IN)                       :: Client_rank
-      INTEGER, INTENT(IN)                       :: tag
-      INTEGER, INTENT(OUT)                      :: ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
+
+      IMPLICIT     none
+
+      INTEGER, INTENT(IN)                   ::  Client_id
+      REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf
+      INTEGER, INTENT(IN)                   ::  n
+      INTEGER, INTENT(IN)                   ::  Client_rank
+      INTEGER, INTENT(IN)                   ::  tag
+      INTEGER, INTENT(OUT)                  ::  ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
          MPI_STATUS_IGNORE, ierr)
 
@@ -360 +371 @@
 
    SUBROUTINE  PMC_Send_to_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
-      IMPLICIT     none
-      INTEGER, INTENT(IN)                         :: Client_id
-      REAL(kind=dp), DIMENSION(:,:,:), INTENT(IN) :: buf
-      INTEGER, INTENT(IN)                         :: n
-      INTEGER, INTENT(IN)                         :: Client_rank
-      INTEGER, INTENT(IN)                         :: tag
-      INTEGER, INTENT(OUT)                        :: ierr
-
-      ierr = 0
-      CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
+
+      IMPLICIT     none
+
+      INTEGER, INTENT(IN)                    ::  Client_id
+      REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf
+      INTEGER, INTENT(IN)                    ::  n
+      INTEGER, INTENT(IN)                    ::  Client_rank
+      INTEGER, INTENT(IN)                    ::  tag
+      INTEGER, INTENT(OUT)                   ::  ierr
+
+      ierr = 0
+      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
          ierr)
 
@@ -376 +389 @@
 
    SUBROUTINE  PMC_Recv_from_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
-      IMPLICIT     none
-      INTEGER, INTENT(IN)                         :: Client_id
-      REAL(kind=dp), DIMENSION(:,:,:), INTENT(OUT):: buf
-      INTEGER, INTENT(IN)                         :: n
-      INTEGER, INTENT(IN)                         :: Client_rank
-      INTEGER, INTENT(IN)                         :: tag
-      INTEGER, INTENT(OUT)                        :: ierr
-
-      ierr = 0
-      CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
+
+      IMPLICIT     none
+
+      INTEGER, INTENT(IN)                     ::  Client_id
+      REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf
+      INTEGER, INTENT(IN)                     :: n
+      INTEGER, INTENT(IN)                     :: Client_rank
+      INTEGER, INTENT(IN)                     :: tag
+      INTEGER, INTENT(OUT)                    :: ierr
+
+      ierr = 0
+      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
          MPI_STATUS_IGNORE, ierr)
 

palm/trunk/SOURCE/pmc_server.f90

@@ -20 +20 @@
 ! Current revisions:
 ! ------------------
-!
+! kind=dp replaced by wp,
+! error messages removed or changed to PALM style, dim_order removed
+! array management changed from linked list to sequential loop
 !
 ! Former revisions:
@@ -52 +54 @@
    USE  kinds
    USE  PMC_general,               ONLY: ClientDef, PMC_MAX_MODELL,PMC_sort, DA_NameDef, DA_Desclen, DA_Namelen,       &
-                                         PMC_G_SetName, PMC_G_GetName, PeDef, ArrayDef
+                                         PMC_G_SetName, PeDef, ArrayDef, PMC_MAX_ARRAY
    USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_client_comm,                     &
                                          PMC_Server_for_Client, m_world_rank
@@ -70 +72 @@
    TYPE(ClientIndexDef),DIMENSION(PMC_MAX_MODELL)     :: indClients
 
+   INTEGER                                            :: next_array_in_list = 0
+
    PUBLIC PMC_Server_for_Client
-
-!-- TO_DO: what is the meaning of this? Could variables declared in this module
-!--        also have single precision?
-!   INTEGER, PARAMETER :: dp = wp
-
-   ! INTERFACE section
 
    INTERFACE PMC_ServerInit
@@ -85 +83 @@
         MODULE procedure PMC_S_Set_2D_index_list
     END INTERFACE PMC_S_Set_2D_index_list
+
+    INTERFACE PMC_S_clear_next_array_list
+        MODULE procedure PMC_S_clear_next_array_list
+    END INTERFACE PMC_S_clear_next_array_list
 
     INTERFACE PMC_S_GetNextArray
@@ -115 +117 @@
     PUBLIC PMC_ServerInit, PMC_S_Set_2D_index_list, PMC_S_GetNextArray, PMC_S_Set_DataArray
     PUBLIC PMC_S_setInd_and_AllocMem, PMC_S_FillBuffer, PMC_S_GetData_from_Buffer, PMC_S_Set_Active_data_array
+    PUBLIC PMC_S_clear_next_array_list
 
 CONTAINS
@@ -145 +148 @@
 
          ALLOCATE (Clients(ClientId)%PEs(Clients(ClientId)%inter_npes))
-
-         do j=1,Clients(ClientId)%inter_npes                                ! Loop over all client PEs
-           NULLIFY(Clients(ClientId)%PEs(j)%Arrays)
+!
+!--      Allocate for all client PEs an array of TYPE ArrayDef to store information of transfer array
+         do j=1,Clients(ClientId)%inter_npes
+           Allocate(Clients(ClientId)%PEs(j)%array_list(PMC_MAX_ARRAY))
          end do
 
@@ -219 +223 @@
     END SUBROUTINE PMC_S_Set_2D_index_list
 
-    logical function PMC_S_GetNextArray (ClientId, myName,Client_PeIndex)
+    SUBROUTINE PMC_S_clear_next_array_list
+       IMPLICIT none
+
+       next_array_in_list = 0
+
+       return
+    END SUBROUTINE PMC_S_clear_next_array_list
+
+!   List handling is still required to get minimal interaction with pmc_interface
+    logical function PMC_S_GetNextArray (ClientId, myName)
+       INTEGER(iwp),INTENT(IN)                    :: ClientId
+       CHARACTER(len=*),INTENT(OUT)               :: myName
+
+!--    local variables
+       TYPE(PeDef),POINTER          :: aPE
+       TYPE(ArrayDef),POINTER       :: ar
+
+       next_array_in_list = next_array_in_list+1
+
+!--    Array Names are the same on all client PE, so take first PE to get the name
+       aPE => Clients(ClientId)%PEs(1)
+
+       if(next_array_in_list > aPE%Nr_arrays) then
+          PMC_S_GetNextArray = .false.              ! all arrays done
+          return
+       end if
+
+       ar  => aPE%array_list(next_array_in_list)
+       myName = ar%name
+
+       PMC_S_GetNextArray =  .true.                 ! Return true if legal array
+       return
+    END function PMC_S_GetNextArray
+
+    SUBROUTINE PMC_S_Set_DataArray_2d (ClientId, array, array_2 )
+
+        IMPLICIT none
+
         INTEGER,INTENT(IN)                         :: ClientId
-        CHARACTER(len=*),INTENT(OUT)               :: myName
-
-        !-- local variables
-        INTEGER                      :: MyCoupleIndex
-        logical                      :: MyLast
-        CHARACTER(len=DA_Namelen)    :: loName
-        INTEGER,INTENT(IN),optional  :: Client_PeIndex
-
-        loName = ' '
-
-        CALL PMC_G_GetName (clients(ClientId), MyCoupleIndex, loName, MyLast, Client_PeIndex)
-
-        myName    = loName
-
-        PMC_S_GetNextArray = .NOT. MyLast                   ! Return true if valid array
-
-        return
-    END function PMC_S_GetNextArray
-
-    SUBROUTINE PMC_S_Set_DataArray_2d (ClientId, array, array_2 )
-        IMPLICIT none
-        INTEGER,INTENT(IN)                         :: ClientId
-!--   TO_DO: has array always to be of dp-kind, or can wp used here
-!--          this effects all respective declarations in this file
-        REAL(kind=dp),INTENT(IN),DIMENSION(:,:)           :: array
-        REAL(kind=dp),INTENT(IN),DIMENSION(:,:),OPTIONAL  :: array_2
-        !-- local variables
+        REAL(wp), INTENT(IN), DIMENSION(:,:)           ::  array
+        REAL(wp), INTENT(IN), DIMENSION(:,:), OPTIONAL ::  array_2
+
         INTEGER                           :: NrDims
         INTEGER,DIMENSION (4)             :: dims
-        INTEGER                           :: dim_order
         TYPE(c_ptr)                       :: array_adr
         TYPE(c_ptr)                       :: second_adr
@@ -259 +275 @@
         dims(1)   = size(array,1)
         dims(2)   = size(array,2)
-        dim_order = 2
-
         array_adr = c_loc(array)
 
         IF ( PRESENT( array_2 ) )  THEN
            second_adr = c_loc(array_2)
-           CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr, second_adr = second_adr)
+           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
         ELSE
-           CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr)
+           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
         ENDIF
 
@@ -274 +288 @@
 
     SUBROUTINE PMC_S_Set_DataArray_3d (ClientId, array, nz_cl, nz, array_2 )
+
         IMPLICIT none
+
         INTEGER,INTENT(IN)                         :: ClientId
-        REAL(kind=dp),INTENT(IN),DIMENSION(:,:,:)  :: array
-        REAL(kind=dp),INTENT(IN),DIMENSION(:,:,:),OPTIONAL  :: array_2
+        REAL(wp), INTENT(IN), DIMENSION(:,:,:)           ::  array
+        REAL(wp), INTENT(IN), DIMENSION(:,:,:), OPTIONAL ::  array_2
         INTEGER,INTENT(IN)                         :: nz_cl
         INTEGER,INTENT(IN)                         :: nz
-        !-- local variables
+
         INTEGER                           :: NrDims
         INTEGER,DIMENSION (4)             :: dims
-        INTEGER                           :: dim_order
         TYPE(c_ptr)                       :: array_adr
         TYPE(c_ptr)                       :: second_adr
@@ -294 +309 @@
         dims(2)   = size(array,2)
         dims(3)   = size(array,3)
-        dim_order = 33
         dims(4)   = nz_cl+dims(1)-nz                        ! works for first dimension 1:nz and 0:nz+1
 
@@ -304 +318 @@
         IF ( PRESENT( array_2 ) )  THEN
           second_adr = c_loc(array_2)
-          CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr, second_adr = second_adr)
+          CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
         ELSE
-           CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr)
+           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
         ENDIF
 
@@ -313 +327 @@
 
    SUBROUTINE PMC_S_setInd_and_AllocMem (ClientId)
+
+      USE control_parameters,                                                  &
+          ONLY:  message_string
+
       IMPLICIT none
+
       INTEGER,INTENT(IN)                      :: ClientId
 
-      INTEGER                                 :: i, istat, ierr
+      INTEGER                                 :: i, istat, ierr, j
       INTEGER                                 :: arlen, myIndex, tag
       INTEGER                                 :: rCount                    ! count MPI requests
@@ -337 +356 @@
          aPE => Clients(ClientId)%PEs(i)
          tag = 200
-         do while (PMC_S_GetNextArray ( ClientId, myName,i))
-            ar  => aPE%Arrays
-            if(ar%dim_order == 2) then
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
+            if(ar%NrDims == 2) then
                arlen     = aPE%NrEle;                             ! 2D
-            else if(ar%dim_order == 33) then
+            else if(ar%NrDims == 3) then
                arlen     = aPE%NrEle * ar%A_dim(4);               ! PALM 3D
             else
@@ -382 +401 @@
       do i=1,Clients(ClientId)%inter_npes
          aPE => Clients(ClientId)%PEs(i)
-         do while (PMC_S_GetNextArray ( ClientId, myName,i))
-            ar  => aPE%Arrays
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
 !--         TO_DO:  Adressrechnung ueberlegen?
             ar%SendBuf = c_loc(base_array(ar%BufIndex))                         !kk Adressrechnung ueberlegen
             if(ar%BufIndex+ar%BufSize > bufsize) then
 !--            TO_DO: can this error really happen, and what can be the reason?
-               write(0,'(a,i4,4i7,1x,a)') 'Buffer too small ',i,ar%BufIndex,ar%BufSize,ar%BufIndex+ar%BufSize,bufsize,trim(myName)
+               write(0,'(a,i4,4i7,1x,a)') 'Buffer too small ',i,ar%BufIndex,ar%BufSize,ar%BufIndex+ar%BufSize,bufsize,trim(ar%name)
                CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
             end if
@@ -399 +418 @@
    SUBROUTINE PMC_S_FillBuffer (ClientId, WaitTime)
       IMPLICIT none
-      INTEGER,INTENT(IN)                      :: ClientId
-      REAL(kind=dp),INTENT(OUT),optional      :: WaitTime
-
-      !-- local variables
-      INTEGER                                 :: ip,ij,istat,ierr
-      INTEGER                                 :: myIndex
-      REAL(kind=dp)                           :: t1,t2
-      TYPE(PeDef),POINTER                     :: aPE
-      TYPE(ArrayDef),POINTER                  :: ar
-      CHARACTER(len=DA_Namelen)               :: myName
-      INTEGER,DIMENSION(1)                    :: buf_shape
-      REAL(kind=wp),POINTER,DIMENSION(:)      :: buf
-      REAL(kind=wp),POINTER,DIMENSION(:,:)    :: data_2d
-      REAL(kind=wp),POINTER,DIMENSION(:,:,:)  :: data_3d
+      INTEGER,INTENT(IN)                  ::  ClientId
+      REAL(wp), INTENT(OUT), OPTIONAL     ::  WaitTime
+
+      INTEGER                             ::  ip,ij,istat,ierr,j
+      INTEGER                             ::  myIndex
+      REAL(wp)                            ::  t1,t2
+      TYPE(PeDef),POINTER                 ::  aPE
+      TYPE(ArrayDef),POINTER              ::  ar
+      CHARACTER(len=DA_Namelen)           ::  myName
+      INTEGER,DIMENSION(1)                ::  buf_shape
+      REAL(wp), POINTER, DIMENSION(:)     ::  buf
+      REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
+      REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
 
       t1 = PMC_Time()
@@ -421 +439 @@
       do ip=1,Clients(ClientId)%inter_npes
          aPE => Clients(ClientId)%PEs(ip)
-         do while (PMC_S_GetNextArray ( ClientId, myName,ip))
-            ar  => aPE%Arrays
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
             myIndex=1
-            if(ar%dim_order == 2) then
+            if(ar%NrDims == 2) then
                buf_shape(1) = aPE%NrEle
                CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
@@ -432 +450 @@
                   myIndex = myIndex+1
                end do
-            else if(ar%dim_order == 33) then
+            else if(ar%NrDims == 3) then
                buf_shape(1) = aPE%NrEle*ar%A_dim(4)
                CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
@@ -440 +458 @@
                   myIndex = myIndex+ar%A_dim(4)
                end do
-            else
-!--            TO_DO: can this error really happen, and what can be the reason?
-               write(0,*) "Illegal Order of Dimension ",ar%dim_order
-               CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr);
-
             end if
           end do
       end do
 
-      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)              ! buffer is full
+      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)    ! buffer is full
 
       return
@@ -455 +468 @@
 
    SUBROUTINE PMC_S_GetData_from_Buffer (ClientId, WaitTime)
+
       IMPLICIT none
-      INTEGER,INTENT(IN)                      :: ClientId
-      REAL(kind=dp),INTENT(OUT),optional      :: WaitTime
+
+      INTEGER,INTENT(IN)                  ::  ClientId
+      REAL(wp), INTENT(OUT), OPTIONAL     ::  WaitTime
 
       !-- local variables
-      INTEGER                                 :: ip,ij,istat,ierr
-      INTEGER                                 :: myIndex
-      REAL(kind=dp)                           :: t1,t2
-      TYPE(PeDef),POINTER                     :: aPE
-      TYPE(ArrayDef),POINTER                  :: ar
-      CHARACTER(len=DA_Namelen)               :: myName
-      INTEGER,DIMENSION(1)                    :: buf_shape
-      REAL(kind=wp),POINTER,DIMENSION(:)      :: buf
-      REAL(kind=wp),POINTER,DIMENSION(:,:)    :: data_2d
-      REAL(kind=wp),POINTER,DIMENSION(:,:,:)  :: data_3d
+      INTEGER                             ::  ip,ij,istat,ierr,j
+      INTEGER                             ::  myIndex
+      REAL(wp)                            ::  t1,t2
+      TYPE(PeDef),POINTER                 ::  aPE
+      TYPE(ArrayDef),POINTER              ::  ar
+      CHARACTER(len=DA_Namelen)           ::  myName
+      INTEGER,DIMENSION(1)                ::  buf_shape
+      REAL(wp), POINTER, DIMENSION(:)     ::  buf
+      REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
+      REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
 
       t1 = PMC_Time()
@@ -478 +493 @@
       do ip=1,Clients(ClientId)%inter_npes
          aPE => Clients(ClientId)%PEs(ip)
-         do while (PMC_S_GetNextArray ( ClientId, myName,ip))
-            ar  => aPE%Arrays
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
             myIndex=1
-            if(ar%dim_order == 2) then
+            if(ar%NrDims == 2) then
                buf_shape(1) = aPE%NrEle
                CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
@@ -489 +504 @@
                   myIndex = myIndex+1
                end do
-            else if(ar%dim_order == 33) then
+            else if(ar%NrDims == 3) then
                buf_shape(1) = aPE%NrEle*ar%A_dim(4)
                CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
@@ -497 +512 @@
                   myIndex = myIndex+ar%A_dim(4)
                end do
-            else
-!--            TO_DO: can this error really happen, and what can be the reason?
-               write(0,*) "Illegal Order of Dimension ",ar%dim_order
-               CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr);
-
             end if
           end do
@@ -535 +545 @@
    END SUBROUTINE Get_DA_names_from_client
 
-   SUBROUTINE PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr, second_adr)
+   SUBROUTINE PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr)
       IMPLICIT none
 
@@ -541 +551 @@
       INTEGER,INTENT(IN)                      :: NrDims
       INTEGER,INTENT(IN),DIMENSION(:)         :: dims
-      INTEGER,INTENT(IN)                      :: dim_order
       TYPE(c_ptr),INTENT(IN)                  :: array_adr
       TYPE(c_ptr),INTENT(IN),OPTIONAL         :: second_adr
@@ -554 +563 @@
        do i=1,Clients(ClientId)%inter_npes
           aPE => Clients(ClientId)%PEs(i)
-          ar  => aPE%Arrays
+          ar  => aPE%array_list(next_array_in_list)
           ar%NrDims    = NrDims
           ar%A_dim     = dims
-          ar%dim_order = dim_order
           ar%data      = array_adr
           if(present(second_adr)) then
@@ -579 +587 @@
 
 !--   local variables
-      INTEGER                                 :: i, ip
+      INTEGER                                 :: i, ip, j
       TYPE(PeDef),POINTER                     :: aPE
       TYPE(ArrayDef),POINTER                  :: ar
@@ -586 +594 @@
       do ip=1,Clients(ClientId)%inter_npes
          aPE => Clients(ClientId)%PEs(ip)
-         do while (PMC_S_GetNextArray ( ClientId, myName,ip))
-            ar  => aPE%Arrays
+         do j=1,aPE%Nr_arrays
+            ar  => aPE%array_list(j)
             if(iactive == 1 .OR. iactive == 2)   then
                ar%data = ar%po_data(iactive)