Changeset 1779


Ignore:
Timestamp:
Mar 3, 2016 8:01:28 AM (5 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:
15 edited

Legend:

Unmodified
Added
Removed
  • palm/trunk/SCRIPTS/mrun

    r1759 r1779  
    2222# Current revisions:
    2323# ------------------
    24 #
     24# test: implementing an execute mechanism where the execute command is given in the
     25# configuration file
     26# ROPTS removed from execution commands
     27# Warnings about missing optional files or user code changed to informative messages
    2528#
    2629# Former revisions:
     
    245248 exclude=""
    246249 executable=""
     250 execute_command="none"
    247251 execution_error=false
    248252 fftw_inc=""
     
    671675    while read line
    672676    do
    673        if [[ "$line" != ""  &&  $(echo $line | cut -c1) != "#" &&  $(echo $line | cut -d" " -s -f4) = $cond1 && $(echo $line | cut -d" " -s -f4)  = $cond2 ]]
     677       echo line=\"$line\"
     678       if [[ "$line" != ""  &&  $(echo $line | cut -c1) != "#" &&  $(echo $line | cut -d" " -s -f4) = $cond1 && $(echo $line | cut -d" " -s -f5)  = $cond2 ]]
    674679       then
    675680          coupled_mode="mpi2"
     
    15941599       if [[ ! -d $add_source_path ]]
    15951600       then
    1596           printf "\n\n  +++ WARNING: additional source code directory"
     1601          printf "\n\n  *** INFORMATIVE: additional source code directory"
    15971602          printf "\n      \"$add_source_path\" "
    15981603          printf "\n      does not exist or is not a directory."
     
    18931898
    18941899
    1895 
    18961900    # DETERMINE COMPILE- AND LINK-OPTIONS
    18971901 fopts="$fopts $netcdf_inc $fftw_inc $dvr_inc"
    18981902 lopts="$lopts $netcdf_lib $fftw_lib $dvr_lib"
    1899  ROPTS="$ropts"
    1900 # 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 ]]
    1901 # then
    1902     XOPT="-X $numprocs"
    1903 # fi
    1904 
     1903 XOPT="-X $numprocs"
    19051904
    19061905
     
    28752874          if [[ "${extin[$i]}" = ""  ||  "${extin[$i]}" = " " ]]
    28762875          then
    2877              printf "\n  +++ WARNING: input file \"${pathin[$i]}/${afname}${endin[$i]}\" "
    2878              printf "\n               is not available!"
     2876             printf "\n  *** INFORMATIVE: input file \"${pathin[$i]}/${afname}${endin[$i]}\" "
     2877             printf "\n                   is not available!"
    28792878          else
    2880              printf "\n  +++ WARNING: input file \"${pathin[$i]}/${afname}${endin[$i]}.${extin[$i]}\" "
    2881              printf "\n               is not available!"
     2879             printf "\n  *** INFORMATIVE: input file \"${pathin[$i]}/${afname}${endin[$i]}.${extin[$i]}\" "
     2880             printf "\n                   is not available!"
    28822881          fi
    28832882          continue
     
    32593258    PATH=$PATH:$TEMPDIR
    32603259
    3261        # MPI DEBUG OPTION (ARGUMENT CHECKING, SLOWS DOWN EXECUTION DUE TO INCREASED LATENCY)
    3262     if [[ "$mpi_debug" = true ]]
    3263     then
    3264        export MPI_CHECK_ARGS=1
    3265        printf "\n  +++ MPI_CHECK_ARGS=$MPI_CHECK_ARGS"
    3266     fi
    3267 
    3268     if [[ "$totalview" = true ]]
    3269     then
    3270        printf "\n *** totalview debugger will be used"
    3271        tv_opt="-tv"
     3260
     3261    if [[ $execute_command != "none" ]]
     3262    then
     3263
     3264        printf "\n  +++ branch still not realized"
     3265        locat=execution
     3266        exit
     3267
    32723268    else
    3273        tv_opt=""
    3274     fi
    3275 
    3276     if [[ "$cond1" = debug  ||  "$cond2" = debug ]]
    3277     then
    3278 
    3279           #Interactive ALLINEA DEBUG seesion
    3280        if [[ "$ENVIRONMENT" != BATCH ]]
    3281        then
    3282           if [[ $host = lccrayb || $host = lccrayh ]]
    3283           then
    3284              if [[ "$allinea" = true ]]
    3285              then
    3286                 echo "--- aprun  -n $ii  -N $tasks_per_node  a.out  $ROPTS  < runfile_atmos"
    3287 
    3288                 ddt  aprun  -n $ii  -N $tasks_per_node  a.out  $ROPTS 
    3289                 wait
    3290              fi         
    3291           fi
    3292        fi
    3293 
    3294        if [[ "$ENVIRONMENT" = BATCH ]]
    3295        then
    3296           continue
    3297        fi
    3298        if [[ $localhost = ibmh ]]
    3299        then
    3300 
    3301              # SETUP THE IBM MPI ENVIRONMENT
    3302           export MP_SHARED_MEMORY=yes
    3303           export AIXTHREADS_SCOPE=S
    3304           export OMP_NUM_THREADS=$threads_per_task
    3305           export AUTHSTATE=files
    3306           export XLFRTEOPTS="nlwidth=132:err_recovery=no"    # RECORD-LENGTH OF NAMELIST-OUTPUT
    3307 
    3308              # FOLLOWING OPTIONS ARE MANDATORY FOR TOTALVIEW
    3309           export MP_ADAPTER_USE=shared
    3310           export MP_CPU_USE=multiple
    3311           export MP_TIMEOUT=1200
    3312 
    3313           unset  MP_TASK_AFFINITY
    3314 
    3315              # SO FAR, TOTALVIEW NEEDS HOSTFILE MECHANISM FOR EXECUTION
    3316           #(( ii = 1 ))
    3317           #while (( ii <= $numprocs ))
    3318           #do
    3319           #   echo  $localhost_realname  >>  hostfile
    3320           #   (( ii = ii + 1 ))
    3321           #done
    3322           #export MP_HOSTFILE=hostfile
    3323 
    3324           if [[ "$LOADLBATCH" = yes ]]
    3325           then
    3326              totalview   poe  a.out  $ROPTS
    3327           else
    3328              echo totalview   poe  -a a.out  -procs $numprocs  -rmpool 0  -nodes 1   $ROPTS
    3329              export TVDSVRLAUNCHCMD=ssh
    3330              totalview   poe  -a a.out  -procs $numprocs  -rmpool 0  -nodes 1   $ROPTS
    3331           fi
    3332 
    3333        fi  # END DEBUG MODE
    3334 
    3335     else
    3336 
    3337           # NORMAL EXECUTION
    3338        if [[ -n $numprocs ]]
    3339        then
    3340 
    3341              # RUNNING THE PROGRAM ON PARALLEL MACHINES
    3342           if [[ $(echo $host | cut -c1-3) = ibm ]]
     3269
     3270          # MPI DEBUG OPTION (ARGUMENT CHECKING, SLOWS DOWN EXECUTION DUE TO INCREASED LATENCY)
     3271       if [[ "$mpi_debug" = true ]]
     3272       then
     3273          export MPI_CHECK_ARGS=1
     3274          printf "\n  +++ MPI_CHECK_ARGS=$MPI_CHECK_ARGS"
     3275       fi
     3276
     3277       if [[ "$totalview" = true ]]
     3278       then
     3279          printf "\n *** totalview debugger will be used"
     3280          tv_opt="-tv"
     3281       else
     3282          tv_opt=""
     3283       fi
     3284
     3285       if [[ "$cond1" = debug  ||  "$cond2" = debug ]]
     3286       then
     3287
     3288             #Interactive ALLINEA DEBUG seesion
     3289          if [[ "$ENVIRONMENT" != BATCH ]]
     3290          then
     3291             if [[ $host = lccrayb || $host = lccrayh ]]
     3292             then
     3293                if [[ "$allinea" = true ]]
     3294                then
     3295                   echo "--- aprun  -n $ii  -N $tasks_per_node  a.out  < runfile_atmos"
     3296
     3297                   ddt  aprun  -n $ii  -N $tasks_per_node  a.out
     3298                   wait
     3299                fi         
     3300             fi
     3301          fi
     3302
     3303          if [[ $localhost = ibmh ]]
    33433304          then
    33443305
    33453306                # SETUP THE IBM MPI ENVIRONMENT
    3346              if [[ $host != ibmh  &&  $host != ibmkisti ]]
    3347              then
    3348                 export MP_SHARED_MEMORY=yes
    3349                 export AIXTHREAD_SCOPE=S
    3350                 export OMP_NUM_THREADS=$threads_per_task
    3351                 export XLSMPOPTS="spins=0:yields=0:stack=20000000"
    3352                 export AUTHSTATE=files
    3353                 export XLFRTEOPTS="nlwidth=132:err_recovery=no"    # RECORD-LENGTH OF NAMELIST-OUTPUT
    3354                 #  export MP_PRINTENV=yes
    3355 
    3356                    # TUNING-VARIABLES TO IMPROVE COMMUNICATION SPEED
    3357                    # DO NOT SHOW SIGNIFICANT EFFECTS (SEP 04, FEDERATION-SWITCH)
    3358                 export MP_WAIT_MODE=poll
    3359                 [[ $node_usage = not_shared ]]  &&  export MP_SINGLE_THREAD=yes
     3307             export MP_SHARED_MEMORY=yes
     3308             export AIXTHREADS_SCOPE=S
     3309             export OMP_NUM_THREADS=$threads_per_task
     3310             export AUTHSTATE=files
     3311             export XLFRTEOPTS="nlwidth=132:err_recovery=no"    # RECORD-LENGTH OF NAMELIST-OUTPUT
     3312
     3313                # FOLLOWING OPTIONS ARE MANDATORY FOR TOTALVIEW
     3314             export MP_ADAPTER_USE=shared
     3315             export MP_CPU_USE=multiple
     3316             export MP_TIMEOUT=1200
     3317
     3318             unset  MP_TASK_AFFINITY
     3319
     3320             if [[ "$LOADLBATCH" = yes ]]
     3321             then
     3322                totalview   poe  a.out
     3323             else
     3324                echo totalview   poe  -a a.out  -procs $numprocs  -rmpool 0  -nodes 1
     3325                export TVDSVRLAUNCHCMD=ssh
     3326                totalview   poe  -a a.out  -procs $numprocs  -rmpool 0  -nodes 1
    33603327             fi
    33613328
    3362              if [[ $host = ibmkisti ]]
    3363              then
    3364                 export LANG=en_US
    3365                 export MP_SHARED_MEMORY=yes
    3366                 if [[ $threads_per_task = 1 ]]
     3329          fi  # END DEBUG MODE
     3330
     3331       else
     3332
     3333             # NORMAL EXECUTION
     3334          if [[ -n $numprocs ]]
     3335          then
     3336
     3337                # RUNNING THE PROGRAM ON PARALLEL MACHINES
     3338             if [[ $(echo $host | cut -c1-3) = ibm ]]
     3339             then
     3340
     3341                   # SETUP THE IBM MPI ENVIRONMENT
     3342                if [[ $host != ibmh  &&  $host != ibmkisti ]]
    33673343                then
    3368                    export MP_SINGLE_THREAD=yes
    3369                    export MEMORY_AFFINITY=MCM
     3344                   export MP_SHARED_MEMORY=yes
     3345                   export AIXTHREAD_SCOPE=S
     3346                   export OMP_NUM_THREADS=$threads_per_task
     3347                   export XLSMPOPTS="spins=0:yields=0:stack=20000000"
     3348                   export AUTHSTATE=files
     3349                   export XLFRTEOPTS="nlwidth=132:err_recovery=no"    # RECORD-LENGTH OF NAMELIST-OUTPUT
     3350                   #  export MP_PRINTENV=yes
     3351
     3352                      # TUNING-VARIABLES TO IMPROVE COMMUNICATION SPEED
     3353                      # DO NOT SHOW SIGNIFICANT EFFECTS (SEP 04, FEDERATION-SWITCH)
     3354                   export MP_WAIT_MODE=poll
     3355                   [[ $node_usage = not_shared ]]  &&  export MP_SINGLE_THREAD=yes
     3356                fi
     3357
     3358                if [[ $host = ibmkisti ]]
     3359                then
     3360                   export LANG=en_US
     3361                   export MP_SHARED_MEMORY=yes
     3362                   if [[ $threads_per_task = 1 ]]
     3363                   then
     3364                      export MP_SINGLE_THREAD=yes
     3365                      export MEMORY_AFFINITY=MCM
     3366                   else
     3367                      export OMP_NUM_THREADS=$threads_per_task
     3368                   fi
     3369                fi
     3370
     3371                if [[ "$LOADLBATCH" = yes ]]
     3372                then
     3373                   printf "\n--- Control: OMP_NUM_THREADS = \"$OMP_NUM_THREADS\" \n"
     3374                   if [[ "$cond1" = hpmcount  ||  "$cond2" = hpmcount ]]
     3375                   then
     3376                      /opt/optibm/HPM_2_4_1/bin/hpmcount  a.out
     3377                   else
     3378                      if [[ $run_coupled_model = false ]]
     3379                      then
     3380                         if [[ "$ocean_file_appendix" = true ]]
     3381                         then
     3382                            echo "precursor_ocean"  >  runfile_atmos
     3383                         else
     3384                            echo "precursor_atmos"  >  runfile_atmos
     3385                         fi
     3386                      else
     3387                         (( iia = $numprocs_atmos / $threads_per_task ))
     3388                         (( iio = $numprocs_ocean / $threads_per_task ))
     3389                         printf "\n      coupled run ($iia atmosphere, $iio ocean)"
     3390                         printf "\n      using $coupled_mode coupling"
     3391                         printf "\n\n"
     3392                         echo "coupled_run $iia $iio"  >  runfile_atmos
     3393                      fi
     3394                      poe ./a.out  <  runfile_atmos
     3395                   fi
    33703396                else
    3371                    export OMP_NUM_THREADS=$threads_per_task
     3397                   if [[ $localhost = ibmh  ||  $localhost = ibms ]]
     3398                   then
     3399                      poe  a.out  -procs $numprocs  -nodes 1  -rmpool 0
     3400                   elif [[ $localhost = ibmkisti  ||  $localhost = ibmku ]]
     3401                   then
     3402                      if [[ -f $hostfile ]]
     3403                      then
     3404                         cp  $hostfile  hostfile
     3405                      else
     3406                         (( ii = 1 ))
     3407                         while (( ii <= $numprocs ))
     3408                         do
     3409                            echo  $localhost_realname  >>  hostfile
     3410                            (( ii = ii + 1 ))
     3411                         done
     3412                      fi
     3413                      export MP_HOSTFILE=hostfile
     3414                      if [[ $run_coupled_model = false ]]
     3415                      then
     3416                         if [[ "$ocean_file_appendix" = true ]]
     3417                         then
     3418                            echo "precursor_ocean"  >  runfile_atmos
     3419                         else
     3420                            echo "precursor_atmos"  >  runfile_atmos
     3421                         fi
     3422                      else
     3423                         (( iia = $numprocs_atmos / $threads_per_task ))
     3424                         (( iio = $numprocs_ocean / $threads_per_task ))
     3425                         printf "\n      coupled run ($iia atmosphere, $iio ocean)"
     3426                         printf "\n      using $coupled_mode coupling"
     3427                         printf "\n\n"
     3428                         echo "coupled_run $iia $iio"  >  runfile_atmos
     3429                      fi
     3430
     3431                      poe  ./a.out  -procs $numprocs  <  runfile_atmos
     3432
     3433                   else
     3434                      if [[ "$host_file" = "" ]]
     3435                      then
     3436                         printf "\n  +++ no hostfile given in configuration file"
     3437                         locat=config_file
     3438                         exit
     3439                      else
     3440                         eval host_file=$host_file
     3441                      fi
     3442                      export MP_HOSTFILE=$host_file
     3443                      poe  a.out  -procs $numprocs  -tasks_per_node $numprocs
     3444                   fi
    33723445                fi
    3373              fi
    3374 
    3375              if [[ "$LOADLBATCH" = yes ]]
    3376              then
    3377                 printf "\n--- Control: OMP_NUM_THREADS = \"$OMP_NUM_THREADS\" \n"
    3378                 if [[ "$cond1" = hpmcount  ||  "$cond2" = hpmcount ]]
     3446
     3447             elif [[ $host = nech ]]  # running on NEC machines
     3448             then
     3449
     3450                (( ii = nodes ))
     3451                if [[ $ii = 1 ]]
    33793452                then
    3380                    /opt/optibm/HPM_2_4_1/bin/hpmcount  a.out  $ROPTS
     3453                   export F_ERRCNT=0        # acceptable number of errors before program is stopped
     3454                   export MPIPROGINF=YES
     3455                   #  export F_TRACE=YES|FMT1|FMT2  # output of ftrace informations to job protocol
     3456                   echo "*** execution on single node with mpirun"
     3457                   mpirun  -np $numprocs  ./a.out
    33813458                else
    3382                    if [[ $run_coupled_model = false ]]
    3383                    then
    3384                       if [[ "$ocean_file_appendix" = true ]]
    3385                       then
    3386                          echo "precursor_ocean"  >  runfile_atmos
    3387                       else
    3388                          echo "precursor_atmos"  >  runfile_atmos
    3389                       fi
    3390                    else
    3391                       (( iia = $numprocs_atmos / $threads_per_task ))
    3392                       (( iio = $numprocs_ocean / $threads_per_task ))
    3393                       printf "\n      coupled run ($iia atmosphere, $iio ocean)"
    3394                       printf "\n      using $coupled_mode coupling"
    3395                       printf "\n\n"
    3396                       echo "coupled_run $iia $iio"  >  runfile_atmos
    3397                    fi
    3398                    poe ./a.out  $ROPTS  <  runfile_atmos
     3459                   (( i = 0 ))
     3460                   while (( i < ii ))
     3461                   do
     3462                      echo "-h $i  -p $tasks_per_node  -e ./mpi_exec_shell"  >>  multinode_config
     3463                      (( i = i + 1 ))
     3464                   done
     3465
     3466                   echo "#!/bin/sh"                         >   mpi_exec_shell
     3467                   echo " "                                 >>  mpi_exec_shell
     3468                   echo "set -u"                            >>  mpi_exec_shell
     3469                   echo "F_ERRCNT=0"                        >>  mpi_exec_shell
     3470                   echo "MPIPROGINV=YES"                    >>  mpi_exec_shell
     3471                   echo "OMP_NUM_THREADS=$threads_per_task" >>  mpi_exec_shell
     3472                   echo "cpurest=$cpurest"                  >>  mpi_exec_shell
     3473                   echo "fname=$fname"                      >>  mpi_exec_shell
     3474                   echo "localhost=$localhost"              >>  mpi_exec_shell
     3475                   echo "return_address=$return_address"    >>  mpi_exec_shell
     3476                   echo "return_username=$return_username"  >>  mpi_exec_shell
     3477                   echo "tasks_per_node=$tasks_per_node"    >>  mpi_exec_shell
     3478                   echo "write_binary=$write_binary"        >>  mpi_exec_shell
     3479                   echo "use_seperate_pe_for_dvrp_output=$use_seperate_pe_for_dvrp_output"  >>  mpi_exec_shell
     3480                   echo "  "                                >>  mpi_exec_shell
     3481                   echo "export F_ERRCNT"                   >>  mpi_exec_shell
     3482                   echo "export MPIPROGINV"                 >>  mpi_exec_shell
     3483                   echo "export OMP_NUM_THREADS"            >>  mpi_exec_shell
     3484                   echo "export cpurest"                    >>  mpi_exec_shell
     3485                   echo "export fname"                      >>  mpi_exec_shell
     3486                   echo "export localhost"                  >>  mpi_exec_shell
     3487                   echo "export return_address"             >>  mpi_exec_shell
     3488                   echo "export return_username"            >>  mpi_exec_shell
     3489                   echo "export tasks_per_node"             >>  mpi_exec_shell
     3490                   echo "export write_binary"               >>  mpi_exec_shell
     3491                   echo "export use_seperate_pe_for_dvrp_output"  >>  mpi_exec_shell
     3492                   echo " "                                 >>  mpi_exec_shell
     3493                   echo "exec  ./a.out"                     >>  mpi_exec_shell
     3494
     3495                   chmod u+x  mpi_exec_shell
     3496                   export MPIPROGINF=YES
     3497                   mpirun  -f multinode_config  &
     3498                   wait
     3499
    33993500                fi
    3400              else
    3401                 if [[ $localhost = ibmh  ||  $localhost = ibms ]]
    3402                 then
    3403                    poe  a.out  -procs $numprocs  -nodes 1  -rmpool 0  $ROPTS
    3404                 elif [[ $localhost = ibmkisti  ||  $localhost = ibmku ]]
     3501
     3502             elif [[ $(echo $host | cut -c1-2) = lc  &&  $host != lckyoto &&  $host != lctit ]]
     3503             then
     3504
     3505                   # COPY HOSTFILE FROM SOURCE DIRECTORY OR CREATE IT, IF IT
     3506                   # DOES NOT EXIST
     3507                if [[  $host != lcbullhh  && $host != lccrayb  &&  $host != lccrayf  && $host != lccrayh  &&  $host != lckyuh  &&  $host != lckyut ]]
    34053508                then
    34063509                   if [[ -f $hostfile ]]
    34073510                   then
    34083511                      cp  $hostfile  hostfile
     3512                      (( ii = $numprocs / $threads_per_task ))
     3513                      [[ $ii = 0 ]]  &&  (( ii = 1 ))
    34093514                   else
    34103515                      (( ii = 1 ))
    3411                       while (( ii <= $numprocs ))
     3516                      while (( ii <= $numprocs / $threads_per_task ))
    34123517                      do
    34133518                         echo  $localhost_realname  >>  hostfile
    34143519                         (( ii = ii + 1 ))
    34153520                      done
     3521                      if (( $numprocs / $threads_per_task == 0 ))
     3522                      then
     3523                         echo  $localhost_realname  >>  hostfile
     3524                      fi
    34163525                   fi
    3417                    export MP_HOSTFILE=hostfile
    3418                    if [[ $run_coupled_model = false ]]
     3526                   eval zeile=\"`head -n $ii  hostfile`\"
     3527                   printf "\n  *** running on: $zeile"
     3528                fi
     3529
     3530                (( ii = $numprocs / $threads_per_task ))
     3531                [[ $ii = 0 ]]  &&  (( ii = 1 ))
     3532                export OMP_NUM_THREADS=$threads_per_task
     3533
     3534                if [[ $threads_per_task != 1 ]]
     3535                then
     3536                      # INCREASE STACK SIZE TO UNLIMITED, BECAUSE OTHERWISE LARGE RUNS
     3537                      # MAY ABORT
     3538                   ulimit -s unlimited
     3539                   printf "\n      threads per task: $threads_per_task  stacksize: unlimited"
     3540                fi
     3541                if [[ $run_coupled_model = false ]]
     3542                then
     3543                   if [[ "$ocean_file_appendix" = true ]]
    34193544                   then
    3420                       if [[ "$ocean_file_appendix" = true ]]
     3545                      echo "precursor_ocean"  >  runfile_atmos
     3546                   else
     3547                      echo "precursor_atmos"  >  runfile_atmos
     3548                   fi
     3549                   printf "\n\n"
     3550
     3551                   if [[ $host = lccrayb || $host = lccrayh ]]
     3552                   then
     3553                       echo "--- aprun  -n $ii  -N $tasks_per_node  a.out  <  runfile_atmos"
     3554                       aprun  -n $ii  -N $tasks_per_node  a.out  <  runfile_atmos
     3555                   elif [[ $host = lcbullhh ]]
     3556                   then
     3557                      export OMPI_MCA_pml=cm
     3558                      export OMPI_MCA_mtl=mxm
     3559                      export OMPI_MCA_coll=^ghc
     3560                      export OMPI_MCA_mtl_mxm_np=0
     3561                      export MXM_RDMA_PORTS=mlx5_0:1
     3562                      export MXM_LOG_LEVEL=ERROR
     3563                      export OMP_NUM_THREADS=$threads_per_task
     3564                      export KMP_AFFINITY=verbose,granularity=core,compact,1
     3565                      export KMP_STACKSIZE=64m
     3566
     3567                      srun  --nodes=$nodes --ntasks-per-node=$tasks_per_node ./a.out  <  runfile_atmos
     3568
     3569                   elif [[ $host = lccrayf ]]
     3570                   then
     3571                       aprun  -j1  -n $ii  -N $tasks_per_node  -m ${memory}M  a.out  <  runfile_atmos
     3572                   elif [[ $host = lcxe6  ||  $host = lcxt5m ]]
     3573                   then
     3574                       aprun  -n $ii  -N $tasks_per_node  a.out  <  runfile_atmos
     3575                   elif [[ $host = lcflow ]]
     3576                   then
     3577                      mpirun -np $ii a.out  < runfile_atmos
     3578                   elif [[ $host = lcsb ]]
     3579                   then
     3580                      mpirun_rsh -hostfile $PBS_NODEFILE -np `cat $PBS_NODEFILE | wc -l` a.out  < runfile_atmos
     3581                   elif [[ $host = lckiaps ]]
     3582                   then
     3583                      mpirun -np $ii  -f $PBS_NODEFILE  a.out  <  runfile_atmos
     3584                   elif [[ $host = lckyu* ]]
     3585                   then
     3586                      mpiexec -n $ii --stdin runfile_atmos  ./a.out
     3587                   else
     3588                      mpiexec  -machinefile hostfile  -n $ii  a.out  <  runfile_atmos
     3589                   fi
     3590
     3591                else
     3592
     3593                       # CURRENTLY THERE IS NO FULL MPI-2 SUPPORT ON ICE AND XT4
     3594                   (( iia = $numprocs_atmos / $threads_per_task ))
     3595                   (( iio = $numprocs_ocean / $threads_per_task ))
     3596                   printf "\n      coupled run ($iia atmosphere, $iio ocean)"
     3597                   printf "\n      using $coupled_mode coupling"
     3598                   printf "\n\n"
     3599
     3600                   if [[ $coupled_mode = "mpi2" ]]
     3601                   then
     3602                      echo "atmosphere_to_ocean $iia $iio"  >  runfile_atmos
     3603                      echo "ocean_to_atmosphere $iia $iio"  >  runfile_ocean
     3604
     3605                      if [[ $host = lccrayf  ||  $host = lcxe6  ||  $host = lcxt5m ]]
    34213606                      then
    3422                          echo "precursor_ocean"  >  runfile_atmos
     3607
     3608                         aprun  -n $iia  -N $tasks_per_node  a.out < runfile_atmos  &
     3609                         aprun  -n $iio  -N $tasks_per_node  a.out < runfile_ocean  &
     3610
    34233611                      else
    3424                          echo "precursor_atmos"  >  runfile_atmos
     3612                             # WORKAROUND BECAUSE mpiexec WITH -env option IS NOT AVAILABLE ON SOME SYSTEMS
     3613                          mpiexec  -machinefile hostfile  -n $iia  a.out  <  runfile_atmos &
     3614                          mpiexec  -machinefile hostfile  -n $iio  a.out  <  runfile_ocean &
     3615#                          mpiexec  -machinefile hostfile  -n $iia  -env coupling_mode atmosphere_to_ocean  a.out  &
     3616#                          mpiexec  -machinefile hostfile  -n $iio  -env coupling_mode ocean_to_atmosphere  a.out  &
    34253617                      fi
     3618                      wait
     3619
    34263620                   else
    3427                       (( iia = $numprocs_atmos / $threads_per_task ))
    3428                       (( iio = $numprocs_ocean / $threads_per_task ))
    3429                       printf "\n      coupled run ($iia atmosphere, $iio ocean)"
    3430                       printf "\n      using $coupled_mode coupling"
    3431                       printf "\n\n"
     3621
    34323622                      echo "coupled_run $iia $iio"  >  runfile_atmos
     3623
     3624                      if [[ $host = lccrayf  ||  $host = lcxe6  ||  $host = lcxt5m ]]
     3625                      then
     3626
     3627                         aprun  -n $ii  -N $tasks_per_node  a.out < runfile_atmos
     3628
     3629                      elif [[ $host = lck || $host = lckordi ]]
     3630                      then
     3631
     3632                         mpiexec -n $ii  ./a.out  <  runfile_atmos  &
     3633
     3634                      elif [[ $host = lckyu* ]]
     3635                      then
     3636
     3637                         mpiexec -n $ii --stdin runfile_atmos  ./a.out
     3638
     3639                      elif [[ $host = lcmuk ]]
     3640                      then
     3641
     3642                         mpiexec  -machinefile hostfile  -n $ii  a.out  <  runfile_atmos
     3643
     3644                      fi
     3645                      wait
    34333646                   fi
    34343647
    3435                    poe  ./a.out  -procs $numprocs $ROPTS  <  runfile_atmos
    3436 
     3648                fi
     3649
     3650             elif [[ $host = lckyoto ]]
     3651             then
     3652                set -xv
     3653                export P4_RSHCOMMAND=plesh
     3654                echo "     P4_RSHCOMMAND = $P4_RSHCOMMAND"
     3655                if [[ "$ENVIRONMENT" = BATCH ]]
     3656                then
     3657                   if [[ "$cond2" = fujitsu ]]
     3658                   then
     3659                      mpiexec  -n $numprocs  ./a.out  # for fujitsu-compiler
     3660                   elif [[ "cond2" = pgi ]]
     3661                   then
     3662                      mpirun  -np $numprocs  -machinefile ${QSUB_NODEINF}  ./a.out
     3663                   else
     3664                      mpirun_rsh -np $numprocs -hostfile ${QSUB_NODEINF} MV2_USE_SRQ=0 ./a.out  ||  /bin/true
     3665                   fi
    34373666                else
    3438                    if [[ "$host_file" = "" ]]
     3667                   if [[ "$cond2" = "" ]]
    34393668                   then
    3440                       printf "\n  +++ no hostfile given in configuration file"
    3441                       locat=config_file
    3442                       exit
     3669                      mpiruni_rsh -np $numprocs ./a.out  # for intel
    34433670                   else
    3444                       eval host_file=$host_file
    3445                    fi
    3446                    export MP_HOSTFILE=$host_file
    3447                    poe  a.out  -procs $numprocs  -tasks_per_node $numprocs  $ROPTS
    3448                 fi
    3449              fi
    3450           elif [[ $host = nech ]]
    3451           then
    3452              (( ii = nodes ))
    3453              if [[ $ii = 1 ]]
    3454              then
    3455                 export F_ERRCNT=0        # acceptable number of errors before program is stopped
    3456                 export MPIPROGINF=YES
    3457                 #  export F_TRACE=YES|FMT1|FMT2  # output of ftrace informations to job protocol
    3458                 echo "*** execution on single node with mpirun"
    3459                 mpirun  -np $numprocs  ./a.out  $ROPTS
    3460              else
    3461                 (( i = 0 ))
    3462                 while (( i < ii ))
    3463                 do
    3464                    echo "-h $i  -p $tasks_per_node  -e ./mpi_exec_shell"  >>  multinode_config
    3465                    (( i = i + 1 ))
    3466                 done
    3467 
    3468                 echo "#!/bin/sh"                         >   mpi_exec_shell
    3469                 echo " "                                 >>  mpi_exec_shell
    3470                 echo "set -u"                            >>  mpi_exec_shell
    3471                 echo "F_ERRCNT=0"                        >>  mpi_exec_shell
    3472                 echo "MPIPROGINV=YES"                    >>  mpi_exec_shell
    3473                 echo "OMP_NUM_THREADS=$threads_per_task" >>  mpi_exec_shell
    3474                 echo "cpurest=$cpurest"                  >>  mpi_exec_shell
    3475                 echo "fname=$fname"                      >>  mpi_exec_shell
    3476                 echo "localhost=$localhost"              >>  mpi_exec_shell
    3477                 echo "return_address=$return_address"    >>  mpi_exec_shell
    3478                 echo "return_username=$return_username"  >>  mpi_exec_shell
    3479                 echo "tasks_per_node=$tasks_per_node"    >>  mpi_exec_shell
    3480                 echo "write_binary=$write_binary"        >>  mpi_exec_shell
    3481                 echo "use_seperate_pe_for_dvrp_output=$use_seperate_pe_for_dvrp_output"  >>  mpi_exec_shell
    3482                 echo "  "                                >>  mpi_exec_shell
    3483                 echo "export F_ERRCNT"                   >>  mpi_exec_shell
    3484                 echo "export MPIPROGINV"                 >>  mpi_exec_shell
    3485                 echo "export OMP_NUM_THREADS"            >>  mpi_exec_shell
    3486                 echo "export cpurest"                    >>  mpi_exec_shell
    3487                 echo "export fname"                      >>  mpi_exec_shell
    3488                 echo "export localhost"                  >>  mpi_exec_shell
    3489                 echo "export return_address"             >>  mpi_exec_shell
    3490                 echo "export return_username"            >>  mpi_exec_shell
    3491                 echo "export tasks_per_node"             >>  mpi_exec_shell
    3492                 echo "export write_binary"               >>  mpi_exec_shell
    3493                 echo "export use_seperate_pe_for_dvrp_output"  >>  mpi_exec_shell
    3494                 echo " "                                 >>  mpi_exec_shell
    3495                 echo "exec  ./a.out"                     >>  mpi_exec_shell
    3496 
    3497                 chmod u+x  mpi_exec_shell
    3498                 export MPIPROGINF=YES
    3499                 mpirun  -f multinode_config  &
    3500                 wait
    3501 
    3502              fi
    3503           elif [[ $(echo $host | cut -c1-2) = lc  &&  $host != lckyoto &&  $host != lctit ]]
    3504           then
    3505 
    3506                 # COPY HOSTFILE FROM SOURCE DIRECTORY OR CREATE IT, IF IT
    3507                 # DOES NOT EXIST
    3508              if [[  $host != lcbullhh  && $host != lccrayb  &&  $host != lccrayf  && $host != lccrayh  &&  $host != lckyuh  &&  $host != lckyut ]]
    3509 
    3510              then
    3511                 if [[ -f $hostfile ]]
    3512                 then
    3513                    cp  $hostfile  hostfile
    3514                    (( ii = $numprocs / $threads_per_task ))
    3515                    [[ $ii = 0 ]]  &&  (( ii = 1 ))
    3516                 else
    3517                    (( ii = 1 ))
    3518                    while (( ii <= $numprocs / $threads_per_task ))
    3519                    do
    3520                       echo  $localhost_realname  >>  hostfile
    3521                       (( ii = ii + 1 ))
    3522                    done
    3523                    if (( $numprocs / $threads_per_task == 0 ))
    3524                    then
    3525                       echo  $localhost_realname  >>  hostfile
     3671                      mpirun  -np $numprocs  ./a.out
    35263672                   fi
    35273673                fi
    3528                 eval zeile=\"`head -n $ii  hostfile`\"
    3529                 printf "\n  *** running on: $zeile"
     3674                set +xv
     3675
     3676             elif [[ $host = lctit ]]
     3677             then
     3678                export OMP_NUM_THREADS=$threads_per_task
     3679                echo "OMP_NUM_THREADS=$OMP_NUM_THREADS"
     3680                if [[ "$threads_per_task" != 1 ]]
     3681                then
     3682                   export MV2_ENABLE_AFFINITY=0
     3683                fi
     3684                echo "----- PBS_NODEFILE content:"
     3685                cat $PBS_NODEFILE
     3686                echo "-----"
     3687                (( ii = $numprocs / $threads_per_task ))
     3688                echo "mpirun  -np $ii  -hostfile $PBS_NODEFILE ./a.out"
     3689                mpirun  -np $ii  -hostfile $PBS_NODEFILE  ./a.out
     3690
     3691             else
     3692                mpprun  -n $numprocs  a.out
    35303693             fi
    3531 
    3532              (( ii = $numprocs / $threads_per_task ))
    3533              [[ $ii = 0 ]]  &&  (( ii = 1 ))
    3534              export OMP_NUM_THREADS=$threads_per_task
    3535 
    3536              if [[ $threads_per_task != 1 ]]
    3537              then
    3538                    # INCREASE STACK SIZE TO UNLIMITED, BECAUSE OTHERWISE LARGE RUNS
    3539                    # MAY ABORT
    3540                 ulimit -s unlimited
    3541                 printf "\n      threads per task: $threads_per_task  stacksize: unlimited"
    3542              fi
    3543              if [[ $run_coupled_model = false ]]
    3544              then
    3545                 if [[ "$ocean_file_appendix" = true ]]
    3546                 then
    3547                    echo "precursor_ocean"  >  runfile_atmos
    3548                 else
    3549                    echo "precursor_atmos"  >  runfile_atmos
    3550                 fi
    3551                 printf "\n\n"
    3552 
    3553                 if [[ $host = lccrayb || $host = lccrayh ]]
    3554                 then
    3555                     echo "--- aprun  -n $ii  -N $tasks_per_node  a.out  $ROPTS  < runfile_atmos"
    3556                     aprun  -n $ii  -N $tasks_per_node  a.out  $ROPTS  < runfile_atmos
    3557 #                    aprun  -n $ii  -ss  -r2  -j1  a.out  $ROPTS  < runfile_atmos
    3558 
    3559                 elif [[ $host = lcbullhh ]]
    3560                 then
    3561                    export OMPI_MCA_pml=cm
    3562                    export OMPI_MCA_mtl=mxm
    3563                    export OMPI_MCA_coll=^ghc
    3564                    export OMPI_MCA_mtl_mxm_np=0
    3565                    export MXM_RDMA_PORTS=mlx5_0:1
    3566                    export MXM_LOG_LEVEL=ERROR
    3567                    export OMP_NUM_THREADS=$threads_per_task
    3568                    export KMP_AFFINITY=verbose,granularity=core,compact,1
    3569                    export KMP_STACKSIZE=64m
    3570 
    3571                    srun  --nodes=$nodes --ntasks-per-node=$tasks_per_node ./a.out 
    3572 
    3573                 elif [[ $host = lccrayf ]]
    3574                 then
    3575                     aprun  -j1  -n $ii  -N $tasks_per_node  -m ${memory}M  a.out  $ROPTS  < runfile_atmos
    3576                 elif [[ $host = lcxe6  ||  $host = lcxt5m ]]
    3577                 then
    3578                     aprun  -n $ii  -N $tasks_per_node  a.out  $ROPTS  < runfile_atmos
    3579                 elif [[ $host = lcflow ]]
    3580                 then
    3581                    mpirun -np $ii a.out  < runfile_atmos  $ROPTS
    3582                 elif [[ $host = lcsb ]]
    3583                 then
    3584                    mpirun_rsh -hostfile $PBS_NODEFILE -np `cat $PBS_NODEFILE | wc -l` a.out  < runfile_atmos  $ROPTS
    3585                 elif [[ $host = lckiaps ]]
    3586                 then
    3587                    mpirun -np $ii  -f $PBS_NODEFILE  a.out  <  runfile_atmos  $ROPTS
    3588                 elif [[ $host = lckyu* ]]
    3589                 then
    3590                    mpiexec -n $ii --stdin runfile_atmos  ./a.out  $ROPTS
    3591                 else
    3592                    mpiexec  -machinefile hostfile  -n $ii  a.out  <  runfile_atmos  $ROPTS
    3593                 fi
    3594              else
    3595 
    3596                     # CURRENTLY THERE IS NO FULL MPI-2 SUPPORT ON ICE AND XT4
    3597                 (( iia = $numprocs_atmos / $threads_per_task ))
    3598                 (( iio = $numprocs_ocean / $threads_per_task ))
    3599                 printf "\n      coupled run ($iia atmosphere, $iio ocean)"
    3600                 printf "\n      using $coupled_mode coupling"
    3601                 printf "\n\n"
    3602 
    3603                 if [[ $coupled_mode = "mpi2" ]]
    3604                 then
    3605                    echo "atmosphere_to_ocean $iia $iio"  >  runfile_atmos
    3606                    echo "ocean_to_atmosphere $iia $iio"  >  runfile_ocean
    3607 
    3608                    if [[ $host = lccrayf  ||  $host = lcxe6  ||  $host = lcxt5m ]]
    3609                    then
    3610 
    3611                       aprun  -n $iia  -N $tasks_per_node  a.out < runfile_atmos  $ROPTS  &
    3612                       aprun  -n $iio  -N $tasks_per_node  a.out < runfile_ocean  $ROPTS  &
    3613 
    3614                    else
    3615                           # WORKAROUND BECAUSE mpiexec WITH -env option IS NOT AVAILABLE ON SOME SYSTEMS
    3616                        mpiexec  -machinefile hostfile  -n $iia  a.out  $ROPTS  <  runfile_atmos &
    3617                        mpiexec  -machinefile hostfile  -n $iio  a.out  $ROPTS  <  runfile_ocean &
    3618 #                       mpiexec  -machinefile hostfile  -n $iia  -env coupling_mode atmosphere_to_ocean  a.out  $ROPTS  &
    3619 #                       mpiexec  -machinefile hostfile  -n $iio  -env coupling_mode ocean_to_atmosphere  a.out  $ROPTS  &
    3620                    fi
    3621                    wait
    3622 
    3623                 else
    3624 
    3625                    echo "coupled_run $iia $iio"  >  runfile_atmos
    3626 
    3627                    if [[ $host = lccrayf  ||  $host = lcxe6  ||  $host = lcxt5m ]]
    3628                    then
    3629 
    3630                       aprun  -n $ii  -N $tasks_per_node  a.out < runfile_atmos  $ROPTS
    3631 
    3632                    elif [[ $host = lck || $host = lckordi ]]
    3633                    then
    3634 
    3635                       mpiexec -n $ii  ./a.out  $ROPTS < runfile_atmos &
    3636 
    3637                    elif [[ $host = lckyu* ]]
    3638                    then
    3639 
    3640                       mpiexec -n $ii --stdin runfile_atmos  ./a.out  $ROPTS
    3641 
    3642                    elif [[ $host = lcmuk ]]
    3643                    then
    3644 
    3645                       mpiexec  -machinefile hostfile  -n $ii  a.out  <  runfile_atmos  $ROPTS
    3646 
    3647                    fi
    3648                    wait
    3649                 fi
    3650 
    3651              fi
    3652 
    3653           elif [[ $host = lckyoto ]]
    3654           then
    3655              set -xv
    3656              export P4_RSHCOMMAND=plesh
    3657              echo "     P4_RSHCOMMAND = $P4_RSHCOMMAND"
    3658              if [[ "$ENVIRONMENT" = BATCH ]]
    3659              then
    3660                 if [[ "$cond2" = fujitsu ]]
    3661                 then
    3662                    mpiexec  -n $numprocs  ./a.out  $ROPTS  # for fujitsu-compiler
    3663                 elif [[ "cond2" = pgi ]]
    3664                 then
    3665                    mpirun  -np $numprocs  -machinefile ${QSUB_NODEINF}  ./a.out  $ROPTS
    3666                 else
    3667                    mpirun_rsh -np $numprocs -hostfile ${QSUB_NODEINF} MV2_USE_SRQ=0 ./a.out ${ROPTS} || /bin/true
    3668                 fi
    3669              else
    3670                 if [[ "$cond2" = "" ]]
    3671                 then
    3672                    mpiruni_rsh -np $numprocs ./a.out  $ROPTS  # for intel
    3673                 else
    3674                    mpirun  -np $numprocs  ./a.out  $ROPTS
    3675                 fi
    3676              fi
    3677              set +xv
    3678 
    3679           elif [[ $host = lctit ]]
    3680           then
    3681              export OMP_NUM_THREADS=$threads_per_task
    3682              echo "OMP_NUM_THREADS=$OMP_NUM_THREADS"
    3683              if [[ "$threads_per_task" != 1 ]]
    3684              then
    3685                 export MV2_ENABLE_AFFINITY=0
    3686              fi
    3687              echo "----- PBS_NODEFILE content:"
    3688              cat $PBS_NODEFILE
    3689              echo "-----"
    3690              (( ii = $numprocs / $threads_per_task ))
    3691              echo "mpirun  -np $ii  -hostfile $PBS_NODEFILE ./a.out  $ROPTS"
    3692              mpirun  -np $ii  -hostfile $PBS_NODEFILE ./a.out  $ROPTS
    3693 
    36943694          else
    3695              mpprun  -n $numprocs  a.out  $ROPTS
    3696           fi
    3697       else
    3698           a.out  $ROPTS
    3699        fi
    3700     fi
     3695             a.out
     3696          fi
     3697
     3698       fi  # end normal (non-debug) execution
     3699
     3700    fi  # end explicit execute_command or host-specific execute actions
    37013701
    37023702    if [[ $? != 0 ]]
     
    37623762      then
    37633763         printf "\n\n\n *** post-processing: now executing \"aprun  -n 1  -N 1 combine_plot_fields${block}.x\" ..."
    3764          aprun  -n 1  -N 1 combine_plot_fields${block}.x #$ROPTS < runfile_atmos
     3764         aprun  -n 1  -N 1 combine_plot_fields${block}.x
    37653765      else
    37663766         printf "\n\n\n *** post-processing: now executing \"combine_plot_fields${block}.x\" ..."
  • palm/trunk/SCRIPTS/subjob

    r1702 r1779  
    152152
    153153 typeset  -i   cputime=0  memory=0  Memory=0  minuten  resttime  sekunden  stunden
    154  typeset  -i   inumprocs  mpi_tasks=0  nodes=0  processes_per_node=0 tasks_per_node=0  threads_per_task=1
     154 typeset  -i   numprocs  mpi_tasks=0  nodes=0  processes_per_node=0 tasks_per_node=0  threads_per_task=1
    155155
    156156
  • palm/trunk/SOURCE/Makefile

    r1767 r1779  
    2020# Current revisions:
    2121# ------------------
    22 #
     22# dependencies changed for init_peprid
    2323#
    2424# Former revisions:
     
    383383init_masks.o: modules.o mod_kinds.o
    384384init_ocean.o: modules.o eqn_state_seawater.o mod_kinds.o
    385 init_pegrid.o: modules.o mod_kinds.o pmc_interface.o
     385init_pegrid.o: modules.o mod_kinds.o
    386386init_pt_anomaly.o: modules.o mod_kinds.o
    387387init_rankine.o: modules.o mod_kinds.o
  • palm/trunk/SOURCE/check_open.f90

    r1746 r1779  
    1919! Current revisions:
    2020! -----------------
    21 !
     21! coupling_char is trimmed at every place it occurs, because it can have
     22! different length now
    2223!
    2324! Former revisions:
     
    274275!--       check_namelist_files!
    275276          IF ( check_restart == 2 ) THEN
    276              OPEN ( 11, FILE='PARINF'//coupling_char, FORM='FORMATTED',        &
    277                         STATUS='OLD' )
    278           ELSE
    279              OPEN ( 11, FILE='PARIN'//coupling_char, FORM='FORMATTED',        &
     277             OPEN ( 11, FILE='PARINF'//TRIM( coupling_char ),                  &
     278                        FORM='FORMATTED', STATUS='OLD' )
     279          ELSE
     280             OPEN ( 11, FILE='PARIN'//TRIM( coupling_char ), FORM='FORMATTED', &
    280281                        STATUS='OLD' )
    281282          END IF
    282283#else
    283284
    284           OPEN ( 11, FILE='PARIN'//coupling_char, FORM='FORMATTED',            &
     285          OPEN ( 11, FILE='PARIN'//TRIM( coupling_char ), FORM='FORMATTED',    &
    285286                     STATUS='OLD' )
    286287#endif
     
    289290
    290291          IF ( myid_char == '' )  THEN
    291              OPEN ( 13, FILE='BININ'//coupling_char//myid_char,                &
     292             OPEN ( 13, FILE='BININ'//TRIM( coupling_char )//myid_char,        &
    292293                        FORM='UNFORMATTED', STATUS='OLD' )
    293294          ELSE
     
    296297!--          only this file contains the global variables
    297298             IF ( .NOT. openfile(file_id)%opened_before )  THEN
    298                 OPEN ( 13, FILE='BININ'//TRIM( coupling_char )//'/_000000',      &
     299                OPEN ( 13, FILE='BININ'//TRIM( coupling_char )//'/_000000',    &
    299300                           FORM='UNFORMATTED', STATUS='OLD' )
    300301             ELSE
    301                 OPEN ( 13, FILE='BININ'//TRIM( coupling_char )//'/'//myid_char,&
    302                            FORM='UNFORMATTED', STATUS='OLD' )
     302                OPEN ( 13, FILE='BININ'//TRIM( coupling_char )//'/'//          &
     303                           myid_char, FORM='UNFORMATTED', STATUS='OLD' )
    303304             ENDIF
    304305          ENDIF
     
    307308
    308309          IF ( myid_char == '' )  THEN
    309              OPEN ( 14, FILE='BINOUT'//coupling_char//myid_char,               &
     310             OPEN ( 14, FILE='BINOUT'//TRIM( coupling_char )//myid_char,       &
    310311                        FORM='UNFORMATTED', POSITION='APPEND' )
    311312          ELSE
    312313             IF ( myid == 0  .AND. .NOT. openfile(file_id)%opened_before )  THEN
    313                 CALL local_system( 'mkdir  BINOUT' // coupling_char )
     314                CALL local_system( 'mkdir  BINOUT' // TRIM( coupling_char ) )
    314315             ENDIF
    315316#if defined( __parallel ) && ! defined ( __check )
     
    325326       CASE ( 15 )
    326327
    327           OPEN ( 15, FILE='RUN_CONTROL'//coupling_char, FORM='FORMATTED' )
     328          OPEN ( 15, FILE='RUN_CONTROL'//TRIM( coupling_char ),                &
     329                     FORM='FORMATTED' )
    328330
    329331       CASE ( 16 )
    330332
    331           OPEN ( 16, FILE='LIST_PROFIL'//coupling_char, FORM='FORMATTED' )
     333          OPEN ( 16, FILE='LIST_PROFIL'//TRIM( coupling_char ),                &
     334                     FORM='FORMATTED' )
    332335
    333336       CASE ( 17 )
    334337
    335           OPEN ( 17, FILE='LIST_PROFIL_1D'//coupling_char, FORM='FORMATTED' )
     338          OPEN ( 17, FILE='LIST_PROFIL_1D'//TRIM( coupling_char ),             &
     339                     FORM='FORMATTED' )
    336340
    337341       CASE ( 18 )
    338342
    339           OPEN ( 18, FILE='CPU_MEASURES'//coupling_char, FORM='FORMATTED' )
     343          OPEN ( 18, FILE='CPU_MEASURES'//TRIM( coupling_char ),               &
     344                     FORM='FORMATTED' )
    340345
    341346       CASE ( 19 )
    342347
    343           OPEN ( 19, FILE='HEADER'//coupling_char, FORM='FORMATTED' )
     348          OPEN ( 19, FILE='HEADER'//TRIM( coupling_char ), FORM='FORMATTED' )
    344349
    345350       CASE ( 20 )
    346351
    347352          IF ( myid == 0  .AND. .NOT. openfile(file_id)%opened_before )  THEN
    348              CALL local_system( 'mkdir  DATA_LOG' // coupling_char )
     353             CALL local_system( 'mkdir  DATA_LOG' // TRIM( coupling_char ) )
    349354          ENDIF
    350355          IF ( myid_char == '' )  THEN
    351              OPEN ( 20, FILE='DATA_LOG'//TRIM( coupling_char )//'/_000000',      &
     356             OPEN ( 20, FILE='DATA_LOG'//TRIM( coupling_char )//'/_000000',    &
    352357                        FORM='UNFORMATTED', POSITION='APPEND' )
    353358          ELSE
     
    358363             CALL MPI_BARRIER( comm2d, ierr )
    359364#endif
    360              OPEN ( 20, FILE='DATA_LOG'//TRIM( coupling_char )//'/'//myid_char,&
    361                         FORM='UNFORMATTED', POSITION='APPEND' )
     365             OPEN ( 20, FILE='DATA_LOG'//TRIM( coupling_char )//'/'//          &
     366                        myid_char, FORM='UNFORMATTED', POSITION='APPEND' )
    362367          ENDIF
    363368
     
    368373                        FORM='UNFORMATTED', POSITION='APPEND' )
    369374          ELSE
    370              OPEN ( 21, FILE='PLOT2D_XY'//coupling_char,                       &
     375             OPEN ( 21, FILE='PLOT2D_XY'//TRIM( coupling_char ),                       &
    371376                        FORM='UNFORMATTED', POSITION='APPEND' )
    372377          ENDIF
     
    401406                        FORM='UNFORMATTED', POSITION='APPEND' )
    402407          ELSE
    403              OPEN ( 22, FILE='PLOT2D_XZ'//coupling_char, FORM='UNFORMATTED',   &
    404                         POSITION='APPEND' )
     408             OPEN ( 22, FILE='PLOT2D_XZ'//TRIM( coupling_char ),               &
     409                        FORM='UNFORMATTED', POSITION='APPEND' )
    405410          ENDIF
    406411
     
    434439                        FORM='UNFORMATTED', POSITION='APPEND' )
    435440          ELSE
    436              OPEN ( 23, FILE='PLOT2D_YZ'//coupling_char, FORM='UNFORMATTED',   &
    437                         POSITION='APPEND' )
     441             OPEN ( 23, FILE='PLOT2D_YZ'//TRIM( coupling_char ),               &
     442                        FORM='UNFORMATTED', POSITION='APPEND' )
    438443          ENDIF
    439444
     
    541546          ELSE
    542547             IF ( myid == 0  .AND.  .NOT. openfile(80)%opened_before )  THEN
    543                 CALL local_system( 'mkdir  PARTICLE_INFOS' // coupling_char )
     548                CALL local_system( 'mkdir  PARTICLE_INFOS' //                  &
     549                                   TRIM( coupling_char ) )
    544550             ENDIF
    545551#if defined( __parallel ) && ! defined ( __check )
     
    565571       CASE ( 81 )
    566572
    567              OPEN ( 81, FILE='PLOTSP_X_PAR'//coupling_char, FORM='FORMATTED',  &
    568                         DELIM='APOSTROPHE', RECL=1500, POSITION='APPEND' )
     573             OPEN ( 81, FILE='PLOTSP_X_PAR'//TRIM( coupling_char ),            &
     574                        FORM='FORMATTED', DELIM='APOSTROPHE', RECL=1500,       &
     575                        POSITION='APPEND' )
    569576
    570577       CASE ( 82 )
    571578
    572              OPEN ( 82, FILE='PLOTSP_X_DATA'//coupling_char, FORM='FORMATTED', &
    573                         POSITION = 'APPEND' )
     579             OPEN ( 82, FILE='PLOTSP_X_DATA'//TRIM( coupling_char ),          &
     580                        FORM='FORMATTED', POSITION = 'APPEND' )
    574581
    575582       CASE ( 83 )
    576583
    577              OPEN ( 83, FILE='PLOTSP_Y_PAR'//coupling_char, FORM='FORMATTED',  &
    578                         DELIM='APOSTROPHE', RECL=1500, POSITION='APPEND' )
     584             OPEN ( 83, FILE='PLOTSP_Y_PAR'//TRIM( coupling_char ),            &
     585                        FORM='FORMATTED', DELIM='APOSTROPHE', RECL=1500,       &
     586                        POSITION='APPEND' )
    579587
    580588       CASE ( 84 )
    581589
    582              OPEN ( 84, FILE='PLOTSP_Y_DATA'//coupling_char, FORM='FORMATTED', &
    583                         POSITION='APPEND' )
     590             OPEN ( 84, FILE='PLOTSP_Y_DATA'//TRIM( coupling_char ),          &
     591                        FORM='FORMATTED', POSITION='APPEND' )
    584592
    585593       CASE ( 85 )
     
    590598          ELSE
    591599             IF ( myid == 0  .AND.  .NOT. openfile(85)%opened_before )  THEN
    592                 CALL local_system( 'mkdir  PARTICLE_DATA' // coupling_char )
     600                CALL local_system( 'mkdir  PARTICLE_DATA' //                   &
     601                                   TRIM( coupling_char ) )
    593602             ENDIF
    594603#if defined( __parallel ) && ! defined ( __check )
     
    622631!--       Set filename depending on unit number
    623632          IF ( file_id == 101 )  THEN
    624              filename = 'DATA_2D_XY_NETCDF' // coupling_char
     633             filename = 'DATA_2D_XY_NETCDF' // TRIM( coupling_char )
    625634             av = 0
    626635          ELSE
    627              filename = 'DATA_2D_XY_AV_NETCDF' // coupling_char
     636             filename = 'DATA_2D_XY_AV_NETCDF' // TRIM( coupling_char )
    628637             av = 1
    629638          ENDIF
     
    684693!--       Set filename depending on unit number
    685694          IF ( file_id == 102 )  THEN
    686              filename = 'DATA_2D_XZ_NETCDF' // coupling_char
     695             filename = 'DATA_2D_XZ_NETCDF' // TRIM( coupling_char )
    687696             av = 0
    688697          ELSE
    689              filename = 'DATA_2D_XZ_AV_NETCDF' // coupling_char
     698             filename = 'DATA_2D_XZ_AV_NETCDF' // TRIM( coupling_char )
    690699             av = 1
    691700          ENDIF
     
    746755!--       Set filename depending on unit number
    747756          IF ( file_id == 103 )  THEN
    748              filename = 'DATA_2D_YZ_NETCDF' // coupling_char
     757             filename = 'DATA_2D_YZ_NETCDF' // TRIM( coupling_char )
    749758             av = 0
    750759          ELSE
    751              filename = 'DATA_2D_YZ_AV_NETCDF' // coupling_char
     760             filename = 'DATA_2D_YZ_AV_NETCDF' // TRIM( coupling_char )
    752761             av = 1
    753762          ENDIF
     
    807816!
    808817!--       Set filename
    809           filename = 'DATA_1D_PR_NETCDF' // coupling_char
     818          filename = 'DATA_1D_PR_NETCDF' // TRIM( coupling_char )
    810819
    811820!
     
    847856!
    848857!--       Set filename
    849           filename = 'DATA_1D_TS_NETCDF' // coupling_char
     858          filename = 'DATA_1D_TS_NETCDF' // TRIM( coupling_char )
    850859
    851860!
     
    889898!--       Set filename depending on unit number
    890899          IF ( file_id == 106 )  THEN
    891              filename = 'DATA_3D_NETCDF' // coupling_char
     900             filename = 'DATA_3D_NETCDF' // TRIM( coupling_char )
    892901             av = 0
    893902          ELSE
    894              filename = 'DATA_3D_AV_NETCDF' // coupling_char
     903             filename = 'DATA_3D_AV_NETCDF' // TRIM( coupling_char )
    895904             av = 1
    896905          ENDIF
     
    952961!
    953962!--       Set filename
    954           filename = 'DATA_1D_SP_NETCDF' // coupling_char
     963          filename = 'DATA_1D_SP_NETCDF' // TRIM( coupling_char )
    955964
    956965!
     
    9941003
    9951004          IF ( myid_char == '' )  THEN
    996              filename = 'DATA_PRT_NETCDF' // coupling_char
     1005             filename = 'DATA_PRT_NETCDF' // TRIM( coupling_char )
    9971006          ELSE
    9981007             filename = 'DATA_PRT_NETCDF' // TRIM( coupling_char ) // '/' //   &
     
    10551064!
    10561065!--       Set filename
    1057           filename = 'DATA_1D_PTS_NETCDF' // coupling_char
     1066          filename = 'DATA_1D_PTS_NETCDF' // TRIM( coupling_char )
    10581067
    10591068!
     
    10971106       CASE ( 117 )
    10981107
    1099           OPEN ( 117, FILE='PROGRESS'//coupling_char, STATUS='REPLACE', FORM='FORMATTED' )
     1108          OPEN ( 117, FILE='PROGRESS'//TRIM( coupling_char ),                  &
     1109                      STATUS='REPLACE', FORM='FORMATTED' )
    11001110
    11011111
     
    11061116             mid = file_id - 200
    11071117             WRITE ( mask_char,'(I2.2)')  mid
    1108              filename = 'DATA_MASK_' // mask_char // '_NETCDF' // coupling_char
     1118             filename = 'DATA_MASK_' // mask_char // '_NETCDF' //              &
     1119                        TRIM( coupling_char )
    11091120             av = 0
    11101121          ELSE
     
    11121123             WRITE ( mask_char,'(I2.2)')  mid
    11131124             filename = 'DATA_MASK_' // mask_char // '_AV_NETCDF' //           &
    1114                   coupling_char
     1125                        TRIM( coupling_char )
    11151126             av = 1
    11161127          ENDIF
  • palm/trunk/SOURCE/init_grid.f90

    r1763 r1779  
    1919! Current revisions:
    2020! -----------------
    21 !
     21! coupling_char is trimmed at every place it occurs, because it can have
     22! different length now
    2223!
    2324! Former revisions:
     
    8990!
    9091! 1069 2012-11-28 16:18:43Z maronga
    91 ! bugfix: added coupling_char to TOPOGRAPHY_DATA to allow topography in the ocean
    92 !          model in case of coupled runs
     92! bugfix: added coupling_char to TOPOGRAPHY_DATA to allow topography in the
     93!         ocean model in case of coupled runs
    9394!
    9495! 1036 2012-10-22 13:43:42Z raasch
     
    680681!--             Arbitrary irregular topography data in PALM format (exactly
    681682!--             matching the grid size and total domain size)
    682                 OPEN( 90, FILE='TOPOGRAPHY_DATA'//coupling_char, STATUS='OLD', &
    683                       FORM='FORMATTED', ERR=10 )
     683                OPEN( 90, FILE='TOPOGRAPHY_DATA'//TRIM( coupling_char ),      &
     684                          STATUS='OLD', FORM='FORMATTED', ERR=10 )
    684685                DO  j = ny, 0, -1
    685686                   READ( 90, *, ERR=11, END=11 )  ( topo_height(j,i), i = 0,nx )
     
    688689                GOTO 12
    689690         
    690  10             message_string = 'file TOPOGRAPHY'//coupling_char//' does not exist'
     691 10             message_string = 'file TOPOGRAPHY'//TRIM( coupling_char )//    &
     692                                 ' does not exist'
    691693                CALL message( 'init_grid', 'PA0208', 1, 2, 0, 6, 0 )
    692694
    693  11             message_string = 'errors in file TOPOGRAPHY_DATA'//coupling_char
     695 11             message_string = 'errors in file TOPOGRAPHY_DATA'//            &
     696                                 TRIM( coupling_char )
    694697                CALL message( 'init_grid', 'PA0209', 1, 2, 0, 6, 0 )
    695698
  • palm/trunk/SOURCE/init_pegrid.f90

    r1765 r1779  
    1919! Current revisions:
    2020! ------------------
    21 !
     21! changes regarding nested domain removed: virtual PE grid will be automatically
     22! calculated for nested runs too
    2223!
    2324! Former revisions:
     
    154155    USE pegrid
    155156 
    156     USE pmc_interface,                                                         &
    157         ONLY:  cpl_npex, cpl_npey, nested_run
    158 
    159157    USE transpose_indices,                                                     &
    160158        ONLY:  nxl_y, nxl_yd, nxl_z, nxr_y, nxr_yd, nxr_z, nyn_x, nyn_z, nys_x,&
     
    217215                           .FALSE. )
    218216
    219     IF ( nested_run )  THEN
    220 !
    221 !--    In case of nested-domain runs, the processor grid is explicitly given
    222 !--    by the user in the nestpar-NAMELIST
    223        pdims(1) = cpl_npex
    224        pdims(2) = cpl_npey
     217!
     218!--    Determine the processor topology or check it, if prescribed by the user
     219    IF ( npex == -1  .AND.  npey == -1 )  THEN
     220
     221!
     222!--       Automatic determination of the topology
     223       numproc_sqr = SQRT( REAL( numprocs, KIND=wp ) )
     224       pdims(1)    = MAX( numproc_sqr , 1 )
     225       DO  WHILE ( MOD( numprocs , pdims(1) ) /= 0 )
     226          pdims(1) = pdims(1) - 1
     227       ENDDO
     228       pdims(2) = numprocs / pdims(1)
     229
     230    ELSEIF ( npex /= -1  .AND.  npey /= -1 )  THEN
     231
     232!
     233!--    Prescribed by user. Number of processors on the prescribed topology
     234!--    must be equal to the number of PEs available to the job
     235       IF ( ( npex * npey ) /= numprocs )  THEN
     236          WRITE( message_string, * ) 'number of PEs of the prescribed ',   &
     237              'topology (', npex*npey,') does not match & the number of ', &
     238              'PEs available to the job (', numprocs, ')'
     239          CALL message( 'init_pegrid', 'PA0221', 1, 2, 0, 6, 0 )
     240       ENDIF
     241       pdims(1) = npex
     242       pdims(2) = npey
    225243
    226244    ELSE
    227245!
    228 !--    Determine the processor topology or check it, if prescribed by the user
    229        IF ( npex == -1  .AND.  npey == -1 )  THEN
    230 
    231 !
    232 !--       Automatic determination of the topology
    233           numproc_sqr = SQRT( REAL( numprocs, KIND=wp ) )
    234           pdims(1)    = MAX( numproc_sqr , 1 )
    235           DO  WHILE ( MOD( numprocs , pdims(1) ) /= 0 )
    236              pdims(1) = pdims(1) - 1
    237           ENDDO
    238           pdims(2) = numprocs / pdims(1)
    239 
    240        ELSEIF ( npex /= -1  .AND.  npey /= -1 )  THEN
    241 
    242 !
    243 !--       Prescribed by user. Number of processors on the prescribed topology
    244 !--       must be equal to the number of PEs available to the job
    245           IF ( ( npex * npey ) /= numprocs )  THEN
    246              WRITE( message_string, * ) 'number of PEs of the prescribed ',   &
    247                  'topology (', npex*npey,') does not match & the number of ', &
    248                  'PEs available to the job (', numprocs, ')'
    249              CALL message( 'init_pegrid', 'PA0221', 1, 2, 0, 6, 0 )
    250           ENDIF
    251           pdims(1) = npex
    252           pdims(2) = npey
    253 
    254        ELSE
    255 !
    256 !--       If the processor topology is prescribed by the user, the number of
    257 !--       PEs must be given in both directions
    258           message_string = 'if the processor topology is prescribed by th' //  &
    259                    'e user& both values of "npex" and "npey" must be given' // &
    260                    ' in the &NAMELIST-parameter file'
    261           CALL message( 'init_pegrid', 'PA0222', 1, 2, 0, 6, 0 )
    262 
    263        ENDIF
    264 
    265     ENDIF
    266 
     246!--    If the processor topology is prescribed by the user, the number of
     247!--    PEs must be given in both directions
     248       message_string = 'if the processor topology is prescribed by th' //  &
     249                'e user& both values of "npex" and "npey" must be given' // &
     250                ' in the &NAMELIST-parameter file'
     251       CALL message( 'init_pegrid', 'PA0222', 1, 2, 0, 6, 0 )
     252
     253    ENDIF
    267254
    268255!
  • palm/trunk/SOURCE/interaction_droplets_ptq.f90

    r1683 r1779  
    1919! Current revisions:
    2020! -----------------
    21 !
     21! module procedure names shortened to avoid Intel compiler warnings about too
     22! long names
    2223!
    2324! Former revisions:
     
    6061
    6162    INTERFACE interaction_droplets_ptq
    62        MODULE PROCEDURE interaction_droplets_ptq
    63        MODULE PROCEDURE interaction_droplets_ptq_ij
     63!
     64!--    Internal names shortened in order ro avoid Intel compiler messages
     65!--    about too long names
     66       MODULE PROCEDURE i_droplets_ptq
     67       MODULE PROCEDURE i_droplets_ptq_ij
    6468    END INTERFACE interaction_droplets_ptq
    6569 
     
    7276!> Call for all grid points
    7377!------------------------------------------------------------------------------!
    74     SUBROUTINE interaction_droplets_ptq
     78    SUBROUTINE i_droplets_ptq
    7579
    7680       USE arrays_3d,                                                          &
     
    103107       ENDDO
    104108
    105     END SUBROUTINE interaction_droplets_ptq
     109    END SUBROUTINE i_droplets_ptq
    106110
    107111
     
    111115!> Call for grid point i,j
    112116!------------------------------------------------------------------------------!
    113     SUBROUTINE interaction_droplets_ptq_ij( i, j )
     117    SUBROUTINE i_droplets_ptq_ij( i, j )
    114118
    115119       USE arrays_3d,                                                          &
     
    139143       ENDDO
    140144
    141     END SUBROUTINE interaction_droplets_ptq_ij
     145    END SUBROUTINE i_droplets_ptq_ij
    142146
    143147 END MODULE interaction_droplets_ptq_mod
  • palm/trunk/SOURCE/modules.f90

    r1765 r1779  
    1919! Current revisions:
    2020! ------------------
    21 !
     21! coupling_char extended to LEN=3
    2222!
    2323! Former revisions:
     
    578578
    579579    CHARACTER (LEN=1)    ::  cycle_mg = 'w', timestep_reason = ' '
    580     CHARACTER (LEN=2)    ::  coupling_char = ''
     580    CHARACTER (LEN=3)    ::  coupling_char = ''
    581581    CHARACTER (LEN=5)    ::  write_binary = 'false'
    582582    CHARACTER (LEN=8)    ::  most_method = 'lookup', & !< NAMELIST parameter defining method to be used to calculate Okukhov length,
  • palm/trunk/SOURCE/palm.f90

    r1765 r1779  
    1919! Current revisions:
    2020! -----------------
    21 !
     21! setting of nest_domain and coupling_char moved to the pmci
    2222!
    2323! Former revisions:
     
    198198!-- be changed in init_pegrid).
    199199    IF ( nested_run )  THEN
    200 !--    TO_DO: move the following two settings somewehere to the pmc_interface
    201        IF ( cpl_id >= 2 )  THEN
    202           nest_domain = .TRUE.
    203           WRITE( coupling_char, '(A1,I1.1)') '_', cpl_id
    204        ENDIF
    205200
    206201       CALL MPI_COMM_SIZE( comm_palm, numprocs, ierr )
  • palm/trunk/SOURCE/pmc_client.f90

    r1765 r1779  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! kind=dp replaced by wp, dim_order removed
     23! array management changed from linked list to sequential loop
    2324!
    2425! Former revisions:
     
    5051    USE  kinds
    5152    USE  PMC_general,   ONLY: ClientDef, DA_NameDef, DA_Namelen, PMC_STATUS_OK, PMC_DA_NAME_ERR, PeDef, ArrayDef, &
    52                                          DA_Desclen, DA_Namelen, PMC_G_SetName, PMC_G_GetName
     53                                         DA_Desclen, DA_Namelen, PMC_G_SetName, PMC_MAX_ARRAY
    5354    USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_server_comm
    5455    USE  PMC_MPI_wrapper,           ONLY: PMC_Send_to_Server, PMC_Recv_from_Server, PMC_Time,                     &
     
    5859    SAVE
    5960
    60 !   data local to this MODULE
    6161    Type(ClientDef)                       :: me
    62 !-- TO_DO: what is the meaning of this? Could variables declared in this module
    63 !--        also have single precision?
    64 !    INTEGER, PARAMETER                    :: dp = wp
    65 
    66     INTEGER, save                         :: myIndex = 0                !Counter and unique number for Data Arrays
     62
     63    INTEGER                               :: next_array_in_list = 0
     64    INTEGER                               :: myIndex = 0                !Counter and unique number for Data Arrays
    6765
    6866    ! INTERFACE section
     
    8179    END INTERFACE PMC_C_Get_2D_index_list
    8280
     81    INTERFACE PMC_C_clear_next_array_list
     82        MODULE procedure PMC_C_clear_next_array_list
     83    END INTERFACE PMC_C_clear_next_array_list
     84
    8385    INTERFACE PMC_C_GetNextArray
    8486        MODULE procedure PMC_C_GetNextArray
     
    105107
    106108    PUBLIC PMC_ClientInit , PMC_Set_DataArray_Name, PMC_C_Get_2D_index_list
    107     PUBLIC PMC_C_GetNextArray, PMC_C_Set_DataArray
    108     PUBLIC PMC_C_setInd_and_AllocMem , PMC_C_GetBuffer, PMC_C_PutBuffer ! ,PMC_C_GetServerType
     109    PUBLIC PMC_C_GetNextArray, PMC_C_Set_DataArray, PMC_C_clear_next_array_list
     110    PUBLIC PMC_C_setInd_and_AllocMem , PMC_C_GetBuffer, PMC_C_PutBuffer
    109111
    110112CONTAINS
     
    130132        CALL MPI_Intercomm_merge (me%inter_comm, .true., me%intra_comm, istat);
    131133        CALL MPI_Comm_rank (me%intra_comm, me%intra_rank, istat);
    132 
    133134        ALLOCATE (me%PEs(me%inter_npes))
    134135
     136!
     137!--     Allocate for all Server PEs an array of TYPE ArrayDef to store information of transfer array
    135138        do i=1,me%inter_npes
    136            NULLIFY(me%PEs(i)%Arrays)
     139           ALLOCATE(me%PEs(i)%array_list(PMC_MAX_ARRAY))
    137140        end do
    138141
     
    142145    END SUBROUTINE PMC_ClientInit
    143146
    144     SUBROUTINE PMC_Set_DataArray_Name (ServerArrayDesc, ServerArrayName, ClientArrayDesc, ClientArrayName, istat, LastEntry)
     147    SUBROUTINE PMC_Set_DataArray_Name (ServerArrayDesc, ServerArrayName, ClientArrayDesc, ClientArrayName, istat)
    145148        IMPLICIT none
    146149        character(len=*),INTENT(IN)           :: ServerArrayName
     
    149152        character(len=*),INTENT(IN)           :: ClientArrayDesc
    150153        INTEGER,INTENT(OUT)                   :: istat
    151         LOGICAL,INTENT(IN),optional           :: LastEntry
    152154
    153155        !-- local variables
     
    192194        CALL PMC_Bcast ( myName%NameOnClient, myPE, comm=m_to_server_comm)
    193195
    194         if(present (LastEntry))   then
    195             CALL PMC_Set_DataArray_Name_LastEntry ( LastEntry = LastEntry)
    196         end if
    197 
    198196        CALL PMC_G_SetName (me, myName%couple_index, myName%NameOnClient)
    199197
     
    231229       INTEGER(KIND=MPI_ADDRESS_KIND)          :: disp            !: Displacement Unit (Integer = 4, floating poit = 8
    232230       INTEGER,DIMENSION(me%inter_npes*2)      :: NrEle           !: Number of Elements of a horizontal slice
    233        TYPE(PeDef),POINTER                     :: aPE             !: Pointer to PeDef strzcture
     231       TYPE(PeDef),POINTER                     :: aPE             !: Pointer to PeDef structure
    234232       INTEGER(KIND=MPI_ADDRESS_KIND)          :: WinSize         !: Size of MPI window 2 (in bytes)
    235233       INTEGER,DIMENSION(:),POINTER            :: myInd
     
    299297    END SUBROUTINE PMC_C_Get_2D_index_list
    300298
     299    SUBROUTINE PMC_C_clear_next_array_list
     300       IMPLICIT none
     301
     302       next_array_in_list = 0
     303
     304       return
     305    END SUBROUTINE PMC_C_clear_next_array_list
     306
     307!   List handling is still required to get minimal interaction with pmc_interface
    301308    LOGICAL function PMC_C_GetNextArray (myName)
    302309        character(len=*),INTENT(OUT)               :: myName
    303310
    304311        !-- local variables
    305         INTEGER                      :: MyCoupleIndex
    306         LOGICAL                      :: MyLast                             !Last Array in List
    307         character(len=DA_Namelen)    :: loName
    308 
    309         loName = 'NoName '
    310         MyLast = .true.
    311 
    312         CALL PMC_G_GetName (me, MyCoupleIndex, loName, MyLast)
    313 
    314         myName = trim(loName)
    315 
    316         PMC_C_GetNextArray = .NOT. MyLast                        ! Return true if valid array
    317 
    318         return
     312       TYPE(PeDef),POINTER          :: aPE
     313       TYPE(ArrayDef),POINTER       :: ar
     314
     315       next_array_in_list = next_array_in_list+1
     316
     317!--    Array Names are the same on all client PE, so take first PE to get the name
     318       aPE => me%PEs(1)
     319
     320       if(next_array_in_list > aPE%Nr_arrays) then
     321          PMC_C_GetNextArray = .false.             !all arrays done
     322          return
     323       end if
     324
     325       ar  => aPE%array_list(next_array_in_list)
     326
     327       myName = ar%name
     328
     329       PMC_C_GetNextArray =  .true.                ! Return true if legal array
     330       return
    319331    END function PMC_C_GetNextArray
    320332
    321333    SUBROUTINE PMC_C_Set_DataArray_2d (array)
     334
    322335       IMPLICIT none
    323 !--    TO_DO: is double precision absolutely required here?
    324        REAL(kind=dp),INTENT(IN),DIMENSION(:,:)    :: array
    325        !-- local variables
    326        INTEGER                           :: NrDims
    327        INTEGER,DIMENSION (4)             :: dims
    328        INTEGER                           :: dim_order
    329        TYPE(c_ptr)                       :: array_adr
    330        INTEGER                           :: i
    331        TYPE(PeDef),POINTER               :: aPE
    332        TYPE(ArrayDef),POINTER            :: ar
     336
     337       REAL(wp), INTENT(IN) ,DIMENSION(:,:) ::  array
     338
     339       INTEGER                              :: NrDims
     340       INTEGER,DIMENSION (4)                :: dims
     341       TYPE(c_ptr)                          :: array_adr
     342       INTEGER                              :: i
     343       TYPE(PeDef),POINTER                  :: aPE
     344       TYPE(ArrayDef),POINTER               :: ar
    333345
    334346
     
    338350       dims(1)   = size(array,1)
    339351       dims(2)   = size(array,2)
    340        dim_order = 2
    341352
    342353       array_adr = c_loc(array)
     
    344355       do i=1,me%inter_npes
    345356          aPE => me%PEs(i)
    346           ar  => aPE%Arrays
     357          ar  => aPE%array_list(next_array_in_list)    !actual array is last array in list
    347358          ar%NrDims    = NrDims
    348359          ar%A_dim     = dims
    349           ar%dim_order = dim_order
    350360          ar%data      = array_adr
    351361       end do
     
    355365
    356366    SUBROUTINE PMC_C_Set_DataArray_3d (array)
     367
    357368       IMPLICIT none
    358 !--    TO_DO: is double precision absolutely required here?
    359        REAL(kind=dp),INTENT(IN),DIMENSION(:,:,:)  :: array
    360        !-- local variables
    361        INTEGER                           :: NrDims
    362        INTEGER,DIMENSION (4)             :: dims
    363        INTEGER                           :: dim_order
    364        TYPE(c_ptr)                       :: array_adr
    365        INTEGER                           :: i
    366        TYPE(PeDef),POINTER               :: aPE
    367        TYPE(ArrayDef),POINTER            :: ar
     369
     370       REAL(wp),INTENT(IN),DIMENSION(:,:,:) ::  array
     371
     372       INTEGER                              ::  NrDims
     373       INTEGER,DIMENSION (4)                ::  dims
     374       TYPE(c_ptr)                          ::  array_adr
     375       INTEGER                              ::  i
     376       TYPE(PeDef),POINTER                  ::  aPE
     377       TYPE(ArrayDef),POINTER               ::  ar
    368378
    369379       dims = 1
     
    373383       dims(2)   = size(array,2)
    374384       dims(3)   = size(array,3)
    375        dim_order =33
    376385
    377386       array_adr = c_loc(array)
     
    379388       do i=1,me%inter_npes
    380389          aPE => me%PEs(i)
    381           ar  => aPE%Arrays
     390          ar  => aPE%array_list(next_array_in_list)    !actual array is last array in list
    382391          ar%NrDims    = NrDims
    383392          ar%A_dim     = dims
    384           ar%dim_order = dim_order
    385393          ar%data      = array_adr
    386394       end do
     
    393401      IMPLICIT none
    394402
    395       INTEGER                                 :: i, ierr
     403      INTEGER                                 :: i, ierr, j
    396404      INTEGER                                 :: arlen, myIndex, tag
    397405      INTEGER(idp)                            :: bufsize                   ! Size of MPI data Window
     
    412420         tag = 200
    413421
    414          do while (PMC_C_GetNextArray (myName))
    415             ar  => aPE%Arrays
     422         do j=1,aPE%Nr_arrays
     423            ar  => aPE%array_list(j)
    416424
    417425            ! Receive Index from client
     
    419427            CALL MPI_Recv (myIndex, 1, MPI_INTEGER, i-1, tag, me%inter_comm, MPI_STATUS_IGNORE, ierr)
    420428
    421             if(ar%dim_order == 33) then                    ! PALM has k in first dimension
     429            if(ar%NrDims == 3) then                    ! PALM has k in first dimension
    422430               bufsize = max(bufsize,ar%A_dim(1)*ar%A_dim(2)*ar%A_dim(3))    ! determine max, because client buffer is allocated only once
    423431            else
     
    442450         aPE => me%PEs(i)
    443451
    444          do while (PMC_C_GetNextArray (myName))
    445             ar  => aPE%Arrays
     452         do j=1,aPE%Nr_arrays
     453            ar  => aPE%array_list(j)
    446454            ar%SendBuf = base_ptr
    447455         end do
     
    452460
    453461   SUBROUTINE PMC_C_GetBuffer (WaitTime)
     462
    454463      IMPLICIT none
    455       REAL(kind=dp),INTENT(OUT),optional         :: WaitTime
     464
     465      REAL(wp), INTENT(OUT), optional   ::  WaitTime
    456466
    457467      !-- local variables
    458       INTEGER                                 :: ip, ij, ierr
    459       INTEGER                                 :: nr                 ! Number of Elements to getb from server
    460       INTEGER                                 :: myIndex
    461       REAL(kind=dp)                           :: t1,t2
    462       TYPE(PeDef),POINTER                     :: aPE
    463       TYPE(ArrayDef),POINTER                  :: ar
    464       INTEGER,DIMENSION(1)                    :: buf_shape
    465       REAL(kind=wp),POINTER,DIMENSION(:)      :: buf
    466       REAL(kind=wp),POINTER,DIMENSION(:,:)    :: data_2d
    467       REAL(kind=wp),POINTER,DIMENSION(:,:,:)  :: data_3d
    468       character(len=DA_Namelen)               :: myName
    469       INTEGER(kind=MPI_ADDRESS_KIND)          :: target_disp
     468      INTEGER                           ::  ip, ij, ierr, j
     469      INTEGER                           ::  nr  ! Number of Elements to getb from server
     470      INTEGER                           :: myIndex
     471      REAL(wp)                          :: t1,t2
     472      TYPE(PeDef),POINTER               :: aPE
     473      TYPE(ArrayDef),POINTER            :: ar
     474      INTEGER,DIMENSION(1)              :: buf_shape
     475      REAL(wp),POINTER,DIMENSION(:)     :: buf
     476      REAL(wp),POINTER,DIMENSION(:,:)   :: data_2d
     477      REAL(wp),POINTER,DIMENSION(:,:,:) :: data_3d
     478      character(len=DA_Namelen)         :: myName
     479      INTEGER(kind=MPI_ADDRESS_KIND)    :: target_disp
    470480
    471481      t1 = PMC_Time()
    472482      CALL MPI_Barrier(me%intra_comm, ierr)                         ! Wait for server to fill buffer
    473       t2 = PMC_Time()
    474       if(present(WaitTime)) WaitTime = t2-t1
     483      t2 = PMC_Time()-t1
     484      if(present(WaitTime)) WaitTime = t2
    475485
    476486      CALL MPI_Barrier(me%intra_comm, ierr)                         ! Wait for buffer is filled
     
    479489         aPE => me%PEs(ip)
    480490
    481          do while (PMC_C_GetNextArray (myName))
    482             ar  => aPE%Arrays
    483             if(ar%dim_order == 2) then
     491         do j=1,aPE%Nr_arrays
     492            ar  => aPE%array_list(j)
     493            if(ar%NrDims == 2) then
    484494               nr = aPE%NrEle
    485             else if(ar%dim_order == 33) then
     495            else if(ar%NrDims == 3) then
    486496               nr = aPE%NrEle*ar%A_dim(1)
    487497            end if
     
    489499            buf_shape(1) = nr
    490500            CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
    491 
     501!
     502!--         MPI passive target RMA
    492503            if(nr > 0)   then
    493504               target_disp = (ar%BufIndex-1)
     
    498509
    499510            myIndex = 1
    500             if(ar%dim_order == 2) then
     511            if(ar%NrDims == 2) then
    501512
    502513               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
     
    505516                  myIndex = myIndex+1
    506517               end do
    507             else if(ar%dim_order == 33) then
     518            else if(ar%NrDims == 3) then
    508519               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
    509520               do ij=1,aPE%NrEle
     
    519530
    520531   SUBROUTINE PMC_C_PutBuffer (WaitTime)
     532
    521533      IMPLICIT none
    522       REAL(kind=dp),INTENT(OUT),optional         :: WaitTime
     534
     535      REAL(wp), INTENT(OUT), optional   :: WaitTime
    523536
    524537      !-- local variables
    525       INTEGER                                 :: ip, ij, ierr
    526       INTEGER                                 :: nr                 ! Number of Elements to getb from server
    527       INTEGER                                 :: myIndex
    528       REAL(kind=dp)                           :: t1,t2
    529       TYPE(PeDef),POINTER                     :: aPE
    530       TYPE(ArrayDef),POINTER                  :: ar
    531       INTEGER,DIMENSION(1)                    :: buf_shape
    532       REAL(kind=wp),POINTER,DIMENSION(:)      :: buf
    533       REAL(kind=wp),POINTER,DIMENSION(:,:)    :: data_2d
    534       REAL(kind=wp),POINTER,DIMENSION(:,:,:)  :: data_3d
    535       character(len=DA_Namelen)               :: myName
    536       INTEGER(kind=MPI_ADDRESS_KIND)          :: target_disp
     538      INTEGER                           ::  ip, ij, ierr, j
     539      INTEGER                           ::  nr  ! Number of Elements to getb from server
     540      INTEGER                           :: myIndex
     541      REAL(wp)                          :: t1,t2
     542      TYPE(PeDef),POINTER               :: aPE
     543      TYPE(ArrayDef),POINTER            :: ar
     544      INTEGER,DIMENSION(1)              :: buf_shape
     545      REAL(wp),POINTER,DIMENSION(:)     :: buf
     546      REAL(wp),POINTER,DIMENSION(:,:)   :: data_2d
     547      REAL(wp),POINTER,DIMENSION(:,:,:) :: data_3d
     548      character(len=DA_Namelen)         :: myName
     549      INTEGER(kind=MPI_ADDRESS_KIND)    :: target_disp
    537550
    538551
     
    540553         aPE => me%PEs(ip)
    541554
    542          do while (PMC_C_GetNextArray (myName))
    543             ar  => aPE%Arrays
    544             if(ar%dim_order == 2) then
     555         do j=1,aPE%Nr_arrays
     556            ar  => aPE%array_list(j)
     557            if(ar%NrDims == 2) then
    545558               nr = aPE%NrEle
    546             else if(ar%dim_order == 33) then
     559            else if(ar%NrDims == 3) then
    547560               nr = aPE%NrEle*ar%A_dim(1)
    548561            end if
     
    552565
    553566            myIndex = 1
    554             if(ar%dim_order == 2) then
     567            if(ar%NrDims == 2) then
    555568               CALL c_f_pointer(ar%data, data_2d, ar%A_dim(1:2))
    556569               do ij=1,aPE%NrEle
     
    558571                  myIndex = myIndex+1
    559572               end do
    560             else if(ar%dim_order == 33) then
     573            else if(ar%NrDims == 3) then
    561574               CALL c_f_pointer(ar%data, data_3d, ar%A_dim(1:3))
    562575               do ij=1,aPE%NrEle
     
    565578               end do
    566579            end if
    567 
     580!
     581!--         MPI passiv target RMA
    568582            if(nr > 0)   then
    569583               target_disp = (ar%BufIndex-1)
  • palm/trunk/SOURCE/pmc_general.f90

    r1767 r1779  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! PMC_MPI_REAL removed, dim_order removed from type arraydef,
     23! array management changed from linked list to sequential loop
    2324!
    2425! Former revisions:
     
    6263   INTEGER,parameter,PUBLIC              :: PMC_DA_NAME_ERR  = 10
    6364
     65   INTEGER,parameter,PUBLIC              :: PMC_MAX_ARRAY    = 32  !Max Number of Array which can be coupled
    6466   INTEGER,parameter,PUBLIC              :: PMC_MAX_MODELL   = 64
    65 !  TO_DO: the next variable doesn't seem to be used.  Remove?
    66    INTEGER,parameter,PUBLIC              :: PMC_MPI_REAL     = MPI_DOUBLE_PRECISION
    6767   INTEGER,parameter,PUBLIC              :: DA_Desclen       = 8
    6868   INTEGER,parameter,PUBLIC              :: DA_Namelen       = 16
     
    7777      INTEGER                       :: NrDims                      ! Number of Dimensions
    7878      INTEGER,DIMENSION(4)          :: A_dim                       ! Size of dimensions
    79       INTEGER                       :: dim_order                   ! Order of Dimensions: 2 = 2D array, 33 = 3D array
    8079      TYPE(c_ptr)                   :: data                        ! Pointer of data in server space
    8180      TYPE(c_ptr), DIMENSION(2)     :: po_data                     ! Base Pointers, PMC_S_Set_Active_data_array sets active pointer
     
    9190
    9291   TYPE, PUBLIC :: PeDef
    93       INTEGER(idp)                        :: NrEle                 ! Number of Elemets
    94       TYPE (xy_ind), POINTER,DIMENSION(:) :: locInd                ! xy index local array for remote PE
    95       TYPE( ArrayDef), POINTER            :: Arrays                ! Pointer to Data Array List (Type ArrayDef)
    96       TYPE( ArrayDef), POINTER            :: ArrayStart            ! Pointer to Star of the List
     92      INTEGER                                :: Nr_arrays=0        ! Number of arrays which will be transfered in this run
     93      INTEGER                                :: NrEle              ! Number of Elemets, same for all arrays
     94      TYPE (xy_ind), POINTER,DIMENSION(:)    :: locInd             ! xy index local array for remote PE
     95      TYPE( ArrayDef), POINTER, DIMENSION(:) :: array_list         ! List of Data Arrays to be transfered
    9796   END TYPE PeDef
    9897
     
    122121    end INTERFACE PMC_G_SetName
    123122
    124     INTERFACE PMC_G_GetName
    125        MODULE procedure PMC_G_GetName
    126     end INTERFACE PMC_G_GetName
    127 
    128123    INTERFACE PMC_sort
    129124       MODULE procedure sort_2d_i
    130125    end INTERFACE PMC_sort
    131126
    132     PUBLIC PMC_G_SetName, PMC_G_GetName, PMC_sort
     127    PUBLIC PMC_G_SetName, PMC_sort
    133128
    134129
     
    145140       TYPE(PeDef),POINTER                     :: aPE
    146141
     142!
     143!--    Assign array to next free index in array_list.
     144!--    Set name of array in ArrayDef structure
    147145       do i=1,myClient%inter_npes
    148146          aPE => myClient%PEs(i)
    149           ar  => aPE%Arrays
    150           if(.not. associated (ar) )  then
    151              ar => DA_List_append (ar, couple_index)
    152              aPE%ArrayStart => ar
    153          else
    154              ar => DA_List_append (ar, couple_index)
    155            endif
    156           Ar%Name    = trim(aName) // " "
    157           myClient%PEs(i)%Arrays => ar
     147          aPE%Nr_arrays = aPE%Nr_arrays+1
     148          aPE%array_list(aPE%Nr_arrays)%name        = aName
     149          aPE%array_list(aPE%Nr_arrays)%coupleIndex = couple_index
    158150       end do
    159151
     
    161153    end SUBROUTINE PMC_G_SetName
    162154
    163     SUBROUTINE PMC_G_GetName (myClient, couple_index, aName, aLast,Client_PeIndex)
    164        IMPLICIT none
    165 
    166        TYPE(ClientDef),INTENT(INOUT)           :: myClient
    167        INTEGER,INTENT(OUT)                     :: couple_index
    168        CHARACTER(LEN=*),INTENT(OUT)            :: aName
    169        logical,INTENT(OUT)                     :: aLast
    170        INTEGER,INTENT(IN),optional             :: Client_PeIndex
    171 
    172        INTEGER                                 :: i,istart,istop
    173        TYPE(PeDef),POINTER                     :: aPE
    174        TYPE(ArrayDef),POINTER                  :: ar
    175        logical,save                            :: first=.true.
    176 
    177        aLast = .false.
    178 
    179        if(present(Client_PeIndex))  then       !Loop over all Client PEs or just one selected via Client_PeIndex
    180           istart = Client_PeIndex
    181           istop  = Client_PeIndex
    182        else
    183           istart = 1
    184           istop  = myClient%inter_npes
    185        end if
    186 
    187        do i=istart,istop
    188           aPE => myClient%PEs(i)
    189           ar  => aPE%Arrays
    190           if(first)  then
    191              ar => aPE%ArrayStart
    192           else
    193              ar => aPE%Arrays
    194              ar => DA_List_next (ar)
    195              if(.not. associated (ar) )  then
    196                 aLast = .true.
    197                 first = .true.                                  !Reset linked list to begin
    198                 aPE%Arrays => ar
    199               end if
    200           endif
    201           aPE%Arrays => ar
    202        end do
    203        if(aLast) then
    204           return
    205        end if
    206 
    207        couple_index = ar%coupleIndex
    208        aName        = ar%Name
    209        aLast        = .false.
    210 
    211        first = .false.
    212 
    213 
    214        return
    215     END SUBROUTINE PMC_G_GetName
    216155
    217156    SUBROUTINE sort_2d_i (array,sort_ind)
     
    238177    END  SUBROUTINE sort_2d_i
    239178
    240 !   Private section
    241 !   linked List routines for Data Array handling
    242 
    243     FUNCTION DA_List_append   (node, couple_index)
    244        TYPE(ArrayDef),POINTER      :: DA_List_append
    245        TYPE(ArrayDef),POINTER      :: node
    246        INTEGER,INTENT(IN)          :: couple_index
    247 
    248 !--    local variables
    249        TYPE(ArrayDef),POINTER      :: ar
    250 
    251        if(.not. associated (node))   then
    252           ALLOCATE(ar)
    253           ar%coupleIndex = couple_index
    254           NULLIFY(ar%next)
    255           DA_List_append => ar
    256        else
    257           ALLOCATE(node%next)
    258           node%next%coupleIndex = couple_index
    259           NULLIFY(node%next%next)
    260           DA_List_append => node%next
    261        end if
    262 
    263        return
    264     END FUNCTION DA_List_append
    265 
    266     FUNCTION DA_List_next   (node)
    267        TYPE(ArrayDef),POINTER      :: DA_List_next
    268        TYPE(ArrayDef),POINTER      :: node
    269 
    270        DA_List_next => node%next
    271 
    272        return
    273     END FUNCTION DA_List_next
    274 
    275179#endif
    276180end MODULE pmc_general
  • palm/trunk/SOURCE/pmc_handle_communicator.f90

    r1765 r1779  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! only the total number of PEs is given in the nestpar-NAMELIST,
     23! additional comments included
    2324!
    2425! Former revisions:
     
    6263      INTEGER  ::  id
    6364      INTEGER  ::  parent_id
    64       INTEGER  ::  npe_x
    65       INTEGER  ::  npe_y
     65      INTEGER  ::  npe_total
    6666
    6767      REAL(wp) ::  lower_left_x
     
    155155            start_pe(1) = 0
    156156            DO  i = 2, m_nrofcpl+1
    157                start_pe(i) = start_pe(i-1) +                                   &
    158                              m_couplers(i-1)%npe_x * m_couplers(i-1)%npe_y
     157               start_pe(i) = start_pe(i-1) + m_couplers(i-1)%npe_total
    159158            ENDDO
    160159
     
    162161!--         The number of cores provided with the run must be the same as the
    163162!--         total sum of cores required by all nest domains
    164 !--         TO_DO: can we use > instead of /= ?
    165163            IF ( start_pe(m_nrofcpl+1) /= m_world_npes )  THEN
    166 !--            TO_DO: this IF statement is redundant
    167                IF ( m_world_rank == 0 )  THEN
    168                   WRITE ( message_string, '(A,I6,A,I6,A)' )                    &
    169                                   'nesting-setup requires more MPI procs (',   &
    170                                   start_pe(m_nrofcpl+1), ') than provided (',  &
    171                                   m_world_npes,')'
    172                   CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 )
    173                ENDIF
     164               WRITE ( message_string, '(A,I6,A,I6,A)' )                       &
     165                               'nesting-setup requires more MPI procs (',      &
     166                               start_pe(m_nrofcpl+1), ') than provided (',     &
     167                               m_world_npes,')'
     168               CALL message( 'pmc_init_model', 'PA0229', 3, 2, 0, 6, 0 )
    174169            ENDIF
    175170
     
    210205         CALL MPI_BCAST( m_couplers(i)%id,           1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
    211206         CALL MPI_BCAST( m_couplers(i)%Parent_id,    1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
    212          CALL MPI_BCAST( m_couplers(i)%npe_x,        1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
    213          CALL MPI_BCAST( m_couplers(i)%npe_y,        1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
     207         CALL MPI_BCAST( m_couplers(i)%npe_total,    1, MPI_INTEGER, 0, MPI_COMM_WORLD, istat )
    214208         CALL MPI_BCAST( m_couplers(i)%lower_left_x, 1, MPI_REAL,    0, MPI_COMM_WORLD, istat )
    215209         CALL MPI_BCAST( m_couplers(i)%lower_left_y, 1, MPI_REAL,    0, MPI_COMM_WORLD, istat )
     
    233227      CALL MPI_COMM_SPLIT( MPI_COMM_WORLD, m_my_cpl_id, m_my_cpl_rank, comm,   &
    234228                           istat )
    235       IF ( istat /= MPI_SUCCESS )  THEN
    236 !
    237 !--      TO_DO: replace by message-call
    238 !--      TO_DO: Can this really happen, or is this just for the debugging phase?
    239          IF ( m_world_rank == 0 )  WRITE (0,*) 'PMC: Error in MPI_Comm_split '
    240          CALL MPI_ABORT( MPI_COMM_WORLD, ierr, istat )
    241       ENDIF
    242 
    243229!
    244230!--   Get size and rank of the model running on this PE
     
    256242
    257243!
    258 !--   TO_DO: describe what is happening here, and why
     244!--   Save the current model communicator for PMC internal use
    259245      m_model_comm = comm
    260246
     
    268254         IF ( m_couplers(i)%parent_id == m_my_cpl_id )  THEN
    269255!
    270 !--         Collect server PEs
    271 !--         TO_DO: explain in more details, what is done here
     256!--         Collect server PEs.
     257!--         Every model exept the root model has a parent model which acts as
     258!--         server model. Create an intercommunicator to connect current PE to
     259!--         all client PEs
    272260            tag = 500 + i
    273261            CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD, start_pe(i),   &
     
    278266         ELSEIF ( i == m_my_cpl_id)  THEN
    279267!
    280 !--         Collect client PEs
    281 !--         TO_DO: explain in more detail, what is happening here
     268!--         Collect client PEs.
     269!--         Every model exept the root model has a paremt model which acts as
     270!--         server model. Create an intercommunicator to connect current PE to
     271!--         all server PEs
    282272            tag = 500 + i
    283273            CALL MPI_INTERCOMM_CREATE( comm, 0, MPI_COMM_WORLD,                &
    284274                                       start_pe(m_couplers(i)%parent_id),      &
    285275                                       tag, m_to_server_comm, istat )
    286          ENDIF
    287 
    288          IF ( istat /= MPI_SUCCESS )  THEN
    289 !
    290 !--         TO_DO: replace by message-call
    291 !--         TO_DO: can this really happen, or is this just for debugging?
    292             IF ( m_world_rank == 0 )  WRITE (0,*) 'PMC: Error in Coupler Setup '
    293             CALL MPI_ABORT( MPI_COMM_WORLD, ierr, istat )
    294276         ENDIF
    295277
     
    309291         ENDIF
    310292      ENDDO
    311 !--   TO_DO: explain why this is done
    312       pmc_server_for_client(clientcount+1) = -1
    313 
    314293!
    315294!--   Get the size of the server model
    316 !--   TO_DO: what does "size" mean here? Number of PEs?
    317295      IF ( m_my_cpl_id > 1 )  THEN
    318296         CALL MPI_COMM_REMOTE_SIZE( m_to_server_comm, m_server_remote_size,    &
     
    337315!
    338316!-- Make module private variables available to palm
    339 !-- TO_DO: why can't they be available from the beginning, i.e. why do they
    340 !--        first have to be declared as different private variables?
    341317   SUBROUTINE pmc_get_local_model_info( my_cpl_id, my_cpl_parent_id, cpl_name, &
    342                                         npe_x, npe_y, lower_left_x,            &
    343                                         lower_left_y )
     318                                        npe_total, lower_left_x, lower_left_y )
    344319
    345320      USE kinds
     
    350325      INTEGER, INTENT(OUT), OPTIONAL          ::  my_cpl_id
    351326      INTEGER, INTENT(OUT), OPTIONAL          ::  my_cpl_parent_id
    352       INTEGER, INTENT(OUT), OPTIONAL          ::  npe_x
    353       INTEGER, INTENT(OUT), OPTIONAL          ::  npe_y
     327      INTEGER, INTENT(OUT), OPTIONAL          ::  npe_total
    354328      REAL(wp), INTENT(OUT), OPTIONAL         ::  lower_left_x
    355329      REAL(wp), INTENT(OUT), OPTIONAL         ::  lower_left_y
    356330
    357 !--   TO_DO: is the PRESENT clause really required here?
    358331      IF ( PRESENT( my_cpl_id )           )  my_cpl_id        = m_my_cpl_id
    359332      IF ( PRESENT( my_cpl_parent_id )    )  my_cpl_parent_id = m_couplers(my_cpl_id)%parent_id
    360333      IF ( PRESENT( cpl_name )            )  cpl_name         = m_couplers(my_cpl_id)%name
    361       IF ( PRESENT( npe_x )               )  npe_x            = m_couplers(my_cpl_id)%npe_x
    362       IF ( PRESENT( npe_y )               )  npe_y            = m_couplers(my_cpl_id)%npe_y
     334      IF ( PRESENT( npe_total )           )  npe_total        = m_couplers(my_cpl_id)%npe_total
    363335      IF ( PRESENT( lower_left_x )        )  lower_left_x     = m_couplers(my_cpl_id)%lower_left_x
    364336      IF ( PRESENT( lower_left_y )        )  lower_left_y     = m_couplers(my_cpl_id)%lower_left_y
     
    378350
    379351
    380 
    381 !-- TO_DO: what does this comment mean?
    382 ! Private SUBROUTINEs
    383352 SUBROUTINE read_coupling_layout( nesting_mode, pmc_status )
    384353
     
    438407
    439408       IF ( m_couplers(i)%id /= -1  .AND.  i <= pmc_max_modell )  THEN
    440           WRITE ( 0, '(A,A,1X,4I7,1X,2F10.2)' )  'Set up Model  ',             &
    441                               TRIM( m_couplers(i)%name ), m_couplers(i)%id,    &
    442                               m_couplers(i)%Parent_id, m_couplers(i)%npe_x,    &
    443                               m_couplers(i)%npe_y, m_couplers(i)%lower_left_x, &
    444                               m_couplers(i)%lower_left_y
     409          WRITE ( 0, '(A,A,1X,3I7,1X,2F10.2)' )  'Set up Model  ',             &
     410                             TRIM( m_couplers(i)%name ), m_couplers(i)%id,     &
     411                             m_couplers(i)%Parent_id, m_couplers(i)%npe_total, &
     412                             m_couplers(i)%lower_left_x,                      &
     413                             m_couplers(i)%lower_left_y
    445414       ELSE
    446415!
  • palm/trunk/SOURCE/pmc_interface.f90

    r1767 r1779  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! only the total number of PEs is given for the domains, npe_x and npe_y
     23! replaced by npe_total,
     24! array management changed from linked list to sequential loop
    2325!
    2426! Former revisions:
     
    5961
    6062    USE control_parameters,                                                    &
    61         ONLY:  dt_3d, dz, humidity, message_string, nest_bound_l,              &
    62                nest_bound_r, nest_bound_s, nest_bound_n, passive_scalar,       &
    63                simulated_time, topography, volume_flow
     63        ONLY:  coupling_char, dt_3d, dz, humidity, message_string,             &
     64               nest_bound_l, nest_bound_r, nest_bound_s, nest_bound_n,         &
     65               nest_domain, passive_scalar, simulated_time, topography,        &
     66               volume_flow
    6467
    6568    USE cpulog,                                                                &
     
    8891
    8992    USE pmc_client,                                                            &
    90         ONLY:  pmc_clientinit, pmc_c_getnextarray, pmc_c_get_2d_index_list,    &
    91                pmc_c_getbuffer, pmc_c_putbuffer, pmc_c_setind_and_allocmem,    &
     93        ONLY:  pmc_clientinit, pmc_c_clear_next_array_list,                    &
     94               pmc_c_getnextarray, pmc_c_get_2d_index_list, pmc_c_getbuffer,   &
     95               pmc_c_putbuffer, pmc_c_setind_and_allocmem,                     &
    9296               pmc_c_set_dataarray, pmc_set_dataarray_name
    9397
     
    104108
    105109    USE pmc_server,                                                            &
    106         ONLY:  pmc_serverinit, pmc_s_fillbuffer, pmc_s_getdata_from_buffer,    &
    107                pmc_s_getnextarray, pmc_s_setind_and_allocmem,                  &
    108                pmc_s_set_active_data_array, pmc_s_set_dataarray,               &
    109                pmc_s_set_2d_index_list
     110        ONLY:  pmc_serverinit, pmc_s_clear_next_array_list, pmc_s_fillbuffer,  &
     111               pmc_s_getdata_from_buffer, pmc_s_getnextarray,                  &
     112               pmc_s_setind_and_allocmem, pmc_s_set_active_data_array,         &
     113               pmc_s_set_dataarray, pmc_s_set_2d_index_list
    110114
    111115#endif
     
    116120!--        limit. Try to reduce as much as possible
    117121
    118 !-- TO_DO: shouldn't we use public as default here? Only a minority of the
    119 !-- variables is private.
     122!-- TO_DO: are all of these variables following now really PUBLIC?
     123!--        Klaus and I guess they are not
    120124    PRIVATE    !:  Note that the default publicity is here set to private.
    121125
     
    129133    INTEGER(iwp), PUBLIC, SAVE      ::  cpl_id  = 1            !:
    130134    CHARACTER(LEN=32), PUBLIC, SAVE ::  cpl_name               !:
    131     INTEGER(iwp), PUBLIC, SAVE      ::  cpl_npex               !:
    132     INTEGER(iwp), PUBLIC, SAVE      ::  cpl_npey               !:
     135    INTEGER(iwp), PUBLIC, SAVE      ::  cpl_npe_total          !:
    133136    INTEGER(iwp), PUBLIC, SAVE      ::  cpl_parent_id          !:
    134137
     
    266269!-- Module private variables.
    267270    INTEGER(iwp), DIMENSION(3)          ::  define_coarse_grid_int    !:
    268     REAL(wp), DIMENSION(9)              ::  define_coarse_grid_real   !:
     271    REAL(wp), DIMENSION(7)              ::  define_coarse_grid_real   !:
    269272
    270273    TYPE coarsegrid_def
     
    364367!
    365368!--    This is not a nested run
    366 !
    367 !--    TO_DO: this wouldn't be required any more?
    368369       world_comm = MPI_COMM_WORLD
    369370       cpl_id     = 1
    370371       cpl_name   = ""
    371        cpl_npex   = 2
    372        cpl_npey   = 2
    373        lower_left_coord_x = 0.0_wp
    374        lower_left_coord_y = 0.0_wp
     372
    375373       RETURN
    376     ELSE
    377 !
    378 !--    Set the general steering switch which tells PALM that its a nested run
    379        nested_run = .TRUE.
     374
    380375    ENDIF
    381376
     377!
     378!-- Set the general steering switch which tells PALM that its a nested run
     379    nested_run = .TRUE.
     380
     381!
     382!-- Get some variables required by the pmc-interface (and in some cases in the
     383!-- PALM code out of the pmci) out of the pmc-core
    382384    CALL pmc_get_local_model_info( my_cpl_id = cpl_id,                         &
    383385                                   my_cpl_parent_id = cpl_parent_id,           &
    384386                                   cpl_name = cpl_name,                        &
    385                                    npe_x = cpl_npex, npe_y = cpl_npey,         &
     387                                   npe_total = cpl_npe_total,                  &
    386388                                   lower_left_x = lower_left_coord_x,          &
    387389                                   lower_left_y = lower_left_coord_y )
     390!
     391!-- Set the steering switch which tells the models that they are nested (of
     392!-- course the root domain (cpl_id = 1 ) is not nested)
     393    IF ( cpl_id >= 2 )  THEN
     394       nest_domain = .TRUE.
     395       WRITE( coupling_char, '(A1,I2.2)') '_', cpl_id
     396    ENDIF
     397
    388398!
    389399!-- Message that communicators for nesting are initialized.
     
    493503          define_coarse_grid_real(1) = lower_left_coord_x
    494504          define_coarse_grid_real(2) = lower_left_coord_y
    495 !--       TO_DO: remove this?
    496           define_coarse_grid_real(3) = 0             !  KK currently not used.
    497           define_coarse_grid_real(4) = 0
    498           define_coarse_grid_real(5) = dx
    499           define_coarse_grid_real(6) = dy
    500           define_coarse_grid_real(7) = lower_left_coord_x + ( nx + 1 ) * dx
    501           define_coarse_grid_real(8) = lower_left_coord_y + ( ny + 1 ) * dy
    502           define_coarse_grid_real(9) = dz
     505          define_coarse_grid_real(3) = dx
     506          define_coarse_grid_real(4) = dy
     507          define_coarse_grid_real(5) = lower_left_coord_x + ( nx + 1 ) * dx
     508          define_coarse_grid_real(6) = lower_left_coord_y + ( ny + 1 ) * dy
     509          define_coarse_grid_real(7) = dz
    503510
    504511          define_coarse_grid_int(1)  = nx
     
    512519          yez = ( nbgp + 1 ) * dy
    513520          IF ( cl_coord_x(0) < define_coarse_grid_real(1) + xez )          nomatch = 1
    514           IF ( cl_coord_x(nx_cl + 1) > define_coarse_grid_real(7) - xez )  nomatch = 1
     521          IF ( cl_coord_x(nx_cl + 1) > define_coarse_grid_real(5) - xez )  nomatch = 1
    515522          IF ( cl_coord_y(0) < define_coarse_grid_real(2) + yez )          nomatch = 1
    516           IF ( cl_coord_y(ny_cl + 1) > define_coarse_grid_real(8) - yez )  nomatch = 1
     523          IF ( cl_coord_y(ny_cl + 1) > define_coarse_grid_real(6) - yez )  nomatch = 1
    517524
    518525          DEALLOCATE( cl_coord_x )
     
    521528!
    522529!--       Send coarse grid information to client
    523           CALL pmc_send_to_client( client_id, Define_coarse_grid_real, 9, 0,   &
     530          CALL pmc_send_to_client( client_id, Define_coarse_grid_real,         &
     531                                   SIZE(define_coarse_grid_real), 0,           &
    524532                                   21, ierr )
    525533          CALL pmc_send_to_client( client_id, Define_coarse_grid_int,  3, 0,   &
     
    553561!
    554562!--    Include couple arrays into server content
     563       CALL pmc_s_clear_next_array_list
    555564       DO  WHILE ( pmc_s_getnextarray( client_id, myname ) )
    556565          CALL pmci_set_array_pointer( myname, client_id = client_id,          &
     
    676685    IF ( .NOT. pmc_is_rootmodel() )  THEN
    677686       CALL pmc_clientinit
    678        
     687!
     688!--    Here and only here the arrays are defined, which actualy will be
     689!--    exchanged between client and server.
     690!--    Please check, if the arrays are in the list of possible exchange arrays
     691!--    in subroutines:
     692!--    pmci_set_array_pointer (for server arrays)
     693!--    pmci_create_client_arrays (for client arrays)
    679694       CALL pmc_set_dataarray_name( 'coarse', 'u'  ,'fine', 'u',  ierr )
    680695       CALL pmc_set_dataarray_name( 'coarse', 'v'  ,'fine', 'v',  ierr )
     
    709724!
    710725!--       Receive Coarse grid information.
    711           CALL pmc_recv_from_server( define_coarse_grid_real, 9, 0, 21, ierr )
     726          CALL pmc_recv_from_server( define_coarse_grid_real,                  &
     727                                     SIZE(define_coarse_grid_real), 0, 21, ierr )
    712728          CALL pmc_recv_from_server( define_coarse_grid_int,  3, 0, 22, ierr )
    713729
     
    719735          WRITE(0,*) 'startx_tot    = ',define_coarse_grid_real(1)
    720736          WRITE(0,*) 'starty_tot    = ',define_coarse_grid_real(2)
    721           WRITE(0,*) 'endx_tot      = ',define_coarse_grid_real(7)
    722           WRITE(0,*) 'endy_tot      = ',define_coarse_grid_real(8)
    723           WRITE(0,*) 'dx            = ',define_coarse_grid_real(5)
    724           WRITE(0,*) 'dy            = ',define_coarse_grid_real(6)
    725           WRITE(0,*) 'dz            = ',define_coarse_grid_real(9)
     737          WRITE(0,*) 'endx_tot      = ',define_coarse_grid_real(5)
     738          WRITE(0,*) 'endy_tot      = ',define_coarse_grid_real(6)
     739          WRITE(0,*) 'dx            = ',define_coarse_grid_real(3)
     740          WRITE(0,*) 'dy            = ',define_coarse_grid_real(4)
     741          WRITE(0,*) 'dz            = ',define_coarse_grid_real(7)
    726742          WRITE(0,*) 'nx_coarse     = ',define_coarse_grid_int(1)
    727743          WRITE(0,*) 'ny_coarse     = ',define_coarse_grid_int(2)
     
    729745       ENDIF
    730746
    731        CALL MPI_BCAST( define_coarse_grid_real, 9, MPI_REAL, 0, comm2d, ierr )
     747       CALL MPI_BCAST( define_coarse_grid_real, SIZE(define_coarse_grid_real), &
     748                       MPI_REAL, 0, comm2d, ierr )
    732749       CALL MPI_BCAST( define_coarse_grid_int, 3, MPI_INTEGER, 0, comm2d, ierr )
    733750
    734        cg%dx = define_coarse_grid_real(5)
    735        cg%dy = define_coarse_grid_real(6)
    736        cg%dz = define_coarse_grid_real(9)
     751       cg%dx = define_coarse_grid_real(3)
     752       cg%dy = define_coarse_grid_real(4)
     753       cg%dz = define_coarse_grid_real(7)
    737754       cg%nx = define_coarse_grid_int(1)
    738755       cg%ny = define_coarse_grid_int(2)
     
    778795!
    779796!--    Include couple arrays into client content.
     797       CALL  pmc_c_clear_next_array_list
    780798       DO  WHILE ( pmc_c_getnextarray( myname ) )
    781799!--       TO_DO: Klaus, why the c-arrays are still up to cg%nz??
     
    880898           ENDIF
    881899        ENDDO
    882 
    883         WRITE( 0, * )  'Coarse area ', myid, icl, icr, jcs, jcn
    884900
    885901        coarse_bound(1) = icl
     
    33973413!
    33983414!-- List of array names, which can be coupled
     3415!-- In case of 3D please change also the second array for the pointer version
    33993416    IF ( TRIM(name) == "u" )     p_3d => u
    34003417    IF ( TRIM(name) == "v" )     p_3d => v
     
    34033420    IF ( TRIM(name) == "pt" )    p_3d => pt
    34043421    IF ( TRIM(name) == "q" )     p_3d => q
    3405     !IF ( TRIM(name) == "z0" )    p_2d => z0
     3422!
     3423!-- This is just an example for a 2D array, not active for coupling
     3424!-- Please note, that z0 has to be declared as TARGET array in modules.f90
     3425!    IF ( TRIM(name) == "z0" )    p_2d => z0
    34063426
    34073427#if defined( __nopointer )
     
    34313451    IF ( TRIM(name) == "e" )     p_3d_sec => e_2
    34323452    IF ( TRIM(name) == "pt" )    p_3d_sec => pt_2
    3433     !IF ( TRIM(name) == "z0" )    p_2d_sec => z0_2
     3453    IF ( TRIM(name) == "q" )     p_3d_sec => q_2
    34343454
    34353455    IF ( ASSOCIATED( p_3d ) )  THEN
     
    34373457                                 array_2 = p_3d_sec )
    34383458    ELSEIF ( ASSOCIATED( p_2d ) )  THEN
    3439        CALL pmc_s_set_dataarray( client_id, p_2d, array_2 = p_2d_sec )
     3459       CALL pmc_s_set_dataarray( client_id, p_2d )
    34403460    ELSE
    34413461!
  • palm/trunk/SOURCE/pmc_mpi_wrapper.f90

    r1765 r1779  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! kind=dp replaced by wp
    2323!
    2424! Former revisions:
     
    5353   SAVE
    5454
    55 !-- TO_DO: what is the meaning of this? Could variables declared in this module
    56 !--        also have single precision?
    57 !   INTEGER, PARAMETER :: dp = wp
    58 
    59 
    60    ! INTERFACE section
    61 
    6255   INTERFACE PMC_Send_to_Server
    6356      MODULE PROCEDURE PMC_Send_to_Server_INTEGER
     
    159152
    160153   SUBROUTINE  PMC_Send_to_Server_real_r1 (buf, n, Server_rank, tag, ierr)
    161       IMPLICIT     none
    162 !--   TO_DO: has buf always to be of dp-kind, or can wp used here
    163 !--          this effects all respective declarations in this file
    164       REAL(kind=dp), DIMENSION(:), INTENT(IN)   :: buf
    165       INTEGER, INTENT(IN)                       :: n
    166       INTEGER, INTENT(IN)                       :: Server_rank
    167       INTEGER, INTENT(IN)                       :: tag
    168       INTEGER, INTENT(OUT)                      :: ierr
    169 
    170       ierr = 0
    171       CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr)
     154
     155      IMPLICIT     none
     156
     157      REAL(wp), DIMENSION(:), INTENT(IN) :: buf
     158      INTEGER, INTENT(IN)                :: n
     159      INTEGER, INTENT(IN)                :: Server_rank
     160      INTEGER, INTENT(IN)                :: tag
     161      INTEGER, INTENT(OUT)               :: ierr
     162
     163      ierr = 0
     164      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
    172165
    173166      return
     
    175168
    176169   SUBROUTINE  PMC_Recv_from_Server_real_r1 (buf, n, Server_rank, tag, ierr)
    177       IMPLICIT     none
    178       REAL(kind=dp), DIMENSION(:), INTENT(OUT)  :: buf
    179       INTEGER, INTENT(IN)                       :: n
    180       INTEGER, INTENT(IN)                       :: Server_rank
    181       INTEGER, INTENT(IN)                       :: tag
    182       INTEGER, INTENT(OUT)                      :: ierr
    183 
    184       ierr = 0
    185       CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, &
    186          MPI_STATUS_IGNORE, ierr)
     170
     171      IMPLICIT     none
     172
     173      REAL(wp), DIMENSION(:), INTENT(OUT) ::  buf
     174      INTEGER, INTENT(IN)                 ::  n
     175      INTEGER, INTENT(IN)                 ::  Server_rank
     176      INTEGER, INTENT(IN)                 ::  tag
     177      INTEGER, INTENT(OUT)                ::  ierr
     178
     179      ierr = 0
     180      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm,     &
     181                     MPI_STATUS_IGNORE, ierr)
    187182
    188183      return
     
    190185
    191186   SUBROUTINE  PMC_Send_to_Server_real_r2 (buf, n, Server_rank, tag, ierr)
    192       IMPLICIT     none
    193       REAL(kind=dp), DIMENSION(:,:), INTENT(IN) :: buf
    194       INTEGER, INTENT(IN)                       :: n
    195       INTEGER, INTENT(IN)                       :: Server_rank
    196       INTEGER, INTENT(IN)                       :: tag
    197       INTEGER, INTENT(OUT)                      :: ierr
    198 
    199       ierr = 0
    200       CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr)
     187
     188      IMPLICIT     none
     189
     190      REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf
     191      INTEGER, INTENT(IN)                  ::  n
     192      INTEGER, INTENT(IN)                  ::  Server_rank
     193      INTEGER, INTENT(IN)                  ::  tag
     194      INTEGER, INTENT(OUT)                 ::  ierr
     195
     196      ierr = 0
     197      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
    201198
    202199      return
     
    204201
    205202   SUBROUTINE  PMC_Recv_from_Server_real_r2 (buf, n, Server_rank, tag, ierr)
    206       IMPLICIT     none
    207       REAL(kind=dp), DIMENSION(:,:),INTENT(OUT) :: buf
    208       INTEGER, INTENT(IN)                       :: n
    209       INTEGER, INTENT(IN)                       :: Server_rank
    210       INTEGER, INTENT(IN)                       :: tag
    211       INTEGER, INTENT(OUT)                      :: ierr
    212 
    213       ierr = 0
    214       CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, &
     203
     204      IMPLICIT     none
     205
     206      REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf
     207      INTEGER, INTENT(IN)                   ::  n
     208      INTEGER, INTENT(IN)                   ::  Server_rank
     209      INTEGER, INTENT(IN)                   ::  tag
     210      INTEGER, INTENT(OUT)                  ::  ierr
     211
     212      ierr = 0
     213      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
    215214         MPI_STATUS_IGNORE, ierr)
    216215
     
    219218
    220219   SUBROUTINE  PMC_Send_to_Server_real_r3 (buf, n, Server_rank, tag, ierr)
    221       IMPLICIT     none
    222       REAL(kind=dp), DIMENSION(:,:,:), INTENT(IN) :: buf
    223       INTEGER, INTENT(IN)                         :: n
    224       INTEGER, INTENT(IN)                         :: Server_rank
    225       INTEGER, INTENT(IN)                         :: tag
    226       INTEGER, INTENT(OUT)                        :: ierr
    227 
    228       ierr = 0
    229       CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, ierr)
     220
     221      IMPLICIT     none
     222
     223      REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf
     224      INTEGER, INTENT(IN)                    ::  n
     225      INTEGER, INTENT(IN)                    ::  Server_rank
     226      INTEGER, INTENT(IN)                    ::  tag
     227      INTEGER, INTENT(OUT)                   ::  ierr
     228
     229      ierr = 0
     230      CALL MPI_Send (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, ierr)
    230231
    231232      return
     
    233234
    234235   SUBROUTINE  PMC_Recv_from_Server_real_r3 (buf, n, Server_rank, tag, ierr)
    235       IMPLICIT     none
    236       REAL(kind=dp), DIMENSION(:,:,:),INTENT(OUT) :: buf
    237       INTEGER, INTENT(IN)                         :: n
    238       INTEGER, INTENT(IN)                         :: Server_rank
    239       INTEGER, INTENT(IN)                         :: tag
    240       INTEGER, INTENT(OUT)                        :: ierr
    241 
    242       ierr = 0
    243       CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Server_rank, tag, m_to_server_comm, &
     236
     237      IMPLICIT     none
     238
     239      REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf
     240      INTEGER, INTENT(IN)                     ::  n
     241      INTEGER, INTENT(IN)                     ::  Server_rank
     242      INTEGER, INTENT(IN)                     ::  tag
     243      INTEGER, INTENT(OUT)                    ::  ierr
     244
     245      ierr = 0
     246      CALL MPI_Recv (buf, n, MPI_REAL, Server_rank, tag, m_to_server_comm, &
    244247         MPI_STATUS_IGNORE, ierr)
    245248
     
    296299
    297300   SUBROUTINE  PMC_Send_to_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
    298       IMPLICIT     none
    299       INTEGER, INTENT(IN)                       :: Client_id
    300       REAL(kind=dp), DIMENSION(:), INTENT(IN)   :: buf
    301       INTEGER, INTENT(IN)                       :: n
    302       INTEGER, INTENT(IN)                       :: Client_rank
    303       INTEGER, INTENT(IN)                       :: tag
    304       INTEGER, INTENT(OUT)                      :: ierr
    305 
    306       ierr = 0
    307       CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
     301
     302      IMPLICIT     none
     303
     304      INTEGER, INTENT(IN)                ::  Client_id
     305      REAL(wp), DIMENSION(:), INTENT(IN) ::  buf
     306      INTEGER, INTENT(IN)                ::  n
     307      INTEGER, INTENT(IN)                ::  Client_rank
     308      INTEGER, INTENT(IN)                ::  tag
     309      INTEGER, INTENT(OUT)               ::  ierr
     310
     311      ierr = 0
     312      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
    308313         ierr)
    309314
     
    312317
    313318   SUBROUTINE  PMC_Recv_from_Client_real_r1 (Client_id, buf, n, Client_rank, tag, ierr)
    314       IMPLICIT     none
    315       INTEGER, INTENT(IN)                       :: Client_id
    316       REAL(kind=dp), DIMENSION(:), INTENT(INOUT):: buf
    317       INTEGER, INTENT(IN)                       :: n
    318       INTEGER, INTENT(IN)                       :: Client_rank
    319       INTEGER, INTENT(IN)                       :: tag
    320       INTEGER, INTENT(OUT)                      :: ierr
    321 
    322       ierr = 0
    323       CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
     319
     320      IMPLICIT     none
     321
     322      INTEGER, INTENT(IN)                   ::  Client_id
     323      REAL(wp), DIMENSION(:), INTENT(INOUT) ::  buf
     324      INTEGER, INTENT(IN)                   ::  n
     325      INTEGER, INTENT(IN)                   ::  Client_rank
     326      INTEGER, INTENT(IN)                   ::  tag
     327      INTEGER, INTENT(OUT)                  ::  ierr
     328
     329      ierr = 0
     330      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
    324331         MPI_STATUS_IGNORE, ierr)
    325332
     
    328335
    329336   SUBROUTINE  PMC_Send_to_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
    330       IMPLICIT     none
    331       INTEGER, INTENT(IN)                       :: Client_id
    332       REAL(kind=dp), DIMENSION(:,:), INTENT(IN) :: buf
    333       INTEGER, INTENT(IN)                       :: n
    334       INTEGER, INTENT(IN)                       :: Client_rank
    335       INTEGER, INTENT(IN)                       :: tag
    336       INTEGER, INTENT(OUT)                      :: ierr
    337 
    338       ierr = 0
    339       CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
     337
     338      IMPLICIT     none
     339
     340      INTEGER, INTENT(IN)                  ::  Client_id
     341      REAL(wp), DIMENSION(:,:), INTENT(IN) ::  buf
     342      INTEGER, INTENT(IN)                  ::  n
     343      INTEGER, INTENT(IN)                  ::  Client_rank
     344      INTEGER, INTENT(IN)                  ::  tag
     345      INTEGER, INTENT(OUT)                 ::  ierr
     346
     347      ierr = 0
     348      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
    340349         ierr)
    341350
     
    344353
    345354   SUBROUTINE  PMC_Recv_from_Client_real_r2 (Client_id, buf, n, Client_rank, tag, ierr)
    346       IMPLICIT     none
    347       INTEGER, INTENT(IN)                       :: Client_id
    348       REAL(kind=dp), DIMENSION(:,:), INTENT(OUT):: buf
    349       INTEGER, INTENT(IN)                       :: n
    350       INTEGER, INTENT(IN)                       :: Client_rank
    351       INTEGER, INTENT(IN)                       :: tag
    352       INTEGER, INTENT(OUT)                      :: ierr
    353 
    354       ierr = 0
    355       CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
     355
     356      IMPLICIT     none
     357
     358      INTEGER, INTENT(IN)                   ::  Client_id
     359      REAL(wp), DIMENSION(:,:), INTENT(OUT) ::  buf
     360      INTEGER, INTENT(IN)                   ::  n
     361      INTEGER, INTENT(IN)                   ::  Client_rank
     362      INTEGER, INTENT(IN)                   ::  tag
     363      INTEGER, INTENT(OUT)                  ::  ierr
     364
     365      ierr = 0
     366      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
    356367         MPI_STATUS_IGNORE, ierr)
    357368
     
    360371
    361372   SUBROUTINE  PMC_Send_to_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
    362       IMPLICIT     none
    363       INTEGER, INTENT(IN)                         :: Client_id
    364       REAL(kind=dp), DIMENSION(:,:,:), INTENT(IN) :: buf
    365       INTEGER, INTENT(IN)                         :: n
    366       INTEGER, INTENT(IN)                         :: Client_rank
    367       INTEGER, INTENT(IN)                         :: tag
    368       INTEGER, INTENT(OUT)                        :: ierr
    369 
    370       ierr = 0
    371       CALL MPI_Send (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
     373
     374      IMPLICIT     none
     375
     376      INTEGER, INTENT(IN)                    ::  Client_id
     377      REAL(wp), DIMENSION(:,:,:), INTENT(IN) ::  buf
     378      INTEGER, INTENT(IN)                    ::  n
     379      INTEGER, INTENT(IN)                    ::  Client_rank
     380      INTEGER, INTENT(IN)                    ::  tag
     381      INTEGER, INTENT(OUT)                   ::  ierr
     382
     383      ierr = 0
     384      CALL MPI_Send (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
    372385         ierr)
    373386
     
    376389
    377390   SUBROUTINE  PMC_Recv_from_Client_real_r3 (Client_id, buf, n, Client_rank, tag, ierr)
    378       IMPLICIT     none
    379       INTEGER, INTENT(IN)                         :: Client_id
    380       REAL(kind=dp), DIMENSION(:,:,:), INTENT(OUT):: buf
    381       INTEGER, INTENT(IN)                         :: n
    382       INTEGER, INTENT(IN)                         :: Client_rank
    383       INTEGER, INTENT(IN)                         :: tag
    384       INTEGER, INTENT(OUT)                        :: ierr
    385 
    386       ierr = 0
    387       CALL MPI_Recv (buf, n, MPI_DOUBLE_PRECISION, Client_rank, tag, m_to_client_comm(Client_id), &
     391
     392      IMPLICIT     none
     393
     394      INTEGER, INTENT(IN)                     ::  Client_id
     395      REAL(wp), DIMENSION(:,:,:), INTENT(OUT) ::  buf
     396      INTEGER, INTENT(IN)                     :: n
     397      INTEGER, INTENT(IN)                     :: Client_rank
     398      INTEGER, INTENT(IN)                     :: tag
     399      INTEGER, INTENT(OUT)                    :: ierr
     400
     401      ierr = 0
     402      CALL MPI_Recv (buf, n, MPI_REAL, Client_rank, tag, m_to_client_comm(Client_id), &
    388403         MPI_STATUS_IGNORE, ierr)
    389404
  • palm/trunk/SOURCE/pmc_server.f90

    r1767 r1779  
    2020! Current revisions:
    2121! ------------------
    22 !
     22! kind=dp replaced by wp,
     23! error messages removed or changed to PALM style, dim_order removed
     24! array management changed from linked list to sequential loop
    2325!
    2426! Former revisions:
     
    5254   USE  kinds
    5355   USE  PMC_general,               ONLY: ClientDef, PMC_MAX_MODELL,PMC_sort, DA_NameDef, DA_Desclen, DA_Namelen,       &
    54                                          PMC_G_SetName, PMC_G_GetName, PeDef, ArrayDef
     56                                         PMC_G_SetName, PeDef, ArrayDef, PMC_MAX_ARRAY
    5557   USE  PMC_handle_communicator,   ONLY: m_model_comm,m_model_rank,m_model_npes, m_to_client_comm,                     &
    5658                                         PMC_Server_for_Client, m_world_rank
     
    7072   TYPE(ClientIndexDef),DIMENSION(PMC_MAX_MODELL)     :: indClients
    7173
     74   INTEGER                                            :: next_array_in_list = 0
     75
    7276   PUBLIC PMC_Server_for_Client
    73 
    74 !-- TO_DO: what is the meaning of this? Could variables declared in this module
    75 !--        also have single precision?
    76 !   INTEGER, PARAMETER :: dp = wp
    77 
    78    ! INTERFACE section
    7977
    8078   INTERFACE PMC_ServerInit
     
    8583        MODULE procedure PMC_S_Set_2D_index_list
    8684    END INTERFACE PMC_S_Set_2D_index_list
     85
     86    INTERFACE PMC_S_clear_next_array_list
     87        MODULE procedure PMC_S_clear_next_array_list
     88    END INTERFACE PMC_S_clear_next_array_list
    8789
    8890    INTERFACE PMC_S_GetNextArray
     
    115117    PUBLIC PMC_ServerInit, PMC_S_Set_2D_index_list, PMC_S_GetNextArray, PMC_S_Set_DataArray
    116118    PUBLIC PMC_S_setInd_and_AllocMem, PMC_S_FillBuffer, PMC_S_GetData_from_Buffer, PMC_S_Set_Active_data_array
     119    PUBLIC PMC_S_clear_next_array_list
    117120
    118121CONTAINS
     
    145148
    146149         ALLOCATE (Clients(ClientId)%PEs(Clients(ClientId)%inter_npes))
    147 
    148          do j=1,Clients(ClientId)%inter_npes                                ! Loop over all client PEs
    149            NULLIFY(Clients(ClientId)%PEs(j)%Arrays)
     150!
     151!--      Allocate for all client PEs an array of TYPE ArrayDef to store information of transfer array
     152         do j=1,Clients(ClientId)%inter_npes
     153           Allocate(Clients(ClientId)%PEs(j)%array_list(PMC_MAX_ARRAY))
    150154         end do
    151155
     
    219223    END SUBROUTINE PMC_S_Set_2D_index_list
    220224
    221     logical function PMC_S_GetNextArray (ClientId, myName,Client_PeIndex)
     225    SUBROUTINE PMC_S_clear_next_array_list
     226       IMPLICIT none
     227
     228       next_array_in_list = 0
     229
     230       return
     231    END SUBROUTINE PMC_S_clear_next_array_list
     232
     233!   List handling is still required to get minimal interaction with pmc_interface
     234    logical function PMC_S_GetNextArray (ClientId, myName)
     235       INTEGER(iwp),INTENT(IN)                    :: ClientId
     236       CHARACTER(len=*),INTENT(OUT)               :: myName
     237
     238!--    local variables
     239       TYPE(PeDef),POINTER          :: aPE
     240       TYPE(ArrayDef),POINTER       :: ar
     241
     242       next_array_in_list = next_array_in_list+1
     243
     244!--    Array Names are the same on all client PE, so take first PE to get the name
     245       aPE => Clients(ClientId)%PEs(1)
     246
     247       if(next_array_in_list > aPE%Nr_arrays) then
     248          PMC_S_GetNextArray = .false.              ! all arrays done
     249          return
     250       end if
     251
     252       ar  => aPE%array_list(next_array_in_list)
     253       myName = ar%name
     254
     255       PMC_S_GetNextArray =  .true.                 ! Return true if legal array
     256       return
     257    END function PMC_S_GetNextArray
     258
     259    SUBROUTINE PMC_S_Set_DataArray_2d (ClientId, array, array_2 )
     260
     261        IMPLICIT none
     262
    222263        INTEGER,INTENT(IN)                         :: ClientId
    223         CHARACTER(len=*),INTENT(OUT)               :: myName
    224 
    225         !-- local variables
    226         INTEGER                      :: MyCoupleIndex
    227         logical                      :: MyLast
    228         CHARACTER(len=DA_Namelen)    :: loName
    229         INTEGER,INTENT(IN),optional  :: Client_PeIndex
    230 
    231         loName = ' '
    232 
    233         CALL PMC_G_GetName (clients(ClientId), MyCoupleIndex, loName, MyLast, Client_PeIndex)
    234 
    235         myName    = loName
    236 
    237         PMC_S_GetNextArray = .NOT. MyLast                   ! Return true if valid array
    238 
    239         return
    240     END function PMC_S_GetNextArray
    241 
    242     SUBROUTINE PMC_S_Set_DataArray_2d (ClientId, array, array_2 )
    243         IMPLICIT none
    244         INTEGER,INTENT(IN)                         :: ClientId
    245 !--   TO_DO: has array always to be of dp-kind, or can wp used here
    246 !--          this effects all respective declarations in this file
    247         REAL(kind=dp),INTENT(IN),DIMENSION(:,:)           :: array
    248         REAL(kind=dp),INTENT(IN),DIMENSION(:,:),OPTIONAL  :: array_2
    249         !-- local variables
     264        REAL(wp), INTENT(IN), DIMENSION(:,:)           ::  array
     265        REAL(wp), INTENT(IN), DIMENSION(:,:), OPTIONAL ::  array_2
     266
    250267        INTEGER                           :: NrDims
    251268        INTEGER,DIMENSION (4)             :: dims
    252         INTEGER                           :: dim_order
    253269        TYPE(c_ptr)                       :: array_adr
    254270        TYPE(c_ptr)                       :: second_adr
     
    259275        dims(1)   = size(array,1)
    260276        dims(2)   = size(array,2)
    261         dim_order = 2
    262 
    263277        array_adr = c_loc(array)
    264278
    265279        IF ( PRESENT( array_2 ) )  THEN
    266280           second_adr = c_loc(array_2)
    267            CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr, second_adr = second_adr)
     281           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
    268282        ELSE
    269            CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr)
     283           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
    270284        ENDIF
    271285
     
    274288
    275289    SUBROUTINE PMC_S_Set_DataArray_3d (ClientId, array, nz_cl, nz, array_2 )
     290
    276291        IMPLICIT none
     292
    277293        INTEGER,INTENT(IN)                         :: ClientId
    278         REAL(kind=dp),INTENT(IN),DIMENSION(:,:,:)  :: array
    279         REAL(kind=dp),INTENT(IN),DIMENSION(:,:,:),OPTIONAL  :: array_2
     294        REAL(wp), INTENT(IN), DIMENSION(:,:,:)           :: array
     295        REAL(wp), INTENT(IN), DIMENSION(:,:,:), OPTIONAL :: array_2
    280296        INTEGER,INTENT(IN)                         :: nz_cl
    281297        INTEGER,INTENT(IN)                         :: nz
    282         !-- local variables
     298
    283299        INTEGER                           :: NrDims
    284300        INTEGER,DIMENSION (4)             :: dims
    285         INTEGER                           :: dim_order
    286301        TYPE(c_ptr)                       :: array_adr
    287302        TYPE(c_ptr)                       :: second_adr
     
    294309        dims(2)   = size(array,2)
    295310        dims(3)   = size(array,3)
    296         dim_order = 33
    297311        dims(4)   = nz_cl+dims(1)-nz                        ! works for first dimension 1:nz and 0:nz+1
    298312
     
    304318        IF ( PRESENT( array_2 ) )  THEN
    305319          second_adr = c_loc(array_2)
    306           CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr, second_adr = second_adr)
     320          CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr = second_adr)
    307321        ELSE
    308            CALL PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr)
     322           CALL PMC_S_SetArray (ClientId, NrDims, dims, array_adr)
    309323        ENDIF
    310324
     
    313327
    314328   SUBROUTINE PMC_S_setInd_and_AllocMem (ClientId)
     329
     330      USE control_parameters,                                                  &
     331          ONLY:  message_string
     332
    315333      IMPLICIT none
     334
    316335      INTEGER,INTENT(IN)                      :: ClientId
    317336
    318       INTEGER                                 :: i, istat, ierr
     337      INTEGER                                 :: i, istat, ierr, j
    319338      INTEGER                                 :: arlen, myIndex, tag
    320339      INTEGER                                 :: rCount                    ! count MPI requests
     
    337356         aPE => Clients(ClientId)%PEs(i)
    338357         tag = 200
    339          do while (PMC_S_GetNextArray ( ClientId, myName,i))
    340             ar  => aPE%Arrays
    341             if(ar%dim_order == 2) then
     358         do j=1,aPE%Nr_arrays
     359            ar  => aPE%array_list(j)
     360            if(ar%NrDims == 2) then
    342361               arlen     = aPE%NrEle;                             ! 2D
    343             else if(ar%dim_order == 33) then
     362            else if(ar%NrDims == 3) then
    344363               arlen     = aPE%NrEle * ar%A_dim(4);               ! PALM 3D
    345364            else
     
    382401      do i=1,Clients(ClientId)%inter_npes
    383402         aPE => Clients(ClientId)%PEs(i)
    384          do while (PMC_S_GetNextArray ( ClientId, myName,i))
    385             ar  => aPE%Arrays
     403         do j=1,aPE%Nr_arrays
     404            ar  => aPE%array_list(j)
    386405!--         TO_DO:  Adressrechnung ueberlegen?
    387406            ar%SendBuf = c_loc(base_array(ar%BufIndex))                         !kk Adressrechnung ueberlegen
    388407            if(ar%BufIndex+ar%BufSize > bufsize) then
    389408!--            TO_DO: can this error really happen, and what can be the reason?
    390                write(0,'(a,i4,4i7,1x,a)') 'Buffer too small ',i,ar%BufIndex,ar%BufSize,ar%BufIndex+ar%BufSize,bufsize,trim(myName)
     409               write(0,'(a,i4,4i7,1x,a)') 'Buffer too small ',i,ar%BufIndex,ar%BufSize,ar%BufIndex+ar%BufSize,bufsize,trim(ar%name)
    391410               CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr)
    392411            end if
     
    399418   SUBROUTINE PMC_S_FillBuffer (ClientId, WaitTime)
    400419      IMPLICIT none
    401       INTEGER,INTENT(IN)                      :: ClientId
    402       REAL(kind=dp),INTENT(OUT),optional      :: WaitTime
    403 
    404       !-- local variables
    405       INTEGER                                 :: ip,ij,istat,ierr
    406       INTEGER                                 :: myIndex
    407       REAL(kind=dp)                           :: t1,t2
    408       TYPE(PeDef),POINTER                     :: aPE
    409       TYPE(ArrayDef),POINTER                  :: ar
    410       CHARACTER(len=DA_Namelen)               :: myName
    411       INTEGER,DIMENSION(1)                    :: buf_shape
    412       REAL(kind=wp),POINTER,DIMENSION(:)      :: buf
    413       REAL(kind=wp),POINTER,DIMENSION(:,:)    :: data_2d
    414       REAL(kind=wp),POINTER,DIMENSION(:,:,:)  :: data_3d
     420      INTEGER,INTENT(IN)                  ::  ClientId
     421      REAL(wp), INTENT(OUT), OPTIONAL     ::  WaitTime
     422
     423      INTEGER                             ::  ip,ij,istat,ierr,j
     424      INTEGER                             ::  myIndex
     425      REAL(wp)                            ::  t1,t2
     426      TYPE(PeDef),POINTER                 ::  aPE
     427      TYPE(ArrayDef),POINTER              ::  ar
     428      CHARACTER(len=DA_Namelen)           ::  myName
     429      INTEGER,DIMENSION(1)                ::  buf_shape
     430      REAL(wp), POINTER, DIMENSION(:)     ::  buf
     431      REAL(wp), POINTER, DIMENSION(:,:)   ::  data_2d
     432      REAL(wp), POINTER, DIMENSION(:,:,:) ::  data_3d
    415433
    416434      t1 = PMC_Time()
     
    421439      do ip=1,Clients(ClientId)%inter_npes
    422440         aPE => Clients(ClientId)%PEs(ip)
    423          do while (PMC_S_GetNextArray ( ClientId, myName,ip))
    424             ar  => aPE%Arrays
     441         do j=1,aPE%Nr_arrays
     442            ar  => aPE%array_list(j)
    425443            myIndex=1
    426             if(ar%dim_order == 2) then
     444            if(ar%NrDims == 2) then
    427445               buf_shape(1) = aPE%NrEle
    428446               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
     
    432450                  myIndex = myIndex+1
    433451               end do
    434             else if(ar%dim_order == 33) then
     452            else if(ar%NrDims == 3) then
    435453               buf_shape(1) = aPE%NrEle*ar%A_dim(4)
    436454               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
     
    440458                  myIndex = myIndex+ar%A_dim(4)
    441459               end do
    442             else
    443 !--            TO_DO: can this error really happen, and what can be the reason?
    444                write(0,*) "Illegal Order of Dimension ",ar%dim_order
    445                CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr);
    446 
    447460            end if
    448461          end do
    449462      end do
    450463
    451       CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)              ! buffer is full
     464      CALL MPI_Barrier(Clients(ClientId)%intra_comm, ierr)    ! buffer is full
    452465
    453466      return
     
    455468
    456469   SUBROUTINE PMC_S_GetData_from_Buffer (ClientId, WaitTime)
     470
    457471      IMPLICIT none
    458       INTEGER,INTENT(IN)                      :: ClientId
    459       REAL(kind=dp),INTENT(OUT),optional      :: WaitTime
     472
     473      INTEGER,INTENT(IN)                  ::  ClientId
     474      REAL(wp), INTENT(OUT), OPTIONAL     ::  WaitTime
    460475
    461476      !-- local variables
    462       INTEGER                                 :: ip,ij,istat,ierr
    463       INTEGER                                 :: myIndex
    464       REAL(kind=dp)                           :: t1,t2
    465       TYPE(PeDef),POINTER                     :: aPE
    466       TYPE(ArrayDef),POINTER                  :: ar
    467       CHARACTER(len=DA_Namelen)               :: myName
    468       INTEGER,DIMENSION(1)                    :: buf_shape
    469       REAL(kind=wp),POINTER,DIMENSION(:)      :: buf
    470       REAL(kind=wp),POINTER,DIMENSION(:,:)    :: data_2d
    471       REAL(kind=wp),POINTER,DIMENSION(:,:,:)  :: data_3d
     477      INTEGER                             ::  ip,ij,istat,ierr,j
     478      INTEGER                             :: myIndex
     479      REAL(wp)                            :: t1,t2
     480      TYPE(PeDef),POINTER                 :: aPE
     481      TYPE(ArrayDef),POINTER              :: ar
     482      CHARACTER(len=DA_Namelen)           :: myName
     483      INTEGER,DIMENSION(1)                :: buf_shape
     484      REAL(wp), POINTER, DIMENSION(:)     :: buf
     485      REAL(wp), POINTER, DIMENSION(:,:)   :: data_2d
     486      REAL(wp), POINTER, DIMENSION(:,:,:) :: data_3d
    472487
    473488      t1 = PMC_Time()
     
    478493      do ip=1,Clients(ClientId)%inter_npes
    479494         aPE => Clients(ClientId)%PEs(ip)
    480          do while (PMC_S_GetNextArray ( ClientId, myName,ip))
    481             ar  => aPE%Arrays
     495         do j=1,aPE%Nr_arrays
     496            ar  => aPE%array_list(j)
    482497            myIndex=1
    483             if(ar%dim_order == 2) then
     498            if(ar%NrDims == 2) then
    484499               buf_shape(1) = aPE%NrEle
    485500               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
     
    489504                  myIndex = myIndex+1
    490505               end do
    491             else if(ar%dim_order == 33) then
     506            else if(ar%NrDims == 3) then
    492507               buf_shape(1) = aPE%NrEle*ar%A_dim(4)
    493508               CALL c_f_pointer(ar%SendBuf, buf, buf_shape)
     
    497512                  myIndex = myIndex+ar%A_dim(4)
    498513               end do
    499             else
    500 !--            TO_DO: can this error really happen, and what can be the reason?
    501                write(0,*) "Illegal Order of Dimension ",ar%dim_order
    502                CALL MPI_Abort (MPI_COMM_WORLD, istat, ierr);
    503 
    504514            end if
    505515          end do
     
    535545   END SUBROUTINE Get_DA_names_from_client
    536546
    537    SUBROUTINE PMC_S_SetArray (ClientId, NrDims, dims, dim_order, array_adr, second_adr)
     547   SUBROUTINE PMC_S_SetArray (ClientId, NrDims, dims, array_adr, second_adr)
    538548      IMPLICIT none
    539549
     
    541551      INTEGER,INTENT(IN)                      :: NrDims
    542552      INTEGER,INTENT(IN),DIMENSION(:)         :: dims
    543       INTEGER,INTENT(IN)                      :: dim_order
    544553      TYPE(c_ptr),INTENT(IN)                  :: array_adr
    545554      TYPE(c_ptr),INTENT(IN),OPTIONAL         :: second_adr
     
    554563       do i=1,Clients(ClientId)%inter_npes
    555564          aPE => Clients(ClientId)%PEs(i)
    556           ar  => aPE%Arrays
     565          ar  => aPE%array_list(next_array_in_list)
    557566          ar%NrDims    = NrDims
    558567          ar%A_dim     = dims
    559           ar%dim_order = dim_order
    560568          ar%data      = array_adr
    561569          if(present(second_adr)) then
     
    579587
    580588!--   local variables
    581       INTEGER                                 :: i, ip
     589      INTEGER                                 :: i, ip, j
    582590      TYPE(PeDef),POINTER                     :: aPE
    583591      TYPE(ArrayDef),POINTER                  :: ar
     
    586594      do ip=1,Clients(ClientId)%inter_npes
    587595         aPE => Clients(ClientId)%PEs(ip)
    588          do while (PMC_S_GetNextArray ( ClientId, myName,ip))
    589             ar  => aPE%Arrays
     596         do j=1,aPE%Nr_arrays
     597            ar  => aPE%array_list(j)
    590598            if(iactive == 1 .OR. iactive == 2)   then
    591599               ar%data = ar%po_data(iactive)
Note: See TracChangeset for help on using the changeset viewer.