Patch Detail
get:
Show a patch.
patch:
Update a patch.
put:
Update a patch.
GET /api/patches/2195308/?format=api
{ "id": 2195308, "url": "http://patchwork.ozlabs.org/api/patches/2195308/?format=api", "web_url": "http://patchwork.ozlabs.org/project/gcc/patch/455a1bbe-05e5-4c55-b54c-2ccd787c8c25@gmail.com/", "project": { "id": 17, "url": "http://patchwork.ozlabs.org/api/projects/17/?format=api", "name": "GNU Compiler Collection", "link_name": "gcc", "list_id": "gcc-patches.gcc.gnu.org", "list_email": "gcc-patches@gcc.gnu.org", "web_url": null, "scm_url": null, "webscm_url": null, "list_archive_url": "", "list_archive_url_format": "", "commit_url_format": "" }, "msgid": "<455a1bbe-05e5-4c55-b54c-2ccd787c8c25@gmail.com>", "list_archive_url": null, "date": "2026-02-10T18:08:50", "name": "[5/13] Coarray shared memory library", "commit_ref": null, "pull_url": null, "state": "new", "archived": false, "hash": "41bc3571bfefb2c4ad812741354fa57a4182ecce", "submitter": { "id": 78264, "url": "http://patchwork.ozlabs.org/api/people/78264/?format=api", "name": "Jerry D", "email": "jvdelisle2@gmail.com" }, "delegate": null, "mbox": "http://patchwork.ozlabs.org/project/gcc/patch/455a1bbe-05e5-4c55-b54c-2ccd787c8c25@gmail.com/mbox/", "series": [ { "id": 491719, "url": "http://patchwork.ozlabs.org/api/series/491719/?format=api", "web_url": "http://patchwork.ozlabs.org/project/gcc/list/?series=491719", "date": "2026-02-10T17:55:35", "name": "[1/13] Coarray shared memory library", "version": 1, "mbox": "http://patchwork.ozlabs.org/series/491719/mbox/" } ], "comments": "http://patchwork.ozlabs.org/api/patches/2195308/comments/", "check": "pending", "checks": "http://patchwork.ozlabs.org/api/patches/2195308/checks/", "tags": {}, "related": [], "headers": { "Return-Path": "<gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org>", "X-Original-To": [ "incoming@patchwork.ozlabs.org", "gcc-patches@gcc.gnu.org" ], "Delivered-To": [ "patchwork-incoming@legolas.ozlabs.org", "gcc-patches@gcc.gnu.org" ], "Authentication-Results": [ "legolas.ozlabs.org;\n\tdkim=pass (2048-bit key;\n unprotected) header.d=gmail.com header.i=@gmail.com header.a=rsa-sha256\n header.s=20230601 header.b=PYsSiESO;\n\tdkim-atps=neutral", "legolas.ozlabs.org;\n spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org\n (client-ip=2620:52:6:3111::32; helo=vm01.sourceware.org;\n envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org;\n receiver=patchwork.ozlabs.org)", "sourceware.org;\n\tdkim=pass (2048-bit key,\n unprotected) header.d=gmail.com header.i=@gmail.com header.a=rsa-sha256\n header.s=20230601 header.b=PYsSiESO", "sourceware.org;\n dmarc=pass (p=none dis=none) header.from=gmail.com", "sourceware.org; spf=pass smtp.mailfrom=gmail.com", "server2.sourceware.org;\n arc=none smtp.remote-ip=209.85.214.172" ], "Received": [ "from vm01.sourceware.org (vm01.sourceware.org\n [IPv6:2620:52:6:3111::32])\n\t(using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)\n\t key-exchange x25519 server-signature ECDSA (secp384r1) server-digest SHA384)\n\t(No client certificate requested)\n\tby legolas.ozlabs.org (Postfix) with ESMTPS id 4f9V2f5y5wz1xwG\n\tfor <incoming@patchwork.ozlabs.org>; Wed, 11 Feb 2026 05:09:46 +1100 (AEDT)", "from vm01.sourceware.org (localhost [127.0.0.1])\n\tby sourceware.org (Postfix) with ESMTP id ADA174BA23C3\n\tfor <incoming@patchwork.ozlabs.org>; Tue, 10 Feb 2026 18:09:39 +0000 (GMT)", "from mail-pl1-f172.google.com (mail-pl1-f172.google.com\n [209.85.214.172])\n by sourceware.org (Postfix) with ESMTPS id ED37D4BA543C\n for <gcc-patches@gcc.gnu.org>; Tue, 10 Feb 2026 18:08:53 +0000 (GMT)", "by mail-pl1-f172.google.com with SMTP id\n d9443c01a7336-2a90055b9e9so25272515ad.1\n for <gcc-patches@gcc.gnu.org>; Tue, 10 Feb 2026 10:08:53 -0800 (PST)", "from [10.168.168.23] ([50.37.179.80])\n by smtp.gmail.com with ESMTPSA id\n d9443c01a7336-2aadeb4d345sm89534125ad.54.2026.02.10.10.08.50\n (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128);\n Tue, 10 Feb 2026 10:08:51 -0800 (PST)" ], "DKIM-Filter": [ "OpenDKIM Filter v2.11.0 sourceware.org ADA174BA23C3", "OpenDKIM Filter v2.11.0 sourceware.org ED37D4BA543C" ], "DMARC-Filter": "OpenDMARC Filter v1.4.2 sourceware.org ED37D4BA543C", "ARC-Filter": "OpenARC Filter v1.0.0 sourceware.org ED37D4BA543C", "ARC-Seal": "i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1770746934; cv=none;\n b=K4AhtU+rbPa8ycNscu3ebCp53mBHEvhQn382odWsAvmPdZ+d7s7S3a9S1k2KqN1Cn1UZbfP/4FBX0K5yHR5rt2fQ9mPdCJ7BB4EY5EbEJyzGXitAsswr70IZTlK2kXAXPj8LoOm38EQH6ou1BbjvOqk1xkqihWo2FFNgcwUfVi0=", "ARC-Message-Signature": "i=1; a=rsa-sha256; d=sourceware.org; s=key;\n t=1770746934; c=relaxed/simple;\n bh=D7i8gYq6DMOWild62N+OOzPUoP3Lujpeh0Mci8GZHGM=;\n h=DKIM-Signature:Message-ID:Date:MIME-Version:To:From:Subject;\n b=pGW2lflzoWqGQeYT7vAdv1egD6nApBR2lPU0HYSKge8/R671Nu5NEswjyHcqmqrjR1d44ymAS4iWZbuQSCj4q+RvRPSwIQTlfs/aLdp/HC3y/b+gBI3yUb4OcKK90D2MHqXkBRKI1AEhz85Ms220r4QOgeUDhLMCBU8viF4DlOI=", "ARC-Authentication-Results": "i=1; server2.sourceware.org", "DKIM-Signature": "v=1; a=rsa-sha256; c=relaxed/relaxed;\n d=gmail.com; s=20230601; t=1770746933; x=1771351733; darn=gcc.gnu.org;\n h=autocrypt:subject:from:cc:to:content-language:user-agent\n :mime-version:date:message-id:from:to:cc:subject:date:message-id\n :reply-to; bh=D7i8gYq6DMOWild62N+OOzPUoP3Lujpeh0Mci8GZHGM=;\n b=PYsSiESOtEOyfN0L29A1rPThH8GH4HEJXr1IqVIKQ39GMqzLcw/hIWh96p9mAQSIQ8\n HuGQhNqhkCtaEUsP2blQCPBU9TF4YZ9Oq5nt688Sh9dFELtyl2odNj+qDJYeYwSByQeG\n LrNX4xhh+B7COt4tZ/eZ8NJFBnWBsowd+yyuJts2nhPKNxJv0nu0ilcvAQdMm4FeMSSC\n 5nUGb8PscJX7DUHt6D9Ssq2OQdsVENjAnR2cVcez10Cv8ibt5sdnwdz3I9u+QL7p3y/f\n 4y76nxZn521NzvnmaucVVX70Vzje1yEoJHvpS6XDc8puqcVUOtAdwTCojQZVhbwXqx8B\n qgPg==", "X-Google-DKIM-Signature": "v=1; a=rsa-sha256; c=relaxed/relaxed;\n d=1e100.net; s=20230601; t=1770746933; x=1771351733;\n h=autocrypt:subject:from:cc:to:content-language:user-agent\n :mime-version:date:message-id:x-gm-gg:x-gm-message-state:from:to:cc\n :subject:date:message-id:reply-to;\n bh=D7i8gYq6DMOWild62N+OOzPUoP3Lujpeh0Mci8GZHGM=;\n b=kuyRbSmyda2UfH0mJ3lqnf+hbMtpjTh6+7Jhtl+D9kpU91paP7/XPXEp+kXXA1shCn\n E+bpRvIHj/vN1aCFx3zKUitF1C9CBpIkb2C8sVh1Vl6Apq82jU2c4UHQRso/RJYlA3GR\n jIQhnjyfAYaaorWJPrCIyZ82e9JOy6mZieQPpN0uZ2gpDD7lly9488mw2Na5wrlg5qJL\n 1sVSKrs+/fPz81pb45bsiAkIOKftEyHfQRdYGb/JicrT5mJD7mT/q3bGo5QDnj37oPvb\n Jd8u/sQxGfPVdtPO1j5dWZjre+pEoUXnuaFVx2waezwtlkQB/0wELUCfr7a59o2TwJEg\n ncaw==", "X-Forwarded-Encrypted": "i=1;\n AJvYcCUMEZDPKvnHRDn1RaEDRur/lyvGyu2KXjkyeoQ5fi3eNqxdVI3TL4/gTeIKXKGAljQ3h/17LKbSri/o8w==@gcc.gnu.org", "X-Gm-Message-State": "AOJu0YwRX3nCzCdqPq8kZSoQ1FV9+aFgO1U7A1cFnFgLqnacSU0oasEC\n /gwfluv0xvobYLoEZ7KWn/BPtxkZZXUU7rL7VT1C/4rusv/s1Nd2EJ3B", "X-Gm-Gg": "AZuq6aK3asm5y98dkEQrXyvVrO0q/YurXUgUn/1LrF60uA4FrV4zs7NRmv23idpSYBJ\n RfhFrbmsJ6mpwcEkIqyFOQQT97heI8k82th/rl0ThdxWUl+dZBERlUNrIMjzQeXlSnPiz+uBbta\n 3bipupmJRWNUyTSrxFH60CvDGxYdVLW7ygyPCXI8ibaJPAPPTldQyZtEzP5NRJB7+VRPlZxeqGk\n VDLMZ5dMbRrm+CGlIzEKjMnulBd8S0JprLXdKVy3byDgWc/R+eTuDAhWpQjVteymQaIOhzMFHRj\n xhmGQt7kJvhU9sx/3KOOizpOYljACJBLogur8T8wiU+6IHywK8jkc4+NEWg+5zqatAzzPiCv464\n cnMN8P7i+2vEHCU9PHpbcs9na0Ifc3OkmsoSJQU3Ok28x17p/hTYv4w9mw/5VRbusQ33kwWKdJ4\n yLwC+EmW8kkxHlAme2MSehWglbRQI=", "X-Received": "by 2002:a17:903:230d:b0:2a9:4369:6426 with SMTP id\n d9443c01a7336-2a952284edbmr157501245ad.57.1770746932224;\n Tue, 10 Feb 2026 10:08:52 -0800 (PST)", "Content-Type": "multipart/mixed; boundary=\"------------hqazJH58kWOW6K7hsY9KC2T0\"", "Message-ID": "<455a1bbe-05e5-4c55-b54c-2ccd787c8c25@gmail.com>", "Date": "Tue, 10 Feb 2026 10:08:50 -0800", "MIME-Version": "1.0", "User-Agent": "Mozilla Thunderbird", "Content-Language": "en-US", "To": "gfortran <fortran@gcc.gnu.org>, gcc-patches <gcc-patches@gcc.gnu.org>", "Cc": "Tobias Burnus <tburnus@baylibre.com>, Richard Biener <rguenther@suse.de>,\n Andre Vehreschild <vehre@gmx.de>, Jakub Jelinek <jakub@redhat.com>,\n Paul Richard Thomas <paul.richard.thomas@gmail.com>,\n FX Coudert <fxcoudert@gmail.com>, Toon Moene <toon@moene.org>", "From": "Jerry D <jvdelisle2@gmail.com>", "Subject": "[PATCH 5/13] Coarray shared memory library", "Autocrypt": "addr=jvdelisle2@gmail.com; keydata=\n xjMEY5TlkxYJKwYBBAHaRw8BAQdAyrkRDhmJhSTTlV/50gJLlvliU6/Lm5C9ViKV8T9y1GnN\n HkplcnJ5IEQgPGp2ZGVsaXNsZTJAZ21haWwuY29tPsKJBBMWCAAxFiEEOFR0TS0390uh8dRV\n uWXAJaWpwWoFAmOU5ZMCGwMECwkIBwUVCAkKCwUWAgMBAAAKCRC5ZcAlpanBalsJAP4wdCiH\n 2Of9oZv1QWgZ/AVdbWFM3Fv47/WZQHOXfoZ9HgD6AkXrKeJ+6usST7PEaDJjptaViT1fLiYY\n V/6XaOKSsgLOOARjlOWTEgorBgEEAZdVAQUBAQdAdA7PczYnl07vnOT9oP/wvvMDd4HP09Zl\n g3LzwXQJWT8DAQgHwngEGBYIACAWIQQ4VHRNLTf3S6Hx1FW5ZcAlpanBagUCY5TlkwIbDAAK\n CRC5ZcAlpanBasF/AQCa5WjlsVpLsEiggZyT18MOJNAdeRd7wkGDUrwedHrvawD/cE1H+/Ms\n L1ZwvQiLfGdx8crigQqWTQyos4kH8Wx82wc=", "X-BeenThere": "gcc-patches@gcc.gnu.org", "X-Mailman-Version": "2.1.30", "Precedence": "list", "List-Id": "Gcc-patches mailing list <gcc-patches.gcc.gnu.org>", "List-Unsubscribe": "<https://gcc.gnu.org/mailman/options/gcc-patches>,\n <mailto:gcc-patches-request@gcc.gnu.org?subject=unsubscribe>", "List-Archive": "<https://gcc.gnu.org/pipermail/gcc-patches/>", "List-Post": "<mailto:gcc-patches@gcc.gnu.org>", "List-Help": "<mailto:gcc-patches-request@gcc.gnu.org?subject=help>", "List-Subscribe": "<https://gcc.gnu.org/mailman/listinfo/gcc-patches>,\n <mailto:gcc-patches-request@gcc.gnu.org?subject=subscribe>", "Errors-To": "gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org" }, "content": "Dear all, as requested,\n\nSee attached patch 5 of 13\n\nBest Regards,\n\nJerry", "diff": "commit f20950d986c83c2a3a2d108cc5bd499c7930370f\nAuthor: Andre Vehreschild <vehre@gcc.gnu.org>\nDate: Tue Apr 29 16:19:45 2025 +0200\n\n Fortran: Add a shared memory multi process coarray implementation [PR88076]\n \n Add caf_shmem, a shared memory multi process coarray implementation. The\n library adheres to the existing coarray ABI and is controlled by some\n environment variables for selecting the number of images and virtual\n memory size (see invoke.texi).\n \n Co-authored by: Thomas Koenig <tkoenig@gcc.gnu.org>\n Nicolas Koenig <koenigni@gcc.gnu.org>\n \n PR fortran/88076\n \n gcc/fortran/ChangeLog:\n \n * invoke.texi: Add description for use.\n \n libgfortran/ChangeLog:\n \n * caf/libcaf.h (LIBCAF_H): Remove unused header inclusions.\n * caf/caf_error.c: New file.\n * caf/caf_error.h: New file.\n * caf/shmem.c: New file.\n * caf/shmem/alloc.c: New file.\n * caf/shmem/alloc.h: New file.\n * caf/shmem/allocator.c: New file.\n * caf/shmem/allocator.h: New file.\n * caf/shmem/collective_subroutine.c: New file.\n * caf/shmem/collective_subroutine.h: New file.\n * caf/shmem/counter_barrier.c: New file.\n * caf/shmem/counter_barrier.h: New file.\n * caf/shmem/hashmap.c: New file.\n * caf/shmem/hashmap.h: New file.\n * caf/shmem/shared_memory.c: New file.\n * caf/shmem/shared_memory.h: New file.\n * caf/shmem/supervisor.c: New file.\n * caf/shmem/supervisor.h: New file.\n * caf/shmem/sync.c: New file.\n * caf/shmem/sync.h: New file.\n * caf/shmem/teams_mgmt.c: New file.\n * caf/shmem/teams_mgmt.h: New file.\n * caf/shmem/thread_support.c: New file.\n * caf/shmem/thread_support.h: New file.\n\ndiff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi\nindex 549c45032fd..6e8e13a982b 100644\n--- a/gcc/fortran/invoke.texi\n+++ b/gcc/fortran/invoke.texi\n@@ -104,6 +104,7 @@ one is not the default.\n * Interoperability Options:: Options for interoperability with other\n languages.\n * Environment Variables:: Environment variables that affect @command{gfortran}.\n+* Shared Memory Coarrays:: Multi process shared memory coarray support.\n @end menu\n \n @node Option Summary\n@@ -2305,3 +2306,56 @@ variables.\n @xref{Runtime}, for environment variables that affect the\n run-time behavior of programs compiled with GNU Fortran.\n @c man end\n+\n+@node Shared Memory Coarrays\n+@section Shared Memory Coarrays\n+\n+@c man begin SHARED MEMORY COARRAYS\n+\n+@command{gfortran} supplies a runtime library for running coarray enabled\n+programs using a shared memory multi process approach. The library is supplied\n+as a static link library with the @command{libgfortran} library and is fully\n+compatible with the ABI enabled when @command{gfortran} is called with\n+@code{-fcoarray=lib}. The shared memory coarray library then just needs to be\n+linked to the executable produced by @command{gfortran} using\n+@code{-lcaf_shmem}.\n+\n+The library @code{caf_shmem} can only be used on architectures that allow\n+multiple processes to use the same memory at the same virtual memory address in\n+each process' memory space. This is the case on most Unix and Windows based\n+systems.\n+\n+The resulting executable can be started without any driver and does not provide\n+any additional command line options. Limited control is possible by\n+environment variables:\n+\n+@env{GFORTRAN_NUM_IMAGES}: The number of images to spawn when running the\n+executable. Note, there will always be one additional supervisor process, which\n+does not participate in the computation, but is only responsible for starting\n+the images and catching any (ab-)normal termination. When the environment\n+variable is not set, then the number of hardware threads reported by the OS will\n+be taken. Over-provisioning is possible. The number of images is limited only\n+by the OS and the size of an integer variable on the architecture the program is\n+to be run on.\n+\n+@env{GFORTRAN_SHARED_MEMORY_SIZE}: The size of the shared memory segment made\n+available to all images is fixed and needs to be set at program start. It can\n+not grow or shrink. The size can be given in bytes (no suffix), kilobytes\n+(@code{k} or @code{K} suffix), megabytes (@code{m} or @code{M}) or gigabytes\n+(@code{g} or @code{G}). If the variable is not set, or not parseable, then on\n+32-bit architectures 2^28 bytes and on 64-bit 2^34 bytes are choosen. Note,\n+although the size is set, most modern systems do not allocate the memory at\n+program start. This allows to choose a shared memory size larger than available\n+memory.\n+\n+Warning: Choosing a large shared memory size may produce large coredumps!\n+\n+The shared memory coarray library internally uses some additional environment\n+variables, which will be overwritten without notice or may result in failure to\n+start. These are: @code{GFORTRAN_IMAGE_NUM}, @code{GFORTRAN_SHMEM_PID} and\n+@code{GFORTRAN_SHMEM_BASE}. It is strongly discouraged to use these variables.\n+Special care needs to be taken, when one coarray program starts another coarray\n+program as a child process. In this case it is the spawning process'\n+responsibility to remove above variables from the environment.\n+\n+@c man end\ndiff --git a/libgfortran/caf/caf_error.c b/libgfortran/caf/caf_error.c\nnew file mode 100644\nindex 00000000000..a8f3bf7f189\n--- /dev/null\n+++ b/libgfortran/caf/caf_error.c\n@@ -0,0 +1,71 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#include \"caf_error.h\"\n+\n+#include <stdarg.h>\n+#include <stdio.h>\n+#include <stdlib.h>\n+#include <string.h>\n+\n+static void\n+internal_caf_runtime_error (const char *format, va_list args)\n+{\n+ fprintf (stderr, \"Fortran runtime error: \");\n+ vfprintf (stderr, format, args);\n+ fprintf (stderr, \"\\n\");\n+\n+ exit (EXIT_FAILURE);\n+}\n+\n+void\n+caf_runtime_error (const char *format, ...)\n+{\n+ va_list ap;\n+ va_start (ap, format);\n+ internal_caf_runtime_error (format, ap);\n+}\n+\n+void\n+caf_internal_error (const char *format, int *stat, char *errmsg,\n+\t\t size_t errmsg_len, ...)\n+{\n+ va_list args;\n+ va_start (args, errmsg_len);\n+ if (stat)\n+ {\n+ *stat = 1;\n+ if (errmsg_len > 0)\n+\t{\n+\t int len = vsnprintf (errmsg, errmsg_len, format, args);\n+\t if (len >= 0 && errmsg_len > (size_t) len)\n+\t memset (&errmsg[len], ' ', errmsg_len - len);\n+\t}\n+ va_end (args);\n+ return;\n+ }\n+ else\n+ internal_caf_runtime_error (format, args);\n+ va_end (args);\n+}\ndiff --git a/libgfortran/caf/caf_error.h b/libgfortran/caf/caf_error.h\nnew file mode 100644\nindex 00000000000..15455377eb0\n--- /dev/null\n+++ b/libgfortran/caf/caf_error.h\n@@ -0,0 +1,44 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#ifndef CAF_ERROR_H\n+#define CAF_ERROR_H\n+\n+#include <stddef.h>\n+\n+/* Emit a printf style error message and exit with EXIT_FAILURE. */\n+\n+void caf_runtime_error (const char *format, ...);\n+\n+/* If `stat` is given, it will be set to 1 and procedure returns to the caller.\n+ If additionally `errmsg` is non-NULL, then printf-style `format` will by\n+ printed to `errmsg`. If the resulting message is longer then `errmsg_len`,\n+ it will be truncated, else filled with spaces.\n+ If `stat` is not given, then the printf-formated message will be emited to\n+ stderr and the program terminates with EXIT_FAILURE. */\n+\n+void caf_internal_error (const char *format, int *stat, char *errmsg,\n+\t\t\t size_t errmsg_len, ...);\n+\n+#endif\ndiff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h\nindex 022ac5c365f..3e943d4ac67 100644\n--- a/libgfortran/caf/libcaf.h\n+++ b/libgfortran/caf/libcaf.h\n@@ -26,9 +26,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n #ifndef LIBCAF_H\n #define LIBCAF_H\n \n-#include <stdbool.h>\n-#include <stddef.h>\t/* For size_t. */\n-\n #include \"libgfortran.h\"\n \n /* Definitions of the Fortran 2008 standard; need to kept in sync with\ndiff --git a/libgfortran/caf/shmem.c b/libgfortran/caf/shmem.c\nnew file mode 100644\nindex 00000000000..b8d92d657f5\n--- /dev/null\n+++ b/libgfortran/caf/shmem.c\n@@ -0,0 +1,1882 @@\n+/* Shared memory-multiple (process)-image implementation of GNU Fortran\n+ Coarray Library\n+ Copyright (C) 2011-2025 Free Software Foundation, Inc.\n+ Based on single.c contributed by Tobias Burnus <burnus@net-b.de>\n+\n+This file is part of the GNU Fortran Coarray Runtime Library (libcaf).\n+\n+Libcaf is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Libcaf is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#include \"libcaf.h\"\n+#include \"caf_error.h\"\n+\n+#include \"shmem/counter_barrier.h\"\n+#include \"shmem/supervisor.h\"\n+#include \"shmem/teams_mgmt.h\"\n+#include \"shmem/thread_support.h\"\n+\n+#include <stdlib.h> /* For exit and malloc. */\n+#include <string.h> /* For memcpy and memset. */\n+#include <stdint.h>\n+#include <assert.h>\n+#include <errno.h>\n+#include <unistd.h>\n+\n+/* Define GFC_CAF_CHECK to enable run-time checking. */\n+/* #define GFC_CAF_CHECK 1 */\n+\n+#define TOKEN(X) ((caf_shmem_token_t) (X))\n+#define MEMTOK(X) ((caf_shmem_token_t) (X))->memptr\n+\n+/* Global variables. */\n+static caf_static_t *caf_static_list = NULL;\n+memid next_memid = 0;\n+\n+typedef void (*getter_t) (void *, const int *, void **, int32_t *, void *,\n+\t\t\t caf_token_t, const size_t, size_t *, const size_t *);\n+typedef void (*is_present_t) (void *, const int *, int32_t *, void *,\n+\t\t\t caf_shmem_token_t, const size_t);\n+typedef void (*receiver_t) (void *, const int *, void *, const void *,\n+\t\t\t caf_token_t, const size_t, const size_t *,\n+\t\t\t const size_t *);\n+struct accessor_hash_t\n+{\n+ int hash;\n+ int pad;\n+ union\n+ {\n+ getter_t getter;\n+ is_present_t is_present;\n+ receiver_t receiver;\n+ } u;\n+};\n+\n+static struct accessor_hash_t *accessor_hash_table = NULL;\n+static int aht_cap = 0;\n+static int aht_size = 0;\n+static enum {\n+ AHT_UNINITIALIZED,\n+ AHT_OPEN,\n+ AHT_PREPARED\n+} accessor_hash_table_state\n+ = AHT_UNINITIALIZED;\n+\n+void\n+_gfortran_caf_init (int *argc, char ***argv)\n+{\n+ int exit_code = 0;\n+\n+ ensure_shmem_initialization ();\n+\n+ if (shared_memory_get_env ())\n+ {\n+ /* This is the initialization of a worker. */\n+ _gfortran_caf_sync_all (NULL, NULL, 0);\n+ return;\n+ }\n+\n+ if (supervisor_main_loop (argc, argv, &exit_code))\n+ return;\n+ shared_memory_cleanup (&local->sm);\n+\n+ /* Free pseudo tokens and memory to allow main process to survive caf_init.\n+ */\n+ while (caf_static_list != NULL)\n+ {\n+ caf_static_t *tmp = caf_static_list->prev;\n+ free (((caf_shmem_token_t) caf_static_list->token)->base);\n+ free (caf_static_list->token);\n+ free (caf_static_list);\n+ caf_static_list = tmp;\n+ }\n+ free (local);\n+ exit (exit_code);\n+}\n+\n+static void\n+free_team_list (caf_shmem_team_t l)\n+{\n+ while (l != NULL)\n+ {\n+ caf_shmem_team_t p = l->parent;\n+ struct coarray_allocated *ca = l->allocated;\n+ while (ca)\n+\t{\n+\t struct coarray_allocated *nca = ca->next;\n+\t free (ca);\n+\t ca = nca;\n+\t}\n+ free (l);\n+ l = p;\n+ }\n+}\n+\n+void\n+_gfortran_caf_finalize (void)\n+{\n+ free (accessor_hash_table);\n+\n+ while (caf_static_list != NULL)\n+ {\n+ caf_static_t *tmp = caf_static_list->prev;\n+ alloc_free_memory_with_id (\n+\t&local->ai,\n+\t(memid) ((caf_shmem_token_t) caf_static_list->token)->token_id);\n+ free (caf_static_list->token);\n+ free (caf_static_list);\n+ caf_static_list = tmp;\n+ }\n+\n+ free_team_list (caf_current_team);\n+ caf_initial_team = caf_current_team = NULL;\n+ free_team_list (caf_teams_formed);\n+ caf_teams_formed = NULL;\n+\n+ free (local);\n+}\n+\n+int\n+_gfortran_caf_this_image (caf_team_t team)\n+{\n+ return (team ? ((caf_shmem_team_t) team)->index : caf_current_team->index)\n+\t + 1;\n+}\n+\n+int\n+_gfortran_caf_num_images (caf_team_t team, int32_t *team_number)\n+{\n+#define CHECK_TEAMS \\\n+ while (cur) \\\n+ { \\\n+ if (cur->u.image_info->team_id == *team_number) \\\n+\treturn counter_barrier_get_count (&cur->u.image_info->image_count); \\\n+ cur = cur->parent; \\\n+ }\n+\n+ if (team)\n+ return counter_barrier_get_count (\n+ &((caf_shmem_team_t) team)->u.image_info->image_count);\n+\n+ if (team_number)\n+ {\n+ caf_shmem_team_t cur = caf_current_team;\n+\n+ CHECK_TEAMS\n+\n+ cur = caf_teams_formed;\n+ CHECK_TEAMS\n+ }\n+\n+ return counter_barrier_get_count (\n+ &caf_current_team->u.image_info->image_count);\n+}\n+\n+\n+void\n+_gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,\n+\t\t\tgfc_descriptor_t *data, int *stat, char *errmsg,\n+\t\t\tsize_t errmsg_len)\n+{\n+ static bool inited = false;\n+ const char alloc_fail_msg[] = \"Failed to allocate coarray\";\n+ void *mem;\n+ caf_shmem_token_t shmem_token;\n+\n+ /* When the master has not been initialized, we could either be in the\n+ control process or in the static initializer phase. */\n+ if (unlikely (!inited))\n+ {\n+ if (local == NULL)\n+\t{\n+\t if (shared_memory_get_env ())\n+\t {\n+\t /* This is the static initializer phase. Register the static\n+\t\t coarrays or we are in trouble later. */\n+\t ensure_shmem_initialization ();\n+\t inited = true;\n+\t }\n+\t else if (type == CAF_REGTYPE_COARRAY_STATIC)\n+\t {\n+\t /* This is the control process, but it also runs the static\n+\t\t initializers (the caf_init.N() procedures). In these it may\n+\t\t want to assign to members (effectively NULL them) of derived\n+\t\t types. Therefore the need to return valid memory blocks.\n+\t\t These are never used and do not participate in any coarray\n+\t\t routine. They unfortunately just waste some memory. */\n+\t mem = malloc (size);\n+\t GFC_DESCRIPTOR_DATA (data) = mem;\n+\t caf_static_t *tmp = malloc (sizeof (caf_static_t));\n+\t *token = malloc (sizeof (struct caf_shmem_token));\n+\t **(caf_shmem_token_t *) token\n+\t\t= (struct caf_shmem_token) {mem, NULL, mem, size, ~0U, true};\n+\t *tmp = (caf_static_t) {*token, caf_static_list};\n+\t caf_static_list = tmp;\n+\t return;\n+\t }\n+\t else\n+\t return;\n+\t}\n+ }\n+\n+ /* Catch all special cases. */\n+ switch (type)\n+ {\n+ /* When mapping, read from the old token. */\n+ case CAF_REGTYPE_COARRAY_MAP_EXISTING:\n+ /* The mapping could involve an offset that is mangled into the array's\n+\t data ptr. */\n+ mem\n+\t= ((caf_shmem_token_t) *token)->base\n+\t + (GFC_DESCRIPTOR_DATA (data) - ((caf_shmem_token_t) *token)->memptr);\n+ size = ((caf_shmem_token_t) *token)->image_size;\n+ break;\n+ case CAF_REGTYPE_EVENT_ALLOC:\n+ case CAF_REGTYPE_EVENT_STATIC:\n+ size *= sizeof (void *);\n+ break;\n+ default:\n+ break;\n+ }\n+\n+ if (type != CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY)\n+ *token = malloc (sizeof (struct caf_shmem_token));\n+\n+ size = alignto (size, sizeof (ptrdiff_t));\n+ switch (type)\n+ {\n+ case CAF_REGTYPE_LOCK_STATIC:\n+ case CAF_REGTYPE_LOCK_ALLOC:\n+ case CAF_REGTYPE_CRITICAL:\n+ {\n+\tlock_t *addr;\n+\tbool created;\n+\n+\tallocator_lock (&local->ai.alloc);\n+\t/* Allocate enough space for the metadata infront of the lock\n+\t array. */\n+\taddr\n+\t = alloc_get_memory_by_id_created (&local->ai, size * sizeof (lock_t),\n+\t\t\t\t\t next_memid, &created);\n+\n+\tif (created)\n+\t {\n+\t /* Initialize the mutex only, when the memory was allocated for the\n+\t first time. */\n+\t for (size_t c = 0; c < size; ++c)\n+\t initialize_shared_errorcheck_mutex (&addr[c]);\n+\t }\n+\tsize *= sizeof (lock_t);\n+\n+\tallocator_unlock (&local->ai.alloc);\n+\tmem = addr;\n+\tbreak;\n+ }\n+ case CAF_REGTYPE_EVENT_STATIC:\n+ case CAF_REGTYPE_EVENT_ALLOC:\n+ {\n+\tbool created;\n+\n+\tallocator_lock (&local->ai.alloc);\n+\tmem = alloc_get_memory_by_id_created (\n+\t &local->ai, size * caf_current_team->u.image_info->image_count.count,\n+\t next_memid, &created);\n+\tif (created)\n+\t memset (mem, 0,\n+\t\t size * caf_current_team->u.image_info->image_count.count);\n+\tallocator_unlock (&local->ai.alloc);\n+ }\n+ break;\n+ case CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY:\n+ mem = NULL;\n+ break;\n+ case CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY:\n+ allocator_lock (&local->ai.alloc);\n+ mem = SHMPTR_AS (void *, allocator_shared_malloc (&local->ai.alloc, size),\n+\t\t &local->sm);\n+ allocator_unlock (&local->ai.alloc);\n+ break;\n+ case CAF_REGTYPE_COARRAY_MAP_EXISTING:\n+ /* Computing the mem ptr is done above before the new token is allocated.\n+ */\n+ break;\n+ default:\n+ mem = alloc_get_memory_by_id (\n+\t&local->ai, size * caf_current_team->u.image_info->image_count.count,\n+\tnext_memid);\n+ break;\n+ }\n+\n+ if (unlikely (\n+\t*token == NULL\n+\t|| (mem == NULL && type != CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY)))\n+ {\n+ /* Freeing the memory conditionally seems pointless, but\n+\t caf_internal_error () may return, when a stat is given and then the\n+\t memory may be lost. */\n+ if (mem)\n+\talloc_free_memory_with_id (&local->ai, next_memid);\n+ free (*token);\n+ caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);\n+ return;\n+ }\n+\n+ shmem_token = TOKEN (*token);\n+ switch (type)\n+ {\n+ case CAF_REGTYPE_COARRAY_ALLOC_REGISTER_ONLY:\n+ *shmem_token\n+\t= (struct caf_shmem_token) {NULL, NULL, NULL, size, ~0U, false};\n+ break;\n+ case CAF_REGTYPE_COARRAY_ALLOC_ALLOCATE_ONLY:\n+ shmem_token->memptr = mem;\n+ shmem_token->base = mem;\n+ shmem_token->image_size = size;\n+ shmem_token->owning_memory = true;\n+ break;\n+ case CAF_REGTYPE_COARRAY_MAP_EXISTING:\n+ *shmem_token\n+\t= (struct caf_shmem_token) {mem + size * this_image.image_num,\n+\t\t\t\t GFC_DESCRIPTOR_RANK (data) > 0 ? data\n+\t\t\t\t\t\t\t\t : NULL,\n+\t\t\t\t mem,\n+\t\t\t\t size,\n+\t\t\t\t next_memid++,\n+\t\t\t\t false};\n+ break;\n+ case CAF_REGTYPE_LOCK_STATIC:\n+ case CAF_REGTYPE_LOCK_ALLOC:\n+ case CAF_REGTYPE_CRITICAL:\n+ *shmem_token = (struct caf_shmem_token) {\n+\tmem,\t GFC_DESCRIPTOR_RANK (data) > 0 ? data : NULL,\n+\tmem,\t size,\n+\tnext_memid++, false};\n+ break;\n+ default:\n+ *shmem_token\n+\t= (struct caf_shmem_token) {mem + size * this_image.image_num,\n+\t\t\t\t GFC_DESCRIPTOR_RANK (data) > 0 ? data\n+\t\t\t\t\t\t\t\t : NULL,\n+\t\t\t\t mem,\n+\t\t\t\t size,\n+\t\t\t\t next_memid++,\n+\t\t\t\t true};\n+ break;\n+ }\n+\n+ if (stat)\n+ *stat = 0;\n+\n+ if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC\n+ || type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC)\n+ {\n+ caf_static_t *tmp = malloc (sizeof (caf_static_t));\n+ *tmp = (caf_static_t) {*token, caf_static_list};\n+ caf_static_list = tmp;\n+ }\n+ else\n+ {\n+ struct coarray_allocated *ca = caf_current_team->allocated;\n+ for (; ca && ca->token != shmem_token; ca = ca->next)\n+\t;\n+ if (!ca)\n+\t{\n+\t ca = (struct coarray_allocated *) malloc (\n+\t sizeof (struct coarray_allocated));\n+\t *ca = (struct coarray_allocated) {caf_current_team->allocated,\n+\t\t\t\t\t shmem_token};\n+\t caf_current_team->allocated = ca;\n+\t}\n+ }\n+ GFC_DESCRIPTOR_DATA (data) = shmem_token->memptr;\n+}\n+\n+void\n+_gfortran_caf_deregister (caf_token_t *token, caf_deregister_t type, int *stat,\n+\t\t\t char *errmsg __attribute__ ((unused)),\n+\t\t\t size_t errmsg_len __attribute__ ((unused)))\n+{\n+ caf_shmem_token_t shmem_token = TOKEN (*token);\n+\n+ if (shmem_token->owning_memory && shmem_token->memptr)\n+ {\n+ if (shmem_token->token_id != ~0U)\n+\talloc_free_memory_with_id (&local->ai, (memid) shmem_token->token_id);\n+ else\n+\t{\n+\t allocator_lock (&local->ai.alloc);\n+\t allocator_shared_free (&local->ai.alloc,\n+\t\t\t\t AS_SHMPTR (shmem_token->base, local->sm),\n+\t\t\t\t shmem_token->image_size);\n+\t allocator_unlock (&local->ai.alloc);\n+\t}\n+\n+ if (shmem_token->desc)\n+\tGFC_DESCRIPTOR_DATA (shmem_token->desc) = NULL;\n+ }\n+\n+ if (type != CAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY)\n+ {\n+ struct coarray_allocated *ca = caf_current_team->allocated;\n+ if (ca && caf_current_team->allocated->token == shmem_token)\n+\tcaf_current_team->allocated = ca->next;\n+ else\n+\t{\n+\t struct coarray_allocated *pca = NULL;\n+\t for (; ca && ca->token != shmem_token; pca = ca, ca = ca->next)\n+\t ;\n+\t if (!ca)\n+\t caf_runtime_error (\n+\t \"Coarray token to be freeed is not in current team %d\", type);\n+\t /* Unhook found coarray_allocated node from list... */\n+\t pca->next = ca->next;\n+\t}\n+ /* ... and free. */\n+ free (ca);\n+ free (TOKEN (*token));\n+ *token = NULL;\n+ }\n+ else\n+ {\n+ shmem_token->memptr = NULL;\n+ shmem_token->owning_memory = false;\n+ }\n+\n+ if (stat)\n+ *stat = 0;\n+}\n+\n+void\n+_gfortran_caf_sync_all (int *stat, char *errmsg, size_t errmsg_len)\n+{\n+ __asm__ __volatile__ (\"\":::\"memory\");\n+ HEALTH_CHECK (stat, errmsg, errmsg_len);\n+ CHECK_TEAM_INTEGRITY (caf_current_team);\n+ sync_all ();\n+}\n+\n+\n+void\n+_gfortran_caf_sync_memory (int *stat,\n+\t\t\t char *errmsg __attribute__ ((unused)),\n+\t\t\t size_t errmsg_len __attribute__ ((unused)))\n+{\n+ __asm__ __volatile__ (\"\":::\"memory\");\n+ if (stat)\n+ *stat = 0;\n+}\n+\n+void\n+_gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg,\n+\t\t\t size_t errmsg_len)\n+{\n+ int *mapped_images = images;\n+\n+ CHECK_TEAM_INTEGRITY (caf_current_team);\n+ if (count > 0)\n+ {\n+ int *map = caf_current_team->u.image_info->image_map;\n+ int max_id = caf_current_team->u.image_info->image_map_size;\n+\n+ mapped_images = __builtin_alloca (sizeof (int) * count);\n+ if (!mapped_images)\n+\t{\n+\t caf_internal_error (\"SYNC IMAGES: Can not reserve buffer for mapping \"\n+\t\t\t \"images to internal ids. Increase stack size!\",\n+\t\t\t stat, errmsg, errmsg_len);\n+\t return;\n+\t}\n+ for (int c = 0; c < count; ++c)\n+\t{\n+\t if (images[c] > 0 && images[c] <= max_id)\n+\t {\n+\t mapped_images[c] = map[images[c] - 1];\n+\t switch (this_image.supervisor->images[mapped_images[c]].status)\n+\t\t{\n+\t\tcase IMAGE_SUCCESS:\n+\t\t caf_internal_error (\"SYNC IMAGES: Image %d is stopped\", stat,\n+\t\t\t\t errmsg, errmsg_len, images[c]);\n+\t\t /* We can come here only, when stat is non-NULL. */\n+\t\t *stat = CAF_STAT_STOPPED_IMAGE;\n+\t\t return;\n+\t\tcase IMAGE_FAILED:\n+\t\t caf_internal_error (\"SYNC IMAGES: Image %d has failed\", stat,\n+\t\t\t\t errmsg, errmsg_len, images[c]);\n+\t\t /* We can come here only, when stat is non-NULL. */\n+\t\t *stat = CAF_STAT_FAILED_IMAGE;\n+\t\t return;\n+\t\tdefault:\n+\t\t break;\n+\t\t}\n+\t for (int i = 0; i < c; ++i)\n+\t\tif (mapped_images[c] == mapped_images[i])\n+\t\t {\n+\t\t caf_internal_error (\"SYNC IMAGES: Duplicate image %d in \"\n+\t\t\t\t\t\"images at position %d and &d.\",\n+\t\t\t\t\tstat, errmsg, errmsg_len, images[c],\n+\t\t\t\t\ti + 1, c + 1);\n+\t\t /* There is no official error code for this, but 3 is what\n+\t\t OpenCoarray uses. */\n+\t\t *stat = 3;\n+\t\t return;\n+\t\t }\n+\t }\n+\t else\n+\t {\n+\t caf_internal_error (\"Invalid image number %d in SYNC IMAGES\",\n+\t\t\t\t stat, errmsg, errmsg_len, images[c]);\n+\t return;\n+\t }\n+\t}\n+ }\n+ else\n+ HEALTH_CHECK (stat, errmsg, errmsg_len);\n+\n+ __asm__ __volatile__ (\"\" ::: \"memory\");\n+ sync_table (&local->si, mapped_images, count);\n+ HEALTH_CHECK (stat, errmsg, errmsg_len);\n+}\n+\n+extern void _gfortran_report_exception (void);\n+\n+void\n+_gfortran_caf_stop_numeric (int stop_code, bool quiet)\n+{\n+ if (!quiet)\n+ {\n+ _gfortran_report_exception ();\n+ fprintf (stderr, \"STOP %d\\n\", stop_code);\n+ }\n+ exit (stop_code);\n+}\n+\n+void\n+_gfortran_caf_stop_str (const char *string, size_t len, bool quiet)\n+{\n+ if (!quiet)\n+ {\n+ _gfortran_report_exception ();\n+ fputs (\"STOP \", stderr);\n+ while (len--)\n+\tfputc (*(string++), stderr);\n+ fputs (\"\\n\", stderr);\n+ }\n+ exit (0);\n+}\n+\n+\n+void\n+_gfortran_caf_error_stop_str (const char *string, size_t len, bool quiet)\n+{\n+ if (!quiet)\n+ {\n+ _gfortran_report_exception ();\n+ fputs (\"ERROR STOP \", stderr);\n+ while (len--)\n+\tfputc (*(string++), stderr);\n+ fputs (\"\\n\", stderr);\n+ }\n+ exit (1);\n+}\n+\n+/* Report that the program terminated because of a fail image issued. */\n+\n+void\n+_gfortran_caf_fail_image (void)\n+{\n+ fputs (\"IMAGE FAILED!\\n\", stderr);\n+ this_image.supervisor->images[this_image.image_num].status = IMAGE_FAILED;\n+ atomic_fetch_add (&this_image.supervisor->failed_images, 1);\n+ exit (0);\n+}\n+\n+/* Get the status of image IMAGE. */\n+\n+int\n+_gfortran_caf_image_status (int image, caf_team_t *team)\n+{\n+ caf_shmem_team_t t = caf_current_team;\n+ int image_index;\n+\n+ if (team)\n+ t = *(caf_shmem_team_t *) team;\n+\n+ if (image > t->u.image_info->image_count.count)\n+ return CAF_STAT_STOPPED_IMAGE;\n+\n+ image_index = t->u.image_info->image_map[image - 1];\n+\n+ switch (this_image.supervisor->images[image_index].status)\n+ {\n+ case IMAGE_FAILED:\n+ return CAF_STAT_FAILED_IMAGE;\n+ case IMAGE_SUCCESS:\n+ return CAF_STAT_STOPPED_IMAGE;\n+\n+ /* When image status is not known, return 0. */\n+ case IMAGE_OK:\n+ case IMAGE_UNKNOWN:\n+ default:\n+ return 0;\n+ }\n+}\n+\n+static void\n+stopped_or_failed_images (gfc_descriptor_t *array, caf_team_t *team, int *kind,\n+\t\t\t image_status img_stat, const char *function_name)\n+{\n+ int local_kind = kind != NULL ? *kind : 4;\n+ size_t sti = 0;\n+ caf_shmem_team_t t = caf_current_team;\n+\n+ if (team)\n+ t = *(caf_shmem_team_t *) team;\n+\n+ int sz = t->u.image_info->image_map_size;\n+ for (int i = 0; i < sz; ++i)\n+ if (this_image.supervisor->images[t->u.image_info->image_map[i]].status\n+\t== img_stat)\n+ ++sti;\n+\n+ if (sti)\n+ {\n+ array->base_addr = malloc (local_kind * sti);\n+ array->dtype.type = BT_INTEGER;\n+ array->dtype.elem_len = local_kind;\n+ array->dim[0].lower_bound = 1;\n+ array->dim[0]._ubound = sti;\n+ array->dim[0]._stride = 1;\n+ array->span = local_kind;\n+ array->offset = 0;\n+ sti = 0;\n+ for (int i = 0; i < sz; ++i)\n+\tif (this_image.supervisor->images[t->u.image_info->image_map[i]].status\n+\t == img_stat)\n+\t switch (local_kind)\n+\t {\n+\t case 1:\n+\t ((int8_t *) array->base_addr)[sti++] = i + 1;\n+\t break;\n+\t case 2:\n+\t ((int16_t *) array->base_addr)[sti++] = i + 1;\n+\t break;\n+\t case 4:\n+\t ((int32_t *) array->base_addr)[sti++] = i + 1;\n+\t break;\n+\t case 8:\n+\t ((int64_t *) array->base_addr)[sti++] = i + 1;\n+\t break;\n+\t default:\n+\t caf_runtime_error (\"Unsupported kind %d in %s.\", local_kind,\n+\t\t\t\t function_name);\n+\t }\n+ }\n+ else\n+ {\n+ array->base_addr = NULL;\n+ array->dtype.type = BT_INTEGER;\n+ array->dtype.elem_len = local_kind;\n+ /* Setting lower_bound higher then upper_bound is what the compiler does\n+\t to indicate an empty array. */\n+ array->dim[0].lower_bound = 0;\n+ array->dim[0]._ubound = -1;\n+ array->dim[0]._stride = 1;\n+ array->offset = 0;\n+ }\n+}\n+\n+void\n+_gfortran_caf_failed_images (gfc_descriptor_t *array, caf_team_t *team,\n+\t\t\t int *kind)\n+{\n+ stopped_or_failed_images (array, team, kind, IMAGE_FAILED, \"FAILED_IMAGES()\");\n+}\n+\n+void\n+_gfortran_caf_stopped_images (gfc_descriptor_t *array, caf_team_t *team,\n+\t\t\t int *kind)\n+{\n+ stopped_or_failed_images (array, team, kind, IMAGE_SUCCESS,\n+\t\t\t \"STOPPED_IMAGES()\");\n+}\n+\n+void\n+_gfortran_caf_error_stop (int error, bool quiet)\n+{\n+ if (!quiet)\n+ {\n+ _gfortran_report_exception ();\n+ fprintf (stderr, \"ERROR STOP %d\\n\", error);\n+ }\n+ exit (error);\n+}\n+\n+static bool\n+check_get_team (caf_team_t *team, int *team_number, int *stat,\n+\t\tcaf_shmem_team_t *cur_team)\n+{\n+ if (team || team_number)\n+ {\n+ *cur_team = caf_current_team;\n+\n+ if (team)\n+\t{\n+\t caf_shmem_team_t cand_team = (caf_shmem_team_t) (*team);\n+\t while (*cur_team && *cur_team != cand_team)\n+\t *cur_team = (*cur_team)->parent;\n+\t}\n+ else\n+\twhile (*cur_team && (*cur_team)->u.image_info->team_id != *team_number)\n+\t *cur_team = (*cur_team)->parent;\n+\n+ if (!*cur_team)\n+\t{\n+\t if (stat)\n+\t {\n+\t *stat = 1;\n+\t return false;\n+\t }\n+\t else\n+\t caf_runtime_error (\"requested team not found\");\n+\t}\n+ }\n+ else\n+ *cur_team = caf_current_team;\n+\n+ CHECK_TEAM_INTEGRITY ((*cur_team));\n+ return true;\n+}\n+\n+static bool\n+check_map_team (int *remote_index, int *this_index, const int image_index,\n+\t\tcaf_team_t *team, int *team_number, int *stat)\n+{\n+ caf_shmem_team_t selected_team;\n+ const bool check = check_get_team (team, team_number, stat, &selected_team);\n+\n+ if (!selected_team)\n+ return false;\n+#ifndef NDEBUG\n+ if (image_index < 1\n+ || image_index > selected_team->u.image_info->image_map_size)\n+ {\n+ if (stat)\n+\t*stat = 1;\n+ return false;\n+ }\n+#endif\n+\n+ *remote_index = selected_team->u.image_info->image_map[image_index - 1];\n+\n+ *this_index = this_image.image_num;\n+\n+ return check;\n+}\n+\n+void\n+_gfortran_caf_co_broadcast (gfc_descriptor_t *desc, int source_image, int *stat,\n+\t\t\t char *errmsg __attribute__ ((unused)),\n+\t\t\t size_t errmsg_len __attribute__ ((unused)))\n+{\n+ int mapped_index, this_image_index;\n+ if (stat)\n+ *stat = 0;\n+\n+ if (!check_map_team (&mapped_index, &this_image_index, source_image, NULL,\n+\t\t NULL, stat))\n+ return;\n+\n+ collsub_broadcast_array (desc, mapped_index);\n+}\n+\n+#define GEN_OP(name, op, type) \\\n+ static type name##_##type (type *lhs, type *rhs) { return op (*lhs, *rhs); }\n+\n+#define GEN_OP_SERIES(name, op) \\\n+ GEN_OP (name, op, uint8_t) \\\n+ GEN_OP (name, op, uint16_t) \\\n+ GEN_OP (name, op, uint32_t) \\\n+ GEN_OP (name, op, uint64_t) \\\n+ GEN_OP (name, op, int8_t) \\\n+ GEN_OP (name, op, int16_t) \\\n+ GEN_OP (name, op, int32_t) \\\n+ GEN_OP (name, op, int64_t) \\\n+ GEN_OP (name, op, float) \\\n+ GEN_OP (name, op, double)\n+\n+#define CO_ADD(l, r) ((l) + (r))\n+#define CO_MIN(l, r) ((l) < (r) ? (l) : (r))\n+#define CO_MAX(l, r) ((l) > (r) ? (l) : (r))\n+GEN_OP_SERIES (sum, CO_ADD)\n+GEN_OP_SERIES (min, CO_MIN)\n+GEN_OP_SERIES (max, CO_MAX)\n+\n+// typedef void *(*opr_t) (void *, void *);\n+typedef void *opr_t;\n+\n+#define GFC_DESCRIPTOR_KIND(desc) ((desc)->dtype.elem_len)\n+\n+#define CASE_TYPE_KIND(name, type, ctype) \\\n+ case type: \\\n+ { \\\n+ switch (GFC_DESCRIPTOR_KIND (desc)) \\\n+\t{ \\\n+\tcase 1: \\\n+\t opr = (opr_t) name##_##ctype##8_t; \\\n+\t break; \\\n+\tcase 2: \\\n+\t opr = (opr_t) name##_##ctype##16_t; \\\n+\t break; \\\n+\tcase 4: \\\n+\t opr = (opr_t) name##_##ctype##32_t; \\\n+\t break; \\\n+\tcase 8: \\\n+\t opr = (opr_t) name##_##ctype##64_t; \\\n+\t break; \\\n+\tdefault: \\\n+\t caf_runtime_error (\"\" #name \\\n+\t\t\t \" not available for type/kind combination\"); \\\n+\t} \\\n+ break; \\\n+ }\n+\n+#define SWITCH_TYPE_KIND(name) \\\n+ switch (GFC_DESCRIPTOR_TYPE (desc)) \\\n+ { \\\n+ CASE_TYPE_KIND (name, BT_INTEGER, int) \\\n+ CASE_TYPE_KIND (name, BT_UNSIGNED, uint) \\\n+ case BT_REAL: \\\n+ switch (GFC_DESCRIPTOR_KIND (desc)) \\\n+\t{ \\\n+\tcase 4: \\\n+\t opr = (opr_t) name##_float; \\\n+\t break; \\\n+\tcase 8: \\\n+\t opr = (opr_t) name##_double; \\\n+\t break; \\\n+\tdefault: \\\n+\t caf_runtime_error (\"\" #name \\\n+\t\t\t \" not available for type/kind combination\"); \\\n+\t} \\\n+ break; \\\n+ default: \\\n+ caf_runtime_error (\"\" #name \" not available for type/kind combination\"); \\\n+ }\n+\n+void\n+_gfortran_caf_co_sum (gfc_descriptor_t *desc, int result_image, int *stat,\n+\t\t char *errmsg __attribute__ ((unused)),\n+\t\t size_t errmsg_len __attribute__ ((unused)))\n+{\n+ int mapped_index = -1, this_image_index;\n+ opr_t opr;\n+\n+ if (stat)\n+ *stat = 0;\n+\n+ /* If result_image == 0 then allreduce is wanted, i.e. mapped_index = -1. */\n+ if (result_image\n+ && !check_map_team (&mapped_index, &this_image_index, result_image, NULL,\n+\t\t\t NULL, stat))\n+ return;\n+\n+ SWITCH_TYPE_KIND (sum)\n+\n+ collsub_reduce_array (desc, mapped_index, opr, 0, 0);\n+}\n+\n+void\n+_gfortran_caf_co_min (gfc_descriptor_t *desc, int result_image, int *stat,\n+\t\t char *errmsg __attribute__ ((unused)),\n+\t\t int a_len __attribute__ ((unused)),\n+\t\t size_t errmsg_len __attribute__ ((unused)))\n+{\n+ int mapped_index = -1, this_image_index;\n+ opr_t opr;\n+\n+ if (stat)\n+ *stat = 0;\n+ /* If result_image == 0 then allreduce is wanted, i.e. mapped_index = -1. */\n+ if (result_image\n+ && !check_map_team (&mapped_index, &this_image_index, result_image, NULL,\n+\t\t\t NULL, stat))\n+ return;\n+\n+ SWITCH_TYPE_KIND (min)\n+\n+ collsub_reduce_array (desc, mapped_index, opr, 0, 0);\n+}\n+\n+void\n+_gfortran_caf_co_max (gfc_descriptor_t *desc, int result_image, int *stat,\n+\t\t char *errmsg __attribute__ ((unused)),\n+\t\t int a_len __attribute__ ((unused)),\n+\t\t size_t errmsg_len __attribute__ ((unused)))\n+{\n+ int mapped_index = -1, this_image_index;\n+ opr_t opr;\n+\n+ if (stat)\n+ *stat = 0;\n+ /* If result_image == 0 then allreduce is wanted, i.e. mapped_index = -1. */\n+ if (result_image\n+ && !check_map_team (&mapped_index, &this_image_index, result_image, NULL,\n+\t\t\t NULL, stat))\n+ return;\n+\n+ SWITCH_TYPE_KIND (max)\n+\n+ collsub_reduce_array (desc, mapped_index, opr, 0, 0);\n+}\n+\n+void\n+_gfortran_caf_co_reduce (gfc_descriptor_t *desc, void *(*opr) (void *, void *),\n+\t\t\t int opr_flags, int result_image, int *stat,\n+\t\t\t char *errmsg __attribute__ ((unused)), int desc_len,\n+\t\t\t size_t errmsg_len __attribute__ ((unused)))\n+{\n+ int mapped_index = -1, this_image_index;\n+\n+ if (stat)\n+ *stat = 0;\n+\n+ /* If result_image == 0 then allreduce is wanted, i.e. mapped_index = -1. */\n+ if (result_image\n+ && !check_map_team (&mapped_index, &this_image_index, result_image, NULL,\n+\t\t\t NULL, stat))\n+ return;\n+\n+ collsub_reduce_array (desc, mapped_index, opr, opr_flags, desc_len);\n+}\n+\n+void\n+_gfortran_caf_register_accessor (const int hash, getter_t accessor)\n+{\n+ if (accessor_hash_table_state == AHT_UNINITIALIZED)\n+ {\n+ aht_cap = 16;\n+ accessor_hash_table = calloc (aht_cap, sizeof (struct accessor_hash_t));\n+ accessor_hash_table_state = AHT_OPEN;\n+ }\n+ if (aht_size == aht_cap)\n+ {\n+ aht_cap += 16;\n+ accessor_hash_table = realloc (accessor_hash_table,\n+\t\t\t\t aht_cap * sizeof (struct accessor_hash_t));\n+ }\n+ if (accessor_hash_table_state == AHT_PREPARED)\n+ {\n+ accessor_hash_table_state = AHT_OPEN;\n+ }\n+ accessor_hash_table[aht_size].hash = hash;\n+ accessor_hash_table[aht_size].u.getter = accessor;\n+ ++aht_size;\n+}\n+\n+static int\n+hash_compare (const struct accessor_hash_t *lhs,\n+\t const struct accessor_hash_t *rhs)\n+{\n+ return lhs->hash < rhs->hash ? -1 : (lhs->hash > rhs->hash ? 1 : 0);\n+}\n+\n+void\n+_gfortran_caf_register_accessors_finish (void)\n+{\n+ if (accessor_hash_table_state == AHT_PREPARED\n+ || accessor_hash_table_state == AHT_UNINITIALIZED)\n+ return;\n+\n+ qsort (accessor_hash_table, aht_size, sizeof (struct accessor_hash_t),\n+\t (int (*) (const void *, const void *)) hash_compare);\n+ accessor_hash_table_state = AHT_PREPARED;\n+}\n+\n+int\n+_gfortran_caf_get_remote_function_index (const int hash)\n+{\n+ if (accessor_hash_table_state != AHT_PREPARED)\n+ {\n+ caf_runtime_error (\"the accessor hash table is not prepared.\");\n+ }\n+\n+ struct accessor_hash_t cand;\n+ cand.hash = hash;\n+ struct accessor_hash_t *f\n+ = bsearch (&cand, accessor_hash_table, aht_size,\n+\t sizeof (struct accessor_hash_t),\n+\t (int (*) (const void *, const void *)) hash_compare);\n+\n+ int index = f ? f - accessor_hash_table : -1;\n+ return index;\n+}\n+\n+void\n+_gfortran_caf_get_from_remote (\n+ caf_token_t token, const gfc_descriptor_t *opt_src_desc,\n+ const size_t *opt_src_charlen, const int image_index,\n+ const size_t dst_size __attribute__ ((unused)), void **dst_data,\n+ size_t *opt_dst_charlen, gfc_descriptor_t *opt_dst_desc,\n+ const bool may_realloc_dst, const int getter_index, void *add_data,\n+ const size_t add_data_size __attribute__ ((unused)), int *stat,\n+ caf_team_t *team, int *team_number)\n+{\n+ caf_shmem_token_t shmem_token = TOKEN (token);\n+ void *src_ptr;\n+ int32_t free_buffer;\n+ int remote_image_index, this_image_index;\n+ void *dst_ptr = opt_dst_desc ? (void *)opt_dst_desc : dst_data;\n+ void *old_dst_data_ptr = NULL, *old_src_data_ptr = NULL;\n+ struct caf_shmem_token cb_token = {add_data, NULL, add_data, 0, ~0, false};\n+\n+ if (stat)\n+ *stat = 0;\n+\n+ if (!check_map_team (&remote_image_index, &this_image_index, image_index,\n+\t\t team, team_number, stat))\n+ return;\n+\n+ /* Compute the address only after team's mapping has taken place. */\n+ src_ptr = shmem_token->base + remote_image_index * shmem_token->image_size;\n+ if (opt_src_desc)\n+ {\n+ old_src_data_ptr = opt_src_desc->base_addr;\n+ ((gfc_descriptor_t *) opt_src_desc)->base_addr = src_ptr;\n+ src_ptr = (void *) opt_src_desc;\n+ }\n+\n+ if (opt_dst_desc && !may_realloc_dst)\n+ {\n+ old_dst_data_ptr = opt_dst_desc->base_addr;\n+ opt_dst_desc->base_addr = NULL;\n+ }\n+\n+ accessor_hash_table[getter_index].u.getter (add_data, &image_index, dst_ptr,\n+\t\t\t\t\t &free_buffer, src_ptr, &cb_token,\n+\t\t\t\t\t 0, opt_dst_charlen,\n+\t\t\t\t\t opt_src_charlen);\n+ if (opt_dst_desc && old_dst_data_ptr && !may_realloc_dst\n+ && opt_dst_desc->base_addr != old_dst_data_ptr)\n+ {\n+ size_t dsize = opt_dst_desc->span;\n+ for (int i = 0; i < GFC_DESCRIPTOR_RANK (opt_dst_desc); ++i)\n+\tdsize *= GFC_DESCRIPTOR_EXTENT (opt_dst_desc, i);\n+ memcpy (old_dst_data_ptr, opt_dst_desc->base_addr, dsize);\n+ free (opt_dst_desc->base_addr);\n+ opt_dst_desc->base_addr = old_dst_data_ptr;\n+ }\n+\n+ if (old_src_data_ptr)\n+ ((gfc_descriptor_t *) opt_src_desc)->base_addr = old_src_data_ptr;\n+}\n+\n+int32_t\n+_gfortran_caf_is_present_on_remote (caf_token_t token, const int image_index,\n+\t\t\t\t const int present_index, void *add_data,\n+\t\t\t\t const size_t add_data_size\n+\t\t\t\t __attribute__ ((unused)))\n+{\n+ /* Unregistered tokens are always not present. */\n+ if (!token)\n+ return 0;\n+\n+ caf_shmem_token_t shmem_token = TOKEN (token);\n+ int32_t result;\n+ struct caf_shmem_token cb_token = {add_data, NULL, add_data, 0, ~0, false};\n+ void *src_ptr, *arg;\n+ int remote_image_index, this_image_index;\n+ GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp_desc;\n+\n+ if (!check_map_team (&remote_image_index, &this_image_index, image_index,\n+\t\t NULL, NULL, NULL))\n+ return 0;\n+\n+ src_ptr = shmem_token->base + remote_image_index * shmem_token->image_size;\n+ if (shmem_token->desc)\n+ {\n+ memcpy (&temp_desc, shmem_token->desc,\n+\t sizeof (gfc_descriptor_t)\n+\t\t+ GFC_DESCRIPTOR_RANK (shmem_token->desc)\n+\t\t * sizeof (descriptor_dimension));\n+ temp_desc.base_addr = src_ptr;\n+ arg = &temp_desc;\n+ }\n+ else\n+ arg = &src_ptr;\n+\n+ accessor_hash_table[present_index].u.is_present (add_data, &image_index,\n+\t\t\t\t\t\t &result, arg, &cb_token, 0);\n+\n+ return result;\n+}\n+\n+void\n+_gfortran_caf_send_to_remote (\n+ caf_token_t token, gfc_descriptor_t *opt_dst_desc,\n+ const size_t *opt_dst_charlen, const int image_index,\n+ const size_t src_size __attribute__ ((unused)), const void *src_data,\n+ const size_t *opt_src_charlen, const gfc_descriptor_t *opt_src_desc,\n+ const int accessor_index, void *add_data,\n+ const size_t add_data_size __attribute__ ((unused)), int *stat,\n+ caf_team_t *team, int *team_number)\n+{\n+ caf_shmem_token_t shmem_token = TOKEN (token);\n+ void *dst_ptr, *dst_data_ptr, *old_dst_data_ptr = NULL;\n+ const void *src_ptr = opt_src_desc ? (void *) opt_src_desc : src_data;\n+ struct caf_shmem_token cb_token = {add_data, NULL, add_data, 0, ~0, false};\n+ int remote_image_index, this_image_index;\n+ GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) temp_src_desc;\n+\n+ if (stat)\n+ *stat = 0;\n+\n+ if (!check_map_team (&remote_image_index, &this_image_index, image_index,\n+\t\t team, team_number, stat))\n+ return;\n+\n+ dst_data_ptr = dst_ptr\n+ = shmem_token->base + remote_image_index * shmem_token->image_size;\n+ if (opt_dst_desc)\n+ {\n+ old_dst_data_ptr = opt_dst_desc->base_addr;\n+ ((gfc_descriptor_t *) opt_dst_desc)->base_addr = dst_ptr;\n+ dst_ptr = (void *) opt_dst_desc;\n+ }\n+\n+ /* Try to detect copy to self, with overlapping data segment. */\n+ if (opt_src_desc && remote_image_index == this_image_index)\n+ {\n+ size_t src_data_span = GFC_DESCRIPTOR_SIZE (opt_src_desc);\n+ for (int d = 0; d < GFC_DESCRIPTOR_RANK (opt_src_desc); d++)\n+\tsrc_data_span *= GFC_DESCRIPTOR_EXTENT (opt_src_desc, d);\n+ if (GFC_DESCRIPTOR_DATA (opt_src_desc) >= dst_data_ptr\n+\t && dst_data_ptr <= GFC_DESCRIPTOR_DATA (opt_src_desc) + src_data_span)\n+\t{\n+\t src_ptr = __builtin_alloca (src_data_span);\n+\t if (!src_ptr)\n+\t {\n+\t caf_internal_error (\"Out of stack in coarray send (dst[...] = \"\n+\t\t\t\t \"...) expression. Increase stacksize!\",\n+\t\t\t\t stat, NULL, 0);\n+\t return;\n+\t }\n+\t memcpy ((void *) src_ptr, GFC_DESCRIPTOR_DATA (opt_src_desc),\n+\t\t src_data_span);\n+\t memcpy (&temp_src_desc, opt_src_desc,\n+\t\t sizeof (gfc_descriptor_t)\n+\t\t + sizeof (descriptor_dimension)\n+\t\t\t* GFC_DESCRIPTOR_RANK (opt_src_desc));\n+\t temp_src_desc.base_addr = (void *) src_ptr;\n+\t src_ptr = (void *) &temp_src_desc;\n+\t}\n+ }\n+\n+ accessor_hash_table[accessor_index].u.receiver (add_data, &image_index,\n+\t\t\t\t\t\t dst_ptr, src_ptr, &cb_token,\n+\t\t\t\t\t\t 0, opt_dst_charlen,\n+\t\t\t\t\t\t opt_src_charlen);\n+\n+ if (old_dst_data_ptr)\n+ ((gfc_descriptor_t *) opt_dst_desc)->base_addr = old_dst_data_ptr;\n+}\n+\n+void\n+_gfortran_caf_transfer_between_remotes (\n+ caf_token_t dst_token, gfc_descriptor_t *opt_dst_desc,\n+ size_t *opt_dst_charlen, const int dst_image_index,\n+ const int dst_access_index, void *dst_add_data,\n+ const size_t dst_add_data_size __attribute__ ((unused)),\n+ caf_token_t src_token, const gfc_descriptor_t *opt_src_desc,\n+ const size_t *opt_src_charlen, const int src_image_index,\n+ const int src_access_index, void *src_add_data,\n+ const size_t src_add_data_size __attribute__ ((unused)),\n+ const size_t src_size, const bool scalar_transfer, int *dst_stat,\n+ int *src_stat, caf_team_t *dst_team, int *dst_team_number,\n+ caf_team_t *src_team, int *src_team_number)\n+{\n+ static const char *out_of_stack_errmsg\n+ = \"Out of stack in coarray transfer between remotes (dst[...] = \"\n+ \"src[...]) expression. Increase stacksize!\";\n+ caf_shmem_token_t src_shmem_token = TOKEN (src_token),\n+\t\t dst_shmem_token = TOKEN (dst_token);\n+ void *src_ptr, *old_src_data_ptr = NULL;\n+ int32_t free_buffer;\n+ void *dst_ptr, *old_dst_data_ptr = NULL;\n+ void *transfer_ptr, *buffer;\n+ GFC_FULL_ARRAY_DESCRIPTOR (GFC_MAX_DIMENSIONS, void) *transfer_desc = NULL;\n+ struct caf_shmem_token cb_token\n+ = {src_add_data, NULL, src_add_data, 0, ~0, false};\n+ int remote_image_index, this_image_index;\n+\n+ if (src_stat)\n+ *src_stat = 0;\n+\n+ if (!check_map_team (&remote_image_index, &this_image_index, src_image_index,\n+\t\t src_team, src_team_number, src_stat))\n+ return;\n+\n+ if (!scalar_transfer)\n+ {\n+ const size_t desc_size = sizeof (*transfer_desc);\n+ transfer_desc = __builtin_alloca (desc_size);\n+ if (!transfer_desc)\n+\t{\n+\t caf_internal_error (out_of_stack_errmsg, src_stat, NULL, 0);\n+\t return;\n+\t}\n+ memset (transfer_desc, 0, desc_size);\n+ transfer_ptr = transfer_desc;\n+ }\n+ else if (opt_dst_charlen)\n+ {\n+ transfer_ptr = __builtin_alloca (*opt_dst_charlen * src_size);\n+ if (!transfer_ptr)\n+\t{\n+\t caf_internal_error (out_of_stack_errmsg, src_stat, NULL, 0);\n+\t return;\n+\t}\n+ }\n+ else\n+ {\n+ buffer = NULL;\n+ transfer_ptr = &buffer;\n+ }\n+\n+ src_ptr\n+ = src_shmem_token->base + remote_image_index * src_shmem_token->image_size;\n+ if (opt_src_desc)\n+ {\n+ old_src_data_ptr = opt_src_desc->base_addr;\n+ ((gfc_descriptor_t *) opt_src_desc)->base_addr = src_ptr;\n+ src_ptr = (void *) opt_src_desc;\n+ }\n+\n+ accessor_hash_table[src_access_index].u.getter (\n+ src_add_data, &src_image_index, transfer_ptr, &free_buffer, src_ptr,\n+ &cb_token, 0, opt_dst_charlen, opt_src_charlen);\n+\n+ if (old_src_data_ptr)\n+ ((gfc_descriptor_t *) opt_src_desc)->base_addr = old_src_data_ptr;\n+\n+ if (dst_stat)\n+ *dst_stat = 0;\n+\n+ if (!check_map_team (&remote_image_index, &this_image_index, dst_image_index,\n+\t\t dst_team, dst_team_number, dst_stat))\n+ return;\n+\n+ if (scalar_transfer)\n+ transfer_ptr = *(void **) transfer_ptr;\n+\n+ dst_ptr\n+ = dst_shmem_token->base + remote_image_index * dst_shmem_token->image_size;\n+ if (opt_dst_desc)\n+ {\n+ old_dst_data_ptr = opt_dst_desc->base_addr;\n+ ((gfc_descriptor_t *) opt_dst_desc)->base_addr = dst_ptr;\n+ dst_ptr = (void *) opt_dst_desc;\n+ }\n+\n+ cb_token.memptr = cb_token.base = dst_add_data;\n+ accessor_hash_table[dst_access_index].u.receiver (dst_add_data,\n+\t\t\t\t\t\t &dst_image_index, dst_ptr,\n+\t\t\t\t\t\t transfer_ptr, &cb_token, 0,\n+\t\t\t\t\t\t opt_dst_charlen,\n+\t\t\t\t\t\t opt_src_charlen);\n+\n+ if (old_dst_data_ptr)\n+ ((gfc_descriptor_t *) opt_dst_desc)->base_addr = old_dst_data_ptr;\n+\n+ if (free_buffer)\n+ free (transfer_desc ? transfer_desc->base_addr : transfer_ptr);\n+}\n+\n+#define GET_ATOM \\\n+ caf_shmem_token_t shmem_token = TOKEN (token); \\\n+ int remote_image_index, this_image_index; \\\n+ if (stat) \\\n+ *stat = 0; \\\n+ if (!image_index) \\\n+ image_index = this_image.image_num + 1; \\\n+ if (!check_map_team (&remote_image_index, &this_image_index, image_index, \\\n+\t\t NULL, NULL, stat)) \\\n+ return; \\\n+ assert (kind == 4); \\\n+ uint32_t *atom \\\n+ = (uint32_t *) (shmem_token->base \\\n+\t\t + remote_image_index * shmem_token->image_size + offset)\n+\n+void\n+_gfortran_caf_atomic_define (caf_token_t token, size_t offset, int image_index,\n+\t\t\t void *value, int *stat,\n+\t\t\t int type __attribute__ ((unused)), int kind)\n+{\n+ GET_ATOM;\n+\n+ __atomic_store (atom, (uint32_t *) value, __ATOMIC_SEQ_CST);\n+}\n+\n+void\n+_gfortran_caf_atomic_ref (caf_token_t token, size_t offset, int image_index,\n+\t\t\t void *value, int *stat,\n+\t\t\t int type __attribute__ ((unused)), int kind)\n+{\n+ GET_ATOM;\n+\n+ __atomic_load (atom, (uint32_t *) value, __ATOMIC_SEQ_CST);\n+}\n+\n+void\n+_gfortran_caf_atomic_cas (caf_token_t token, size_t offset, int image_index,\n+\t\t\t void *old, void *compare, void *new_val, int *stat,\n+\t\t\t int type __attribute__ ((unused)), int kind)\n+{\n+ GET_ATOM;\n+\n+ *(uint32_t *) old = *(uint32_t *) compare;\n+ (void) __atomic_compare_exchange_n (atom, (uint32_t *) old,\n+\t\t\t\t *(uint32_t *) new_val, false,\n+\t\t\t\t __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST);\n+}\n+\n+void\n+_gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,\n+\t\t\t int image_index, void *value, void *old, int *stat,\n+\t\t\t int type __attribute__ ((unused)), int kind)\n+{\n+ GET_ATOM;\n+\n+ uint32_t res;\n+\n+ switch (op)\n+ {\n+ case GFC_CAF_ATOMIC_ADD:\n+ res = __atomic_fetch_add (atom, *(uint32_t *) value, __ATOMIC_SEQ_CST);\n+ break;\n+ case GFC_CAF_ATOMIC_AND:\n+ res = __atomic_fetch_and (atom, *(uint32_t *) value, __ATOMIC_SEQ_CST);\n+ break;\n+ case GFC_CAF_ATOMIC_OR:\n+ res = __atomic_fetch_or (atom, *(uint32_t *) value, __ATOMIC_SEQ_CST);\n+ break;\n+ case GFC_CAF_ATOMIC_XOR:\n+ res = __atomic_fetch_xor (atom, *(uint32_t *) value, __ATOMIC_SEQ_CST);\n+ break;\n+ default:\n+ __builtin_unreachable ();\n+ }\n+\n+ if (old)\n+ *(uint32_t *) old = res;\n+}\n+\n+#define GET_EVENT(token_, index_, image_index_) \\\n+ ((event_t *) (((caf_shmem_token_t) token_)->base \\\n+\t\t+ ((caf_shmem_token_t) token_)->image_size * image_index_ \\\n+\t\t+ sizeof (event_t) * index_))\n+\n+void\n+_gfortran_caf_event_post (caf_token_t token, size_t index, int image_index,\n+\t\t\t int *stat, char *errmsg __attribute__ ((unused)),\n+\t\t\t size_t errmsg_len __attribute__ ((unused)))\n+{\n+ int remote_image_index, this_image_index;\n+\n+ if (stat)\n+ *stat = 0;\n+\n+ /* When image_index is zero, access this image's event. */\n+ if (!image_index)\n+ image_index = this_image.image_num + 1;\n+\n+ if (!check_map_team (&remote_image_index, &this_image_index, image_index,\n+\t\t NULL, NULL, stat))\n+ return;\n+\n+ volatile event_t *event = GET_EVENT (token, index, remote_image_index);\n+\n+ lock_event (&local->si);\n+ --(*event);\n+ event_post (&local->si);\n+ unlock_event (&local->si);\n+}\n+\n+void\n+_gfortran_caf_event_wait (caf_token_t token, size_t index, int until_count,\n+\t\t\t int *stat, char *errmsg __attribute__ ((unused)),\n+\t\t\t size_t errmsg_len __attribute__ ((unused)))\n+{\n+ int remote_image_index, this_image_index;\n+\n+ if (stat)\n+ *stat = 0;\n+\n+ if (!check_map_team (&remote_image_index, &this_image_index, 1, NULL, NULL,\n+\t\t stat))\n+ return;\n+\n+ volatile event_t *event = GET_EVENT (token, index, this_image_index);\n+ event_t val;\n+\n+ lock_event (&local->si);\n+ val = (*event += until_count);\n+ if (val > 0) /* Move the invariant out of the loop. */\n+ while (*event > 0)\n+ event_wait (&local->si);\n+ unlock_event (&local->si);\n+\n+ if (stat)\n+ *stat = 0;\n+}\n+\n+void\n+_gfortran_caf_event_query (caf_token_t token, size_t index, int image_index,\n+\t\t\t int *count, int *stat)\n+{\n+ int remote_image_index, this_image_index;\n+\n+ if (stat)\n+ *stat = 0;\n+\n+ /* When image_index is zero, access this image's event. */\n+ if (!image_index)\n+ image_index = this_image.image_num + 1;\n+\n+ if (!check_map_team (&remote_image_index, &this_image_index, image_index,\n+\t\t NULL, NULL, stat))\n+ return;\n+\n+ volatile event_t *event = GET_EVENT (token, index, remote_image_index);\n+\n+ lock_event (&local->si);\n+ *count = *event;\n+ unlock_event (&local->si);\n+\n+ if (*count < 0)\n+ *count = -*count;\n+}\n+\n+void\n+_gfortran_caf_lock (caf_token_t token, size_t index,\n+\t\t int image_index __attribute__ ((unused)),\n+\t\t int *acquired_lock, int *stat, char *errmsg,\n+\t\t size_t errmsg_len)\n+{\n+ const char *msg = \"Already locked\";\n+ lock_t *lock = &((lock_t *) MEMTOK (token))[index];\n+ int res;\n+\n+ res\n+ = acquired_lock ? pthread_mutex_trylock (lock) : pthread_mutex_lock (lock);\n+\n+ if (stat)\n+ *stat = res == EBUSY ? GFC_STAT_LOCKED : 0;\n+\n+ if (acquired_lock)\n+ {\n+ *acquired_lock = (int) (res == 0);\n+ return;\n+ }\n+\n+ if (!res)\n+ return;\n+\n+ if (stat)\n+ {\n+ if (errmsg_len > 0)\n+\t{\n+\t size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len\n+\t\t\t\t\t\t : sizeof (msg);\n+\t memcpy (errmsg, msg, len);\n+\t if (errmsg_len > len)\n+\t memset (&errmsg[len], ' ', errmsg_len-len);\n+\t}\n+ return;\n+ }\n+ _gfortran_caf_error_stop_str (msg, strlen (msg), false);\n+}\n+\n+\n+void\n+_gfortran_caf_unlock (caf_token_t token, size_t index,\n+\t\t int image_index __attribute__ ((unused)),\n+\t\t int *stat, char *errmsg, size_t errmsg_len)\n+{\n+ const char *msg = \"Variable is not locked\";\n+ lock_t *lock = &((lock_t *) MEMTOK (token))[index];\n+ int res;\n+\n+ res = pthread_mutex_unlock (lock);\n+\n+ if (res == 0)\n+ {\n+ if (stat)\n+\t*stat = 0;\n+ return;\n+ }\n+\n+ if (stat && res == EPERM)\n+ {\n+ /* res == EPERM means that the lock is locked. Now figure, if by us by\n+\t trying to lock it or by other image, which fails. */\n+ res = pthread_mutex_trylock (lock);\n+ if (res == EBUSY)\n+\t*stat = GFC_STAT_LOCKED_OTHER_IMAGE;\n+ else\n+\t{\n+\t *stat = GFC_STAT_UNLOCKED;\n+\t pthread_mutex_unlock (lock);\n+\t}\n+\n+ if (errmsg_len > 0)\n+\t{\n+\t size_t len = (sizeof (msg) > errmsg_len) ? errmsg_len\n+\t : sizeof (msg);\n+\t memcpy (errmsg, msg, len);\n+\t if (errmsg_len > len)\n+\t memset (&errmsg[len], ' ', errmsg_len-len);\n+\t}\n+ return;\n+ }\n+ _gfortran_caf_error_stop_str (msg, strlen (msg), false);\n+}\n+\n+\n+/* Reference the libraries implementation. */\n+extern void _gfortran_random_seed_i4 (int32_t *size, gfc_array_i4 *put,\n+\t\t\t\t gfc_array_i4 *get);\n+\n+void _gfortran_caf_random_init (bool repeatable, bool image_distinct)\n+{\n+ static struct\n+ {\n+ int32_t *base_addr;\n+ size_t offset;\n+ dtype_type dtype;\n+ index_type span;\n+ descriptor_dimension dim[1];\n+ } rand_seed;\n+ static bool rep_needs_init = true, arr_needs_init = true;\n+ static int32_t seed_size;\n+\n+ if (arr_needs_init)\n+ {\n+ _gfortran_random_seed_i4 (&seed_size, NULL, NULL);\n+ memset (&rand_seed, 0,\n+\t sizeof (gfc_array_i4) + sizeof (descriptor_dimension));\n+ rand_seed.base_addr\n+\t= malloc (seed_size * sizeof (int32_t)); // because using seed_i4\n+ rand_seed.offset = -1;\n+ rand_seed.dtype.elem_len = sizeof (int32_t);\n+ rand_seed.dtype.rank = 1;\n+ rand_seed.dtype.type = BT_INTEGER;\n+ rand_seed.span = 0;\n+ rand_seed.dim[0].lower_bound = 1;\n+ rand_seed.dim[0]._ubound = seed_size;\n+ rand_seed.dim[0]._stride = 1;\n+\n+ arr_needs_init = false;\n+ }\n+\n+ if (repeatable)\n+ {\n+ if (rep_needs_init)\n+\t{\n+\t int32_t lcg_seed = 57911963;\n+\t if (image_distinct)\n+\t {\n+\t lcg_seed *= this_image.image_num;\n+\t }\n+\t int32_t *curr = rand_seed.base_addr;\n+\t for (int i = 0; i < seed_size; ++i)\n+\t {\n+\t const int32_t a = 16087;\n+\t const int32_t m = INT32_MAX;\n+\t const int32_t q = 127773;\n+\t const int32_t r = 2836;\n+\t lcg_seed = a * (lcg_seed % q) - r * (lcg_seed / q);\n+\t if (lcg_seed <= 0)\n+\t\tlcg_seed += m;\n+\t *curr = lcg_seed;\n+\t ++curr;\n+\t }\n+\t rep_needs_init = false;\n+\t}\n+ _gfortran_random_seed_i4 (NULL, (gfc_array_i4 *) &rand_seed, NULL);\n+ }\n+ else if (image_distinct)\n+ {\n+ _gfortran_random_seed_i4 (NULL, NULL, NULL);\n+ }\n+ else\n+ {\n+ if (this_image.image_num == 0)\n+\t{\n+\t _gfortran_random_seed_i4 (NULL, NULL, (gfc_array_i4 *) &rand_seed);\n+\t collsub_broadcast_array ((gfc_descriptor_t *) &rand_seed, 0);\n+\t}\n+ else\n+\t{\n+\t collsub_broadcast_array ((gfc_descriptor_t *) &rand_seed, 0);\n+\t _gfortran_random_seed_i4 (NULL, (gfc_array_i4 *) &rand_seed, NULL);\n+\t}\n+ }\n+}\n+\n+void\n+_gfortran_caf_form_team (int team_no, caf_team_t *team, int *new_index,\n+\t\t\t int *stat, char *errmsg, size_t errmsg_len)\n+{\n+ const char new_index_out_of_range[]\n+ = \"The NEW_INDEX in a FORM TEAM has to in (0, num_images()].\";\n+ const char team_no_negativ[]\n+ = \"The team number in FORM TEAM has to be positive.\";\n+ const char alloc_fail_msg[] = \"Failed to allocate team\";\n+ const char non_unique_image_ids[]\n+ = \"The NEW_INDEX of FORM TEAMs has to be unique.\";\n+ const char cannot_assign_index[]\n+ = \"Can not assign new image index in FORM TEAM.\";\n+ static int image_size_shift = -1;\n+ static int teams_count = 0;\n+ caf_shmem_team_t t;\n+ bool created;\n+ memid tmemid;\n+\n+ if (image_size_shift < 0)\n+ image_size_shift = (int) round (log2 (local->total_num_images));\n+ if (stat)\n+ *stat = 0;\n+\n+ CHECK_TEAM_INTEGRITY (caf_current_team);\n+\n+ if (new_index\n+ && (*new_index <= 0\n+\t || *new_index > caf_current_team->u.image_info->image_count.count))\n+ {\n+ caf_internal_error (new_index_out_of_range, stat, errmsg, errmsg_len);\n+ return;\n+ }\n+ if (team_no <= 0)\n+ {\n+ caf_internal_error (team_no_negativ, stat, errmsg, errmsg_len);\n+ return;\n+ }\n+\n+ *team = malloc (sizeof (struct caf_shmem_team));\n+ if (unlikely (*team == NULL))\n+ {\n+ caf_internal_error (alloc_fail_msg, stat, errmsg, errmsg_len);\n+ return;\n+ }\n+ t = *((caf_shmem_team_t *) team);\n+\n+ allocator_lock (&local->ai.alloc);\n+ if (caf_current_team->team_no == -1)\n+ tmemid = team_no + teams_count;\n+ else\n+ tmemid = (caf_current_team->u.image_info->lastmemid << image_size_shift)\n+\t + team_no + teams_count;\n+ ++teams_count;\n+ *t = (struct caf_shmem_team) {\n+ caf_teams_formed,\n+ team_no,\n+ -1,\n+ 0,\n+ NULL,\n+ {alloc_get_memory_by_id_created (\n+ &local->ai,\n+ sizeof (struct shmem_image_info)\n+\t+ caf_current_team->u.image_info->image_count.count * sizeof (int),\n+ -tmemid, &created)}};\n+\n+ if (created)\n+ {\n+ counter_barrier_init (&t->u.image_info->image_count, 0);\n+ collsub_init_supervisor (&t->u.image_info->collsub,\n+\t\t\t alloc_get_allocator (&local->ai), 0);\n+ t->u.image_info->team_parent_id = caf_current_team->team_no;\n+ t->u.image_info->team_id = team_no;\n+ t->u.image_info->image_map_size = 0;\n+ t->u.image_info->num_term_images = 0;\n+ t->u.image_info->lastmemid = tmemid;\n+ /* Initialize a freshly created image_map with -1. */\n+ for (int i = 0; i < caf_current_team->u.image_info->image_count.count;\n+\t ++i)\n+\tt->u.image_info->image_map[i] = -1;\n+ }\n+ counter_barrier_add (&t->u.image_info->image_count, 1);\n+ counter_barrier_add (&t->u.image_info->collsub.barrier, 1);\n+ allocator_unlock (&local->ai.alloc);\n+\n+ if (new_index)\n+ {\n+ int old_id;\n+\n+ t->index = *new_index - 1;\n+ old_id = __atomic_exchange_n (&t->u.image_info->image_map[t->index],\n+\t\t\t\t this_image.image_num, __ATOMIC_SEQ_CST);\n+ if (old_id != -1)\n+\t{\n+\t caf_internal_error (non_unique_image_ids, stat, errmsg, errmsg_len);\n+\t return;\n+\t}\n+\n+ __atomic_fetch_add (&t->u.image_info->image_map_size, 1,\n+\t\t\t __ATOMIC_SEQ_CST);\n+ }\n+ else\n+ {\n+ int im;\n+ int exp = -1;\n+\n+ __atomic_fetch_add (&t->u.image_info->image_map_size, 1,\n+\t\t\t __ATOMIC_SEQ_CST);\n+ sync_team (caf_current_team);\n+\n+ im = caf_current_team->index * t->u.image_info->image_map_size\n+\t / caf_current_team->u.image_info->image_count.count;\n+ /* Map our old index into the domain of the new team's size. */\n+ if (__atomic_compare_exchange_n (&t->u.image_info->image_map[im], &exp,\n+\t\t\t\t this_image.image_num, false,\n+\t\t\t\t __ATOMIC_SEQ_CST, __ATOMIC_SEQ_CST))\n+\tt->index = im;\n+ else\n+\t{\n+\t caf_internal_error (cannot_assign_index, stat, errmsg, errmsg_len);\n+\t return;\n+\t}\n+ }\n+ sync_team (caf_current_team);\n+\n+ caf_teams_formed = t;\n+}\n+\n+void\n+_gfortran_caf_change_team (caf_team_t team, int *stat,\n+\t\t\t char *errmsg __attribute__ ((unused)),\n+\t\t\t size_t errmsg_len __attribute__ ((unused)))\n+{\n+ caf_shmem_team_t t = (caf_shmem_team_t) team;\n+\n+ if (stat)\n+ *stat = 0;\n+\n+ if (t == caf_teams_formed)\n+ caf_teams_formed = t->parent;\n+ else\n+ for (caf_shmem_team_t p = caf_teams_formed; p; p = p->parent)\n+ if (p->parent == t)\n+\t{\n+\t p->parent = t->parent;\n+\t break;\n+\t}\n+\n+ t->parent = caf_current_team;\n+ t->parent_teams_last_active_memid = next_memid;\n+ next_memid = (t->u.image_info->team_parent_id != -1\n+\t\t ? (((memid) t->u.image_info->team_parent_id) << 48)\n+\t\t : 0)\n+\t | (((memid) t->u.image_info->team_id) << 32) | 1;\n+ caf_current_team = t;\n+ sync_team (caf_current_team);\n+}\n+\n+void\n+_gfortran_caf_end_team (int *stat, char *errmsg, size_t errmsg_len)\n+{\n+ caf_shmem_team_t t = caf_current_team;\n+\n+ if (stat)\n+ *stat = 0;\n+\n+ caf_current_team = caf_current_team->parent;\n+ next_memid = t->parent_teams_last_active_memid;\n+ sync_team (t);\n+\n+ for (struct coarray_allocated *ca = t->allocated; ca;)\n+ {\n+ struct coarray_allocated *nca = ca->next;\n+ _gfortran_caf_deregister ((caf_token_t *) &ca->token,\n+\t\t\t\tCAF_DEREGTYPE_COARRAY_DEALLOCATE_ONLY, stat,\n+\t\t\t\terrmsg, errmsg_len);\n+ free (ca);\n+ ca = nca;\n+ }\n+ t->allocated = NULL;\n+ t->parent = caf_teams_formed;\n+ caf_teams_formed = t;\n+}\n+\n+void\n+_gfortran_caf_sync_team (caf_team_t team, int *stat, char *errmsg,\n+\t\t\t size_t errmsg_len)\n+{\n+ caf_shmem_team_t team_to_sync = (caf_shmem_team_t) team;\n+ caf_shmem_team_t active_team = caf_current_team;\n+\n+ if (stat)\n+ *stat = 0;\n+\n+ /* Check if team to sync is a child of the current team, aka not changed to\n+ yet. */\n+ if (team_to_sync->u.image_info->team_parent_id != active_team->team_no)\n+ for (; active_team && active_team != team_to_sync;\n+\t active_team = active_team->parent)\n+ ;\n+\n+ CHECK_TEAM_INTEGRITY (active_team);\n+\n+ if (!active_team)\n+ {\n+ caf_internal_error (\"SYNC TEAM: Called on team different from current, \"\n+\t\t\t \"or ancestor, or child\",\n+\t\t\t stat, errmsg, errmsg_len);\n+ return;\n+ }\n+\n+ sync_team (team_to_sync);\n+}\n+\n+int\n+_gfortran_caf_team_number (caf_team_t team)\n+{\n+ return team ? ((caf_shmem_team_t) team)->u.image_info->team_id\n+\t : caf_current_team->u.image_info->team_id;\n+}\n+\n+caf_team_t\n+_gfortran_caf_get_team (int32_t *level)\n+{\n+ if (!level)\n+ return caf_current_team;\n+\n+ switch ((caf_team_level_t) *level)\n+ {\n+ case CAF_INITIAL_TEAM:\n+ return caf_initial_team;\n+ case CAF_PARENT_TEAM:\n+ return caf_current_team->parent ? caf_current_team->parent\n+\t\t\t\t : caf_current_team;\n+ case CAF_CURRENT_TEAM:\n+ return caf_current_team;\n+ default:\n+ caf_runtime_error (\"Illegal value for GET_TEAM\");\n+ }\n+ return NULL; /* To prevent any warnings. */\n+}\ndiff --git a/libgfortran/caf/shmem/alloc.c b/libgfortran/caf/shmem/alloc.c\nnew file mode 100644\nindex 00000000000..fecf97c03ff\n--- /dev/null\n+++ b/libgfortran/caf/shmem/alloc.c\n@@ -0,0 +1,168 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+/* This provides the coarray-specific features (like IDs etc) for\n+ allocator.c, in turn calling routines from shared_memory.c.\n+*/\n+\n+#include \"alloc.h\"\n+#include \"../caf_error.h\"\n+#include \"supervisor.h\"\n+#include \"shared_memory.h\"\n+\n+#include <assert.h>\n+#include <pthread.h>\n+#include <string.h>\n+\n+/* Worker's part to initialize the alloc interface. */\n+\n+void\n+alloc_init (alloc *iface, shared_memory mem)\n+{\n+ iface->as = &this_image.supervisor->alloc_shared;\n+ iface->mem = mem;\n+ allocator_init (&iface->alloc, &iface->as->allocator_s, mem);\n+ hashmap_init (&iface->hm, &this_image.supervisor->hms, &iface->alloc);\n+}\n+\n+/* Allocate the shared memory interface. This is called before we have\n+ multiple images. Called only by supervisor. */\n+\n+void\n+alloc_init_supervisor (alloc *iface, shared_memory mem)\n+{\n+ iface->as = &this_image.supervisor->alloc_shared;\n+ iface->mem = mem;\n+ allocator_init_supervisor (&iface->alloc, &iface->as->allocator_s, mem);\n+ hashmap_init_supervisor (&iface->hm, &this_image.supervisor->hms,\n+\t\t\t &iface->alloc);\n+}\n+\n+/* Return a local pointer into a shared memory object identified by\n+ id. If the object is already found, it has been allocated before,\n+ so just increase the reference counter.\n+\n+ The pointers returned by this function remain valid even if the\n+ size of the memory allocation changes (see shared_memory.c). */\n+\n+static void *\n+get_memory_by_id_internal (alloc *iface, size_t size, memid id, bool *created)\n+{\n+ hashmap_search_result res;\n+ shared_mem_ptr shared_ptr;\n+ void *ret;\n+\n+ shared_memory_prepare (iface->mem);\n+\n+ res = hashmap_get (&iface->hm, id);\n+\n+ if (hm_search_result_contains (&res))\n+ {\n+ size_t found_size;\n+ found_size = hm_search_result_size (&res);\n+ if (found_size < size)\n+\t{\n+\t allocator_unlock (&iface->alloc);\n+\t caf_runtime_error (\n+\t \"Size mismatch for coarray allocation id %zd: found = %lu \"\n+\t \"< size = %lu\\n\",\n+\t id, found_size, size);\n+\t return NULL; // The runtime_error exit()s, so this is never reached.\n+\t}\n+ shared_ptr = hm_search_result_ptr (&res);\n+ hashmap_inc (&iface->hm, id, &res);\n+\n+ if (created)\n+\t*created = false;\n+ ret = SHMPTR_AS (void *, shared_ptr, iface->mem);\n+ }\n+ else\n+ {\n+ shared_ptr = allocator_shared_malloc (&iface->alloc, size);\n+ hashmap_set (&iface->hm, id, NULL, shared_ptr, size);\n+\n+ if (created)\n+\t*created = true;\n+\n+ ret = SHMPTR_AS (void *, shared_ptr, iface->mem);\n+ }\n+\n+ return ret;\n+}\n+\n+void *\n+alloc_get_memory_by_id (alloc *iface, size_t size, memid id)\n+{\n+ allocator_lock (&iface->alloc);\n+ void *ret = get_memory_by_id_internal (iface, size, id, NULL);\n+ allocator_unlock (&iface->alloc);\n+ return ret;\n+}\n+\n+void *\n+alloc_get_memory_by_id_created (alloc *iface, size_t size, memid id,\n+\t\t\t\tbool *created)\n+{\n+ return get_memory_by_id_internal (iface, size, id, created);\n+}\n+\n+\n+/* Free memory with id. Free it if this is the last image which\n+ holds that memory segment, decrease the reference count otherwise. */\n+\n+void\n+alloc_free_memory_with_id (alloc *iface, memid id)\n+{\n+ hashmap_search_result res;\n+ int entries_left;\n+\n+ allocator_lock (&iface->alloc);\n+ shared_memory_prepare (iface->mem);\n+\n+ res = hashmap_get (&iface->hm, id);\n+ if (!hm_search_result_contains (&res))\n+ {\n+ allocator_unlock (&iface->alloc);\n+ caf_runtime_error (\"Error in free_memory_with_id: %zd not found.\\n\", id);\n+ return;\n+ }\n+\n+ entries_left = hashmap_dec (&iface->hm, id, &res);\n+ assert (entries_left >= 0);\n+\n+ if (entries_left == 0)\n+ {\n+ allocator_shared_free (&iface->alloc, hm_search_result_ptr (&res),\n+\t\t\t hm_search_result_size (&res));\n+ }\n+\n+ allocator_unlock (&iface->alloc);\n+ return;\n+}\n+\n+allocator *\n+alloc_get_allocator (alloc *iface)\n+{\n+ return &iface->alloc;\n+}\ndiff --git a/libgfortran/caf/shmem/alloc.h b/libgfortran/caf/shmem/alloc.h\nnew file mode 100644\nindex 00000000000..d85b1a30236\n--- /dev/null\n+++ b/libgfortran/caf/shmem/alloc.h\n@@ -0,0 +1,80 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#ifndef ALLOC_H\n+#define ALLOC_H\n+\n+#include \"allocator.h\"\n+#include \"hashmap.h\"\n+\n+/* High-level interface for shared memory allocation.\n+ Handle allocation and freeing of blocks in the shared memory for coarrays.\n+ While allocator keeps track of allocated and freeed portions, this \"class\"\n+ allows allocation of coarrays identified by a memid and associate them\n+ across images.\n+ */\n+\n+/* The part of the alloc interface being shared with all other images. There\n+ must be only one of these objects! */\n+typedef struct alloc_shared\n+{\n+ allocator_shared allocator_s;\n+} alloc_shared;\n+\n+/* This is the image's local part of the alloc interface. */\n+\n+typedef struct alloc\n+{\n+ alloc_shared *as;\n+ shared_memory mem;\n+ allocator alloc;\n+ hashmap hm;\n+} alloc;\n+\n+/* Initialize the local instance of the alloc interface. This routine is to be\n+ called by every worker image and NOT by the supervisor. */\n+void alloc_init (alloc *, shared_memory);\n+\n+/* The routine MUST ONLY called by the supervisor process.\n+ Initialize the shared part of the alloc interface. The local one is only\n+ initialized to be able to pass it to the other components needing it. */\n+void alloc_init_supervisor (alloc *, shared_memory);\n+\n+/* Get a shared memory block identified by id, or a new one, when the id\n+ is not known yet. This routine locks the allocator lock itself. */\n+void *alloc_get_memory_by_id (alloc *, size_t, memid);\n+\n+/* Same as alloc_get_memory_by_id, but it does not lock the allocator lock and\n+ returns an additional bool, that is true, when the memory has been allocated\n+ freshly. */\n+void *alloc_get_memory_by_id_created (alloc *, size_t, memid, bool *);\n+\n+/* Mark the memory identified by id as free. This reduces the use counter on\n+ the memory and sets is free, when the count goes to zero. */\n+void alloc_free_memory_with_id (alloc *, memid);\n+\n+/* Get the allocator for reuse in other interfaces. */\n+allocator *alloc_get_allocator (alloc *);\n+\n+#endif\ndiff --git a/libgfortran/caf/shmem/allocator.c b/libgfortran/caf/shmem/allocator.c\nnew file mode 100644\nindex 00000000000..d900167cfc2\n--- /dev/null\n+++ b/libgfortran/caf/shmem/allocator.c\n@@ -0,0 +1,131 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+/* Main allocation routine, works like malloc. Round up allocations\n+ to the next power of two and keep free lists in buckets. */\n+\n+#include \"libgfortran.h\"\n+\n+#include \"allocator.h\"\n+#include \"supervisor.h\"\n+#include \"thread_support.h\"\n+\n+#include <assert.h>\n+\n+typedef struct\n+{\n+ shared_mem_ptr next;\n+} bucket;\n+\n+size_t\n+alignto (size_t size, size_t align)\n+{\n+ return align * ((size + align - 1) / align);\n+}\n+\n+size_t pagesize;\n+\n+size_t\n+round_to_pagesize (size_t s)\n+{\n+ return alignto (s, pagesize);\n+}\n+\n+/* Initialize the allocator. */\n+\n+void\n+allocator_init (allocator *a, allocator_shared *s, shared_memory sm)\n+{\n+ *a = (allocator) {s, sm};\n+}\n+\n+void\n+allocator_init_supervisor (allocator *a, allocator_shared *s, shared_memory sm)\n+{\n+ *a = (allocator) {s, sm};\n+ initialize_shared_mutex (&s->lock);\n+ for (size_t i = 0; i < VOIDP_BITS; i++)\n+ s->free_bucket_head[i] = SHMPTR_NULL;\n+}\n+\n+#define MAX_ALIGN 16\n+\n+static size_t\n+next_power_of_two (size_t size)\n+{\n+ assert (size);\n+ return 1 << (VOIDP_BITS - __builtin_clzl (size - 1));\n+}\n+\n+shared_mem_ptr\n+allocator_shared_malloc (allocator *a, size_t size)\n+{\n+ shared_mem_ptr ret;\n+ size_t sz;\n+ size_t act_size;\n+ int bucket_list_index;\n+\n+ sz = next_power_of_two (size);\n+ act_size = sz > sizeof (bucket) ? sz : sizeof (bucket);\n+ bucket_list_index = __builtin_clzl (act_size);\n+\n+ if (SHMPTR_IS_NULL (a->s->free_bucket_head[bucket_list_index]))\n+ return shared_memory_get_mem_with_alignment (a->shm, act_size, MAX_ALIGN);\n+\n+ ret = a->s->free_bucket_head[bucket_list_index];\n+ a->s->free_bucket_head[bucket_list_index]\n+ = (SHMPTR_AS (bucket *, ret, a->shm)->next);\n+ return ret;\n+}\n+\n+/* Free memory. */\n+\n+void\n+allocator_shared_free (allocator *a, shared_mem_ptr p, size_t size)\n+{\n+ bucket *b;\n+ size_t sz;\n+ int bucket_list_index;\n+ size_t act_size;\n+\n+ sz = next_power_of_two (size);\n+ act_size = sz > sizeof (bucket) ? sz : sizeof (bucket);\n+ bucket_list_index = __builtin_clzl (act_size);\n+\n+ b = SHMPTR_AS (bucket *, p, a->shm);\n+ b->next = a->s->free_bucket_head[bucket_list_index];\n+ a->s->free_bucket_head[bucket_list_index] = p;\n+}\n+\n+void\n+allocator_lock (allocator *a)\n+{\n+ pthread_mutex_lock (&a->s->lock);\n+}\n+\n+void\n+allocator_unlock (allocator *a)\n+{\n+ pthread_mutex_unlock (&a->s->lock);\n+}\ndiff --git a/libgfortran/caf/shmem/allocator.h b/libgfortran/caf/shmem/allocator.h\nnew file mode 100644\nindex 00000000000..53b6abeeba1\n--- /dev/null\n+++ b/libgfortran/caf/shmem/allocator.h\n@@ -0,0 +1,88 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+/* A malloc() - and free() - like interface, but for shared memory\n+ pointers, except that we pass the size to free as well. */\n+\n+#ifndef ALLOCATOR_HDR\n+#define ALLOCATOR_HDR\n+\n+#include \"shared_memory.h\"\n+\n+#include <stddef.h>\n+#include <pthread.h>\n+\n+/* The number of bits a void pointer has. */\n+#define VOIDP_BITS (__CHAR_BIT__ * sizeof (void *))\n+\n+/* The shared memory part of the allocator. */\n+typedef struct {\n+ pthread_mutex_t lock;\n+ shared_mem_ptr free_bucket_head[VOIDP_BITS];\n+} allocator_shared;\n+\n+/* The image local part of the allocator. */\n+typedef struct {\n+ allocator_shared *s;\n+ shared_memory shm;\n+} allocator;\n+\n+/* The size of a page on this architecture. */\n+extern size_t pagesize;\n+\n+/* Helper routine to align a size to a given boundary. */\n+size_t alignto (size_t, size_t);\n+\n+/* Helper routine to round a size to multiple of the architecture's pagesize.\n+ */\n+size_t round_to_pagesize (size_t);\n+\n+/* Link the worker's allocator with the part in the shared memory. */\n+void allocator_init (allocator *, allocator_shared *, shared_memory);\n+\n+/* Initialize the allocator. This MUST be called ONLY be the supervisor and\n+ only once! */\n+void allocator_init_supervisor (allocator *, allocator_shared *, shared_memory);\n+\n+/* Request a block of shared memory. The memory is not linked with the other\n+ images. The shared_mem_ptr returned is only local to the calling image.\n+ When requiring a memory block shared between all images, call\n+ alloc_get_memory_by_id...(). */\n+shared_mem_ptr allocator_shared_malloc (allocator *, size_t size);\n+\n+/* Free the given piece of memory. This routine just inserts the memory chunk\n+ into the bucket list of free memory. It does not join adjacent blocks of\n+ memory (not implemented yet). */\n+void allocator_shared_free (allocator *, shared_mem_ptr, size_t size);\n+\n+/* Lock the allocator lock preventing any image from modifying memory management\n+ structures. Do not forget to unlock. This interface is exposed to be able\n+ to do more then just get the memory without having to introduce a second lock\n+ and the problems with having to get both. */\n+void allocator_lock (allocator *);\n+\n+/* Unlock the allocator lock. */\n+void allocator_unlock (allocator *);\n+\n+#endif\ndiff --git a/libgfortran/caf/shmem/collective_subroutine.c b/libgfortran/caf/shmem/collective_subroutine.c\nnew file mode 100644\nindex 00000000000..257a048d63d\n--- /dev/null\n+++ b/libgfortran/caf/shmem/collective_subroutine.c\n@@ -0,0 +1,434 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#include \"collective_subroutine.h\"\n+#include \"supervisor.h\"\n+#include \"teams_mgmt.h\"\n+#include \"thread_support.h\"\n+\n+#include <string.h>\n+\n+/* Usage:\n+ pack_info pi;\n+ packed = pack_array_prepare (&pi, source);\n+\n+ // Awesome allocation of destptr using pi.num_elem\n+ if (packed)\n+ memcpy (...);\n+ else\n+ pack_array_finish (&pi, source, destptr);\n+\n+This could also be used in in_pack_generic.c. Additionally, since\n+pack_array_prepare is the same for all type sizes, we would only have to\n+specialize pack_array_finish, saving on code size. */\n+\n+typedef struct\n+{\n+ index_type num_elem;\n+ index_type extent[GFC_MAX_DIMENSIONS];\n+ index_type stride[GFC_MAX_DIMENSIONS]; /* Stride is byte-based. */\n+} pack_info;\n+\n+static bool\n+pack_array_prepare (pack_info *pi, const gfc_descriptor_t *source)\n+{\n+ index_type dim;\n+ bool packed;\n+ index_type span;\n+ index_type type_size;\n+ index_type ssize;\n+\n+ dim = GFC_DESCRIPTOR_RANK (source);\n+ type_size = GFC_DESCRIPTOR_SIZE (source);\n+ ssize = type_size;\n+\n+ pi->num_elem = 1;\n+ packed = true;\n+ span = source->span != 0 ? source->span : type_size;\n+ for (index_type n = 0; n < dim; n++)\n+ {\n+ pi->stride[n] = GFC_DESCRIPTOR_STRIDE (source, n) * span;\n+ pi->extent[n] = GFC_DESCRIPTOR_EXTENT (source, n);\n+ if (pi->extent[n] <= 0)\n+\t{\n+\t /* Do nothing. */\n+\t packed = true;\n+\t pi->num_elem = 0;\n+\t break;\n+\t}\n+\n+ if (ssize != pi->stride[n])\n+\tpacked = false;\n+\n+ pi->num_elem *= pi->extent[n];\n+ ssize *= pi->extent[n];\n+ }\n+\n+ return packed;\n+}\n+\n+static void\n+pack_array_finish (const pack_info *pi, const gfc_descriptor_t *source,\n+\t\t char *dest)\n+{\n+ index_type dim;\n+ const char *restrict src;\n+\n+ index_type size;\n+ index_type stride0;\n+ index_type count[GFC_MAX_DIMENSIONS];\n+\n+ dim = GFC_DESCRIPTOR_RANK (source);\n+ src = source->base_addr;\n+ stride0 = pi->stride[0];\n+ size = GFC_DESCRIPTOR_SIZE (source);\n+ memset (count, '\\0', sizeof (index_type) * dim);\n+ while (src)\n+ {\n+ /* Copy the data. */\n+ memcpy (dest, src, size);\n+ /* Advance to the next element. */\n+ dest += size;\n+ src += stride0;\n+ count[0]++;\n+ /* Advance to the next source element. */\n+ index_type n = 0;\n+ while (count[n] == pi->extent[n])\n+\t{\n+\t /* When we get to the end of a dimension, reset it and increment\n+\t the next dimension. */\n+\t count[n] = 0;\n+\t /* We could precalculate these products, but this is a less\n+\t frequently used path so probably not worth it. */\n+\t src -= pi->stride[n] * pi->extent[n];\n+\t n++;\n+\t if (n == dim)\n+\t {\n+\t src = NULL;\n+\t break;\n+\t }\n+\t else\n+\t {\n+\t count[n]++;\n+\t src += pi->stride[n];\n+\t }\n+\t}\n+ }\n+}\n+\n+static void\n+unpack_array_finish (const pack_info *pi, const gfc_descriptor_t *d,\n+\t\t const void *src)\n+{\n+ index_type stride0;\n+ char *restrict dest;\n+ index_type size;\n+ index_type count[GFC_MAX_DIMENSIONS];\n+ index_type dim;\n+\n+ size = GFC_DESCRIPTOR_SIZE (d);\n+ stride0 = pi->stride[0];\n+ dest = d->base_addr;\n+ dim = GFC_DESCRIPTOR_RANK (d);\n+\n+ memset (count, '\\0', sizeof (index_type) * dim);\n+ while (dest)\n+ {\n+ memcpy (dest, src, size);\n+ src += size;\n+ dest += stride0;\n+ count[0]++;\n+ index_type n = 0;\n+ while (count[n] == pi->extent[n])\n+\t{\n+\t count[n] = 0;\n+\t dest -= pi->stride[n] * pi->extent[n];\n+\t n++;\n+\t if (n == dim)\n+\t {\n+\t dest = NULL;\n+\t break;\n+\t }\n+\t else\n+\t {\n+\t count[n]++;\n+\t dest += pi->stride[n];\n+\t }\n+\t}\n+ }\n+}\n+\n+void\n+collsub_init_supervisor (collsub_shared *cis, allocator *al,\n+\t\t\t const int init_num_images)\n+{\n+ /* Choose an arbitrary large buffer. It can grow later if needed. */\n+ const size_t init_size = 1U << 10;\n+\n+ cis->curr_size = init_size;\n+ cis->collsub_buf = allocator_shared_malloc (al, init_size);\n+\n+ counter_barrier_init (&cis->barrier, init_num_images);\n+ initialize_shared_mutex (&cis->mutex);\n+}\n+\n+static void *\n+get_collsub_buf (size_t size)\n+{\n+ void *ret;\n+\n+ pthread_mutex_lock (&caf_current_team->u.image_info->collsub.mutex);\n+ /* curr_size is always at least sizeof(double), so we don't need to worry\n+ about size == 0. */\n+ if (size > caf_current_team->u.image_info->collsub.curr_size)\n+ {\n+ allocator_shared_free (\n+\talloc_get_allocator (&local->ai),\n+\tcaf_current_team->u.image_info->collsub.collsub_buf,\n+\tcaf_current_team->u.image_info->collsub.curr_size);\n+ caf_current_team->u.image_info->collsub.collsub_buf\n+\t= allocator_shared_malloc (alloc_get_allocator (&local->ai), size);\n+ caf_current_team->u.image_info->collsub.curr_size = size;\n+ }\n+\n+ ret = SHMPTR_AS (void *, caf_current_team->u.image_info->collsub.collsub_buf,\n+\t\t &local->sm);\n+ pthread_mutex_unlock (&caf_current_team->u.image_info->collsub.mutex);\n+ return ret;\n+}\n+\n+/* This function syncs all images with one another. It will only return once\n+ all images have called it. */\n+\n+static void\n+collsub_sync (void)\n+{\n+ counter_barrier_wait (&caf_current_team->u.image_info->collsub.barrier);\n+}\n+\n+typedef void *(*red_op) (void *, void *);\n+typedef void (*ass_op) (red_op, void *, void *, size_t);\n+\n+#define GEN_FOR_BITS(BITS) \\\n+ static void assign_##BITS (void *op, uint##BITS##_t *lhs, \\\n+\t\t\t uint##BITS##_t *rhs, size_t) \\\n+ { \\\n+ *lhs \\\n+ = ((uint##BITS##_t (*) (uint##BITS##_t *, uint##BITS##_t *)) op) (lhs, \\\n+\t\t\t\t\t\t\t\t\trhs); \\\n+ } \\\n+ static void assign_by_val_##BITS (void *op, uint##BITS##_t *lhs, \\\n+\t\t\t\t uint##BITS##_t *rhs, size_t) \\\n+ { \\\n+ *lhs = ((uint##BITS##_t (*) (uint##BITS##_t, uint##BITS##_t)) op) (*lhs, \\\n+\t\t\t\t\t\t\t\t *rhs); \\\n+ }\n+\n+GEN_FOR_BITS (8)\n+GEN_FOR_BITS (16)\n+GEN_FOR_BITS (32)\n+GEN_FOR_BITS (64)\n+// GEN_FOR_BITS (128)\n+\n+static void\n+assign_float (void *op, float *lhs, float *rhs, size_t)\n+{\n+ *lhs = ((float (*) (float *, float *)) op) (lhs, rhs);\n+}\n+\n+static void\n+assign_double (void *op, double *lhs, double *rhs, size_t)\n+{\n+ *lhs = ((double (*) (double *, double *)) op) (lhs, rhs);\n+}\n+\n+static void\n+assign_var (red_op op, void *lhs, void *rhs, size_t sz)\n+{\n+ memcpy (lhs, op (lhs, rhs), sz);\n+}\n+\n+static void\n+assign_char (void *op, void *lhs, void *rhs, size_t sz)\n+{\n+ ((void (*) (char *, size_t, char *, char *, size_t,\n+\t size_t)) op) (lhs, sz, lhs, rhs, sz, sz);\n+}\n+\n+static ass_op\n+gen_reduction (const int type, const size_t sz, const int flags)\n+{\n+ const bool by_val = flags & GFC_CAF_ARG_VALUE;\n+ switch (type)\n+ {\n+ case BT_CHARACTER:\n+ return (ass_op) assign_char;\n+ case BT_REAL:\n+ switch (sz)\n+\t{\n+\tcase 4:\n+\t return (ass_op) assign_float;\n+\tcase 8:\n+\t return (ass_op) assign_double;\n+\tdefault:\n+\t return assign_var;\n+\t}\n+ default:\n+ switch (sz)\n+\t{\n+\tcase 1:\n+\t return (ass_op) (by_val ? assign_by_val_8 : assign_8);\n+\tcase 2:\n+\t return (ass_op) (by_val ? assign_by_val_16 : assign_16);\n+\tcase 4:\n+\t return (ass_op) (by_val ? assign_by_val_32 : assign_32);\n+\tcase 8:\n+\t return (ass_op) (by_val ? assign_by_val_64 : assign_64);\n+\t// case 16:\n+\t// return assign_128;\n+\tdefault:\n+\t return assign_var;\n+\t}\n+ }\n+}\n+\n+/* Having result_image == -1 means allreduce. */\n+\n+void\n+collsub_reduce_array (gfc_descriptor_t *desc, int result_image,\n+\t\t void *(*op) (void *, void *), int opr_flags,\n+\t\t int str_len __attribute__ ((unused)))\n+{\n+ void *buffer;\n+ pack_info pi;\n+ bool packed;\n+ int cbit = 0;\n+ int imoffset;\n+ index_type elem_size;\n+ index_type this_image_size_bytes;\n+ void *this_image_buf, *roll_iter, *src_iter;\n+ ass_op assign;\n+ const int this_img_id = caf_current_team->index;\n+\n+ packed = pack_array_prepare (&pi, desc);\n+ if (pi.num_elem == 0)\n+ return;\n+\n+ elem_size = GFC_DESCRIPTOR_SPAN (desc);\n+ this_image_size_bytes = elem_size * pi.num_elem;\n+\n+ buffer = get_collsub_buf (\n+ this_image_size_bytes * caf_current_team->u.image_info->image_count.count);\n+ this_image_buf = buffer + this_image_size_bytes * this_img_id;\n+\n+ if (packed)\n+ memcpy (this_image_buf, GFC_DESCRIPTOR_DATA (desc), this_image_size_bytes);\n+ else\n+ pack_array_finish (&pi, desc, this_image_buf);\n+\n+ assign = gen_reduction (GFC_DESCRIPTOR_TYPE (desc), elem_size, opr_flags);\n+ collsub_sync ();\n+\n+ for (; ((this_img_id >> cbit) & 1) == 0\n+\t && (caf_current_team->u.image_info->image_count.count >> cbit) != 0;\n+ cbit++)\n+ {\n+ imoffset = 1 << cbit;\n+ if (this_img_id + imoffset\n+\t < caf_current_team->u.image_info->image_count.count)\n+\t{\n+\t /* Reduce arrays elementwise. */\n+\t roll_iter = this_image_buf;\n+\t src_iter = this_image_buf + this_image_size_bytes * imoffset;\n+\t for (ssize_t i = 0; i < pi.num_elem;\n+\t ++i, roll_iter += elem_size, src_iter += elem_size)\n+\t assign (op, roll_iter, src_iter, elem_size);\n+\t}\n+ collsub_sync ();\n+ }\n+ for (; (caf_current_team->u.image_info->image_count.count >> cbit) != 0;\n+ cbit++)\n+ collsub_sync ();\n+\n+ if (result_image < 0 || result_image == this_image.image_num)\n+ {\n+ if (packed)\n+\tmemcpy (GFC_DESCRIPTOR_DATA (desc), buffer, this_image_size_bytes);\n+ else\n+\tunpack_array_finish (&pi, desc, buffer);\n+ }\n+\n+ collsub_sync ();\n+}\n+\n+/* Do not use sync_all(), because the program should deadlock in the case that\n+ * some images are on a sync_all barrier while others are in a collective\n+ * subroutine. */\n+\n+void\n+collsub_broadcast_array (gfc_descriptor_t *desc, int source_image)\n+{\n+ void *buffer;\n+ pack_info pi;\n+ bool packed;\n+ index_type elem_size;\n+ index_type size_bytes;\n+\n+ packed = pack_array_prepare (&pi, desc);\n+ if (pi.num_elem == 0)\n+ return;\n+\n+ if (GFC_DESCRIPTOR_TYPE (desc) == BT_CHARACTER)\n+ {\n+ if (GFC_DESCRIPTOR_SIZE (desc))\n+\telem_size = GFC_DESCRIPTOR_SIZE (desc);\n+ else\n+\telem_size = strlen (desc->base_addr);\n+ }\n+ else\n+ elem_size = GFC_DESCRIPTOR_SPAN (desc) != 0\n+\t\t ? ((index_type) GFC_DESCRIPTOR_SPAN (desc))\n+\t\t : ((index_type) GFC_DESCRIPTOR_SIZE (desc));\n+ size_bytes = elem_size * pi.num_elem;\n+ buffer = get_collsub_buf (size_bytes);\n+\n+ if (source_image == this_image.image_num)\n+ {\n+ if (packed)\n+\tmemcpy (buffer, GFC_DESCRIPTOR_DATA (desc), size_bytes);\n+ else\n+\tpack_array_finish (&pi, desc, buffer);\n+ collsub_sync ();\n+ }\n+ else\n+ {\n+ collsub_sync ();\n+ if (packed)\n+\tmemcpy (GFC_DESCRIPTOR_DATA (desc), buffer, size_bytes);\n+ else\n+\tunpack_array_finish (&pi, desc, buffer);\n+ }\n+\n+ collsub_sync ();\n+}\ndiff --git a/libgfortran/caf/shmem/collective_subroutine.h b/libgfortran/caf/shmem/collective_subroutine.h\nnew file mode 100644\nindex 00000000000..8c37186c867\n--- /dev/null\n+++ b/libgfortran/caf/shmem/collective_subroutine.h\n@@ -0,0 +1,50 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#ifndef COLLECTIVE_SUBROUTINE_HDR\n+#define COLLECTIVE_SUBROUTINE_HDR\n+\n+#include \"alloc.h\"\n+#include \"counter_barrier.h\"\n+#include \"shared_memory.h\"\n+\n+#include \"caf/libcaf.h\"\n+\n+typedef struct collsub_shared\n+{\n+ size_t curr_size;\n+ shared_mem_ptr collsub_buf;\n+ counter_barrier barrier;\n+ pthread_mutex_t mutex;\n+} collsub_shared;\n+\n+void collsub_init_supervisor (collsub_shared *, allocator *,\n+\t\t\t const int init_num_images);\n+\n+void collsub_broadcast_array (gfc_descriptor_t *, int);\n+\n+void collsub_reduce_array (gfc_descriptor_t *, int, void *(*) (void *, void *),\n+\t\t\t int opr_flags, int str_len);\n+\n+#endif\ndiff --git a/libgfortran/caf/shmem/counter_barrier.c b/libgfortran/caf/shmem/counter_barrier.c\nnew file mode 100644\nindex 00000000000..f78ba7fe852\n--- /dev/null\n+++ b/libgfortran/caf/shmem/counter_barrier.c\n@@ -0,0 +1,121 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#include \"libgfortran.h\"\n+#include \"counter_barrier.h\"\n+#include \"supervisor.h\"\n+#include \"thread_support.h\"\n+\n+#include <assert.h>\n+\n+/* Lock the associated counter of this barrier. */\n+\n+static inline void\n+lock_counter_barrier (counter_barrier *b)\n+{\n+ pthread_mutex_lock (&b->mutex);\n+}\n+\n+/* Unlock the associated counter of this barrier. */\n+\n+static inline void\n+unlock_counter_barrier (counter_barrier *b)\n+{\n+ pthread_mutex_unlock (&b->mutex);\n+}\n+\n+void\n+counter_barrier_init (counter_barrier *b, int val)\n+{\n+ *b = (counter_barrier) {PTHREAD_MUTEX_INITIALIZER, PTHREAD_COND_INITIALIZER,\n+\t\t\t val, 0, val};\n+ initialize_shared_condition (&b->cond);\n+ initialize_shared_mutex (&b->mutex);\n+}\n+\n+void\n+counter_barrier_wait (counter_barrier *b)\n+{\n+ int wait_group_beginning;\n+\n+ lock_counter_barrier (b);\n+\n+ wait_group_beginning = b->curr_wait_group;\n+\n+ if ((--b->wait_count) <= 0)\n+ pthread_cond_broadcast (&b->cond);\n+ else\n+ {\n+ while (b->wait_count > 0 && b->curr_wait_group == wait_group_beginning)\n+\t pthread_cond_wait (&b->cond, &b->mutex);\n+ }\n+\n+ if (b->wait_count <= 0)\n+ {\n+ b->curr_wait_group = !wait_group_beginning;\n+ b->wait_count = b->count;\n+ }\n+\n+ unlock_counter_barrier (b);\n+}\n+\n+\n+static inline void\n+change_internal_barrier_count (counter_barrier *b, int val)\n+{\n+ b->wait_count += val;\n+ if (b->wait_count <= 0)\n+ pthread_cond_broadcast (&b->cond);\n+}\n+\n+int\n+counter_barrier_add_locked (counter_barrier *c, int val)\n+{\n+ int ret;\n+ ret = (c->count += val);\n+ change_internal_barrier_count (c, val);\n+\n+ return ret;\n+}\n+\n+int\n+counter_barrier_add (counter_barrier *c, int val)\n+{\n+ int ret;\n+ pthread_mutex_lock (&c->mutex);\n+ ret = counter_barrier_add_locked (c, val);\n+\n+ pthread_mutex_unlock (&c->mutex);\n+ return ret;\n+}\n+\n+int\n+counter_barrier_get_count (counter_barrier *c)\n+{\n+ int ret;\n+ pthread_mutex_lock (&c->mutex);\n+ ret = c->count;\n+ pthread_mutex_unlock (&c->mutex);\n+ return ret;\n+}\ndiff --git a/libgfortran/caf/shmem/counter_barrier.h b/libgfortran/caf/shmem/counter_barrier.h\nnew file mode 100644\nindex 00000000000..a28c58812a5\n--- /dev/null\n+++ b/libgfortran/caf/shmem/counter_barrier.h\n@@ -0,0 +1,76 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#ifndef COUNTER_BARRIER_HDR\n+#define COUNTER_BARRIER_HDR\n+\n+#include <pthread.h>\n+\n+/* Usable as counter barrier and as waitable counter.\n+ This \"class\" allows to sync all images acting as a barrier. For this the\n+ counter_barrier is to be initialized by the number of images and then later\n+ calls to counter_barrier_wait() will sync the given number of images. There\n+ is no order in which the images will be woken up from their wait.\n+ Furthermore may this \"class\" be used as a event queue counter. To use it in\n+ that way the counter barrier is to be initialized with zero. Every \"add\" to\n+ the queue then is to be made by incrementing the counter_barrier every take\n+ by decrementing the queue. If the queue does not satiesfy the needed number\n+ of entries they can be waited for.\n+ */\n+\n+typedef struct\n+{\n+ pthread_mutex_t mutex;\n+ pthread_cond_t cond;\n+ volatile int wait_count;\n+ volatile int curr_wait_group;\n+ volatile int count;\n+} counter_barrier;\n+\n+/* Initialize the counter barrier. Only to be called once per counter barrier.\n+ I.e. a counter barrier in shared memory must only be initialized by one\n+ image. */\n+\n+void counter_barrier_init (counter_barrier *, int);\n+\n+/* Add the given number to the counter barrier. This signals waiting images\n+ when the count drops below 0. This routine is only to be called, when the\n+ image has taken the counter barrier's lock by some other way. */\n+\n+int counter_barrier_add_locked (counter_barrier *, int);\n+\n+/* Add the given number to the counter barrier. This signals waiting images\n+ when the count drops below 0. */\n+\n+int counter_barrier_add (counter_barrier *, int);\n+\n+/* Get the count of the barrier. */\n+\n+int counter_barrier_get_count (counter_barrier *);\n+\n+/* Wait for the count in the barrier drop to or below 0. */\n+\n+void counter_barrier_wait (counter_barrier *);\n+\n+#endif\ndiff --git a/libgfortran/caf/shmem/hashmap.c b/libgfortran/caf/shmem/hashmap.c\nnew file mode 100644\nindex 00000000000..e17d6dd2dca\n--- /dev/null\n+++ b/libgfortran/caf/shmem/hashmap.c\n@@ -0,0 +1,366 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#include \"libgfortran.h\"\n+\n+#include \"hashmap.h\"\n+\n+#include <string.h>\n+\n+#define INITIAL_BITNUM (5)\n+#define INITIAL_SIZE (1 << INITIAL_BITNUM)\n+#define CRITICAL_LOOKAHEAD (16)\n+\n+static ssize_t n_ent;\n+\n+typedef struct\n+{\n+ memid id;\n+ shared_mem_ptr p; /* If p == SHMPTR_NULL, the entry is empty. */\n+ size_t s;\n+ int max_lookahead;\n+ int refcnt;\n+} hashmap_entry;\n+\n+/* 64 bit to 64 bit hash function. */\n+\n+static inline uint64_t\n+hash (uint64_t key)\n+{\n+ key ^= (key >> 30);\n+ key *= 0xbf58476d1ce4e5b9ul;\n+ key ^= (key >> 27);\n+ key *= 0x94d049bb133111ebul;\n+ key ^= (key >> 31);\n+\n+ return key;\n+}\n+\n+/* Gets a pointer to the current data in the hashmap. */\n+\n+static inline hashmap_entry *\n+get_data (hashmap *hm)\n+{\n+ return SHMPTR_AS (hashmap_entry *, hm->s->data, hm->sm);\n+}\n+\n+/* Generate mask from current number of bits. */\n+\n+static inline intptr_t\n+gen_mask (hashmap *hm)\n+{\n+ return (1 << hm->s->bitnum) - 1;\n+}\n+\n+/* Add with wrap-around at hashmap size. */\n+\n+static inline size_t\n+hmiadd (hashmap *hm, size_t s, ssize_t o)\n+{\n+ return (s + o) & gen_mask (hm);\n+}\n+\n+/* Get the expected offset for entry id. */\n+\n+static inline ssize_t\n+get_expected_offset (hashmap *hm, memid id)\n+{\n+ return hash (id) >> (VOIDP_BITS - hm->s->bitnum);\n+}\n+\n+/* Initialize the hashmap. */\n+\n+void\n+hashmap_init (hashmap *hm, hashmap_shared *hs, allocator *a)\n+{\n+ *hm = (hashmap) {hs, a->shm, a};\n+}\n+\n+void\n+hashmap_init_supervisor (hashmap *hm, hashmap_shared *hs, allocator *a)\n+{\n+ hashmap_entry *data;\n+ *hm = (hashmap) {hs, a->shm, a};\n+ hm->s->data\n+ = allocator_shared_malloc (a, INITIAL_SIZE * sizeof (hashmap_entry));\n+ data = get_data (hm);\n+ memset (data, '\\0', INITIAL_SIZE * sizeof (hashmap_entry));\n+\n+ hm->s->size = INITIAL_SIZE;\n+ hm->s->bitnum = INITIAL_BITNUM;\n+}\n+\n+/* This checks if the entry id exists in that range the range between\n+ the expected position and the maximum lookahead. */\n+\n+static ssize_t\n+scan_inside_lookahead (hashmap *hm, ssize_t expected_off, memid id)\n+{\n+ ssize_t lookahead;\n+ hashmap_entry *data;\n+\n+ data = get_data (hm);\n+ lookahead = data[expected_off].max_lookahead;\n+\n+ for (int i = 0; i <= lookahead; i++) /* For performance, this could\n+\t\t\t\t\t iterate backwards. */\n+ if (data[hmiadd (hm, expected_off, i)].id == id)\n+ return hmiadd (hm, expected_off, i);\n+\n+ return -1;\n+}\n+\n+/* Scan for the next empty slot we can use. Returns offset relative\n+ to the expected position. */\n+\n+static ssize_t\n+scan_empty (hashmap *hm, ssize_t expected_off)\n+{\n+ hashmap_entry *data;\n+\n+ data = get_data (hm);\n+ for (int i = 0; i < CRITICAL_LOOKAHEAD; i++)\n+ if (SHMPTR_IS_NULL (data[hmiadd (hm, expected_off, i)].p))\n+ return i;\n+\n+ return -1;\n+}\n+\n+/* Search the hashmap for id. */\n+\n+hashmap_search_result\n+hashmap_get (hashmap *hm, memid id)\n+{\n+ hashmap_search_result ret;\n+ hashmap_entry *data;\n+ size_t expected_offset;\n+ ssize_t res;\n+\n+ data = get_data (hm);\n+ expected_offset = get_expected_offset (hm, id);\n+ res = scan_inside_lookahead (hm, expected_offset, id);\n+\n+ if (res != -1)\n+ ret = ((hashmap_search_result){\n+\t.p = data[res].p, .size = data[res].s, .res_offset = res });\n+ else\n+ ret.p = SHMPTR_NULL;\n+\n+ return ret;\n+}\n+\n+/* Return size of a hashmap search result. */\n+\n+size_t\n+hm_search_result_size (hashmap_search_result *res)\n+{\n+ return res->size;\n+}\n+\n+/* Return pointer of a hashmap search result. */\n+\n+shared_mem_ptr\n+hm_search_result_ptr (hashmap_search_result *res)\n+{\n+ return res->p;\n+}\n+\n+/* Return pointer of a hashmap search result. */\n+\n+bool\n+hm_search_result_contains (hashmap_search_result *res)\n+{\n+ return !SHMPTR_IS_NULL (res->p);\n+}\n+\n+/* Enlarge hashmap memory. */\n+\n+static void\n+enlarge_hashmap_mem (hashmap *hm, hashmap_entry **data, bool f)\n+{\n+ shared_mem_ptr old_data_p;\n+ size_t old_size;\n+\n+ old_data_p = hm->s->data;\n+ old_size = hm->s->size;\n+\n+ hm->s->data = allocator_shared_malloc (hm->a, (hm->s->size *= 2)\n+\t\t\t\t\t\t * sizeof (hashmap_entry));\n+ hm->s->bitnum++;\n+\n+ *data = get_data (hm);\n+ for (size_t i = 0; i < hm->s->size; i++)\n+ (*data)[i] = ((hashmap_entry){\n+\t.id = 0, .p = SHMPTR_NULL, .s = 0, .max_lookahead = 0, .refcnt = 0 });\n+\n+ if (f)\n+ allocator_shared_free (hm->a, old_data_p, old_size);\n+}\n+\n+/* Resize hashmap. */\n+\n+static void\n+resize_hm (hashmap *hm, hashmap_entry **data)\n+{\n+ shared_mem_ptr old_data_p;\n+ hashmap_entry *old_data, *new_data;\n+ size_t old_size;\n+ ssize_t new_offset, inital_index, new_index;\n+ memid id;\n+ ssize_t max_lookahead;\n+\n+ /* old_data points to the old block containing the hashmap. We\n+ redistribute the data from there into the new block. */\n+\n+ old_data_p = hm->s->data;\n+ old_data = *data;\n+ old_size = hm->s->size;\n+\n+ enlarge_hashmap_mem (hm, &new_data, false);\n+retry_resize:\n+ for (size_t i = 0; i < old_size; i++)\n+ {\n+ if (SHMPTR_IS_NULL (old_data[i].p))\n+\tcontinue;\n+\n+ id = old_data[i].id;\n+ inital_index = get_expected_offset (hm, id);\n+ new_offset = scan_empty (hm, inital_index);\n+\n+ /* If we didn't find a free slot, just resize the hashmap\n+\t again. */\n+ if (new_offset == -1)\n+\t{\n+\t enlarge_hashmap_mem (hm, &new_data, true);\n+\t goto retry_resize; /* Sue me. */\n+\t}\n+\n+ new_index = hmiadd (hm, inital_index, new_offset);\n+ max_lookahead = new_data[inital_index].max_lookahead;\n+ new_data[inital_index].max_lookahead\n+\t = new_offset > max_lookahead ? new_offset : max_lookahead;\n+\n+ new_data[new_index] = ((hashmap_entry){\n+\t .id = id,\n+\t .p = old_data[i].p,\n+\t .s = old_data[i].s,\n+\t .max_lookahead = new_data[new_index].max_lookahead,\n+\t .refcnt = old_data[i].refcnt });\n+ }\n+ allocator_shared_free (hm->a, old_data_p, old_size);\n+ *data = new_data;\n+}\n+\n+/* Set an entry in the hashmap. */\n+\n+void\n+hashmap_set (hashmap *hm, memid id, hashmap_search_result *hsr,\n+\t shared_mem_ptr p, size_t size)\n+{\n+ hashmap_entry *data;\n+ ssize_t expected_offset, lookahead;\n+ ssize_t empty_offset;\n+ ssize_t delta;\n+\n+ data = get_data (hm);\n+\n+ if (hsr)\n+ {\n+ data[hsr->res_offset].s = size;\n+ data[hsr->res_offset].p = p;\n+ return;\n+ }\n+\n+ expected_offset = get_expected_offset (hm, id);\n+ while ((delta = scan_empty (hm, expected_offset)) == -1)\n+ {\n+ resize_hm (hm, &data);\n+ expected_offset = get_expected_offset (hm, id);\n+ }\n+\n+ empty_offset = hmiadd (hm, expected_offset, delta);\n+ lookahead = data[expected_offset].max_lookahead;\n+ data[expected_offset].max_lookahead = delta > lookahead ? delta : lookahead;\n+ data[empty_offset]\n+ = ((hashmap_entry){ .id = id,\n+\t\t\t .p = p,\n+\t\t\t .s = size,\n+\t\t\t .max_lookahead = data[empty_offset].max_lookahead,\n+\t\t\t .refcnt = 1 });\n+\n+ n_ent++;\n+ /* TODO: Shouldn't reset refcnt, but this doesn't matter at the\n+ moment because of the way the function is used. */\n+}\n+\n+/* Change the refcount of a hashmap entry. */\n+\n+static int\n+hashmap_change_refcnt (hashmap *hm, memid id, hashmap_search_result *res,\n+\t\t int delta)\n+{\n+ hashmap_entry *data;\n+ hashmap_search_result r;\n+ hashmap_search_result *pr;\n+ int ret;\n+ hashmap_entry *entry;\n+\n+ data = get_data (hm);\n+\n+ if (res)\n+ pr = res;\n+ else\n+ {\n+ r = hashmap_get (hm, id);\n+ pr = &r;\n+ }\n+\n+ entry = &data[pr->res_offset];\n+ ret = (entry->refcnt += delta);\n+ if (ret == 0)\n+ {\n+ n_ent--;\n+ entry->id = 0;\n+ entry->p = SHMPTR_NULL;\n+ entry->s = 0;\n+ }\n+\n+ return ret;\n+}\n+\n+/* Increase hashmap entry refcount. */\n+\n+void\n+hashmap_inc (hashmap *hm, memid id, hashmap_search_result *res)\n+{\n+ hashmap_change_refcnt (hm, id, res, 1);\n+}\n+\n+/* Decrease hashmap entry refcount. */\n+\n+int\n+hashmap_dec (hashmap *hm, memid id, hashmap_search_result *res)\n+{\n+ return hashmap_change_refcnt (hm, id, res, -1);\n+}\ndiff --git a/libgfortran/caf/shmem/hashmap.h b/libgfortran/caf/shmem/hashmap.h\nnew file mode 100644\nindex 00000000000..bc263d32dcd\n--- /dev/null\n+++ b/libgfortran/caf/shmem/hashmap.h\n@@ -0,0 +1,98 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#ifndef HASHMAP_H\n+#define HASHMAP_H\n+\n+#include \"allocator.h\"\n+\n+#include <stdbool.h>\n+#include <stddef.h>\n+#include <stdint.h>\n+\n+/* Data structures and variables:\n+\n+ memid is a unique identifier for the coarray. */\n+\n+typedef uint64_t memid;\n+\n+typedef struct {\n+ shared_mem_ptr data;\n+ size_t size;\n+ int bitnum;\n+} hashmap_shared;\n+\n+typedef struct hashmap\n+{\n+ hashmap_shared *s;\n+ shared_memory sm;\n+ allocator *a;\n+} hashmap;\n+\n+typedef struct {\n+ shared_mem_ptr p;\n+ size_t size;\n+ ssize_t res_offset;\n+} hashmap_search_result;\n+\n+/* Initialize the hashmap on a worker image. */\n+\n+void hashmap_init (hashmap *, hashmap_shared *, allocator *a);\n+\n+/* Initialize the hashmap on the supervisor. This routine must be called only\n+ on the supervisor. */\n+\n+void hashmap_init_supervisor (hashmap *, hashmap_shared *, allocator *);\n+\n+/* Look up memid in the hashmap. The result can be inspected via the\n+ hm_search_result_* functions. */\n+\n+hashmap_search_result hashmap_get (hashmap *, memid);\n+\n+/* Given a search result, returns the size. */\n+size_t hm_search_result_size (hashmap_search_result *);\n+\n+/* Given a search result, returns the pointer. */\n+shared_mem_ptr hm_search_result_ptr (hashmap_search_result *);\n+\n+/* Given a search result, returns whether something was found. */\n+bool hm_search_result_contains (hashmap_search_result *);\n+\n+/* Sets the hashmap entry for memid to shared_mem_ptr and\n+ size_t. Optionally, if a hashmap_search_result is supplied, it is\n+ used to make the lookup faster. */\n+\n+void hashmap_set (hashmap *, memid, hashmap_search_result *, shared_mem_ptr p,\n+\t\t size_t);\n+\n+/* Increments the hashmap entry for memid. Optionally, if a\n+ hashmap_search_result is supplied, it is used to make the lookup\n+ faster. */\n+\n+void hashmap_inc (hashmap *, memid, hashmap_search_result *);\n+\n+/* Same, but decrement. */\n+int hashmap_dec (hashmap *, memid, hashmap_search_result *);\n+\n+#endif\ndiff --git a/libgfortran/caf/shmem/shared_memory.c b/libgfortran/caf/shmem/shared_memory.c\nnew file mode 100644\nindex 00000000000..2b3666ddd3b\n--- /dev/null\n+++ b/libgfortran/caf/shmem/shared_memory.c\n@@ -0,0 +1,200 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#include \"libgfortran.h\"\n+#include \"allocator.h\"\n+#include \"shared_memory.h\"\n+\n+#include <assert.h>\n+#include <fcntl.h>\n+#include <stdlib.h>\n+#include <string.h>\n+#include <sys/mman.h>\n+#include <unistd.h>\n+\n+/* This implements shared memory based on POSIX mmap. We start with\n+ memory block of the size of the global shared memory data, rounded\n+ up to one pagesize, and enlarge as needed.\n+\n+ We address the memory via a shared_memory_ptr, which is an offset into\n+ the shared memory block. The metadata is situated at offset 0.\n+\n+ In order to be able to resize the memory and to keep pointers\n+ valid, we keep the old mapping around, so the memory is actually\n+ visible several times to the process. Thus, pointers returned by\n+ shared_memory_get_mem_with_alignment remain valid even when\n+ resizing. */\n+\n+static const char *ENV_PPID = \"GFORTRAN_SHMEM_PPID\";\n+static const char *ENV_BASE = \"GFORTRAN_SHMEM_BASE\";\n+\n+void\n+shared_memory_set_env (pid_t pid)\n+{\n+#define bufsize 20\n+ char buffer[bufsize];\n+\n+ snprintf (buffer, bufsize, \"%d\", pid);\n+ setenv (ENV_PPID, buffer, 1);\n+#undef bufsize\n+}\n+\n+char *\n+shared_memory_get_env (void)\n+{\n+ return getenv (ENV_PPID);\n+}\n+\n+/* Get a pointer into the shared memory block with alignemnt\n+ (works similar to sbrk). */\n+\n+shared_mem_ptr\n+shared_memory_get_mem_with_alignment (shared_memory_act *mem, size_t size,\n+\t\t\t\t size_t align)\n+{\n+ size_t aligned_curr_size = alignto (mem->glbl.meta->used, align);\n+ mem->glbl.meta->used = aligned_curr_size + size;\n+ return (shared_mem_ptr) {aligned_curr_size};\n+}\n+\n+shared_mem_ptr\n+shared_memory_get_master (shared_memory_act *mem, size_t size, size_t align)\n+{\n+ if (mem->glbl.meta->master)\n+ return (shared_mem_ptr) {mem->glbl.meta->master};\n+ else\n+ {\n+ ptrdiff_t loc = mem->glbl.meta->used;\n+ shared_mem_ptr p\n+\t= shared_memory_get_mem_with_alignment (mem, size, align);\n+ mem->glbl.meta->master = loc;\n+ return p;\n+ }\n+}\n+\n+/* If another image changed the size, update the size accordingly. */\n+\n+void\n+shared_memory_prepare (shared_memory_act *)\n+{\n+ asm volatile (\"\" ::: \"memory\");\n+}\n+\n+#define NAME_MAX 255\n+\n+/* Initialize the memory with one page, the shared metadata of the\n+ shared memory is stored at the beginning. */\n+\n+void\n+shared_memory_init (shared_memory_act *mem, size_t size)\n+{\n+ char shm_name[NAME_MAX];\n+ const char *env_val = getenv (ENV_PPID), *base = getenv (ENV_BASE);\n+ pid_t ppid = getpid ();\n+ int shm_fd, res;\n+ void *base_ptr;\n+\n+ if (env_val)\n+ {\n+ int n = sscanf (env_val, \"%d\", &ppid);\n+ assert (n == 1);\n+ }\n+ snprintf (shm_name, NAME_MAX, \"/gfor-shm-%d\", ppid);\n+ if (base)\n+ {\n+ int n = sscanf (base, \"%p\", &base_ptr);\n+ assert (n == 1);\n+ }\n+ else\n+ base_ptr = NULL;\n+\n+ if (!env_val)\n+ {\n+ shm_fd = shm_open (shm_name, O_CREAT | O_RDWR | O_EXCL, 0600);\n+ if (shm_fd == -1)\n+\t{\n+\t perror (\"creating shared memory segment failed.\");\n+\t exit (1);\n+\t}\n+\n+ res = ftruncate (shm_fd, size);\n+ if (res == -1)\n+\t{\n+\t perror (\"resizing shared memory segment failed.\");\n+\t exit (1);\n+\t}\n+ }\n+ else\n+ {\n+ shm_fd = shm_open (shm_name, O_RDWR, 0);\n+ if (shm_fd == -1)\n+\t{\n+\t perror (\"opening shared memory segment failed.\");\n+\t exit (1);\n+\t}\n+ }\n+\n+ mem->glbl.base\n+ = mmap (base_ptr, size, PROT_READ | PROT_WRITE, MAP_SHARED, shm_fd, 0);\n+ res = close (shm_fd);\n+ if (mem->glbl.base == MAP_FAILED)\n+ {\n+ perror (\"mmap failed\");\n+ exit (1);\n+ }\n+ if (!base_ptr)\n+ {\n+#define bufsize 20\n+ char buffer[bufsize];\n+\n+ snprintf (buffer, bufsize, \"%p\", mem->glbl.base);\n+ setenv (ENV_BASE, buffer, 1);\n+#undef bufsize\n+ }\n+ if (res)\n+ { // from close()\n+ perror (\"closing shm file handle failed. Trying to continue...\");\n+ }\n+ mem->size = size;\n+ if (!env_val)\n+ *mem->glbl.meta\n+ = (global_shared_memory_meta) {sizeof (global_shared_memory_meta), 0};\n+\n+}\n+\n+void\n+shared_memory_cleanup (shared_memory_act *)\n+{\n+ char shm_name[NAME_MAX];\n+ int res;\n+\n+ snprintf (shm_name, NAME_MAX, \"/gfor-shm-%s\", shared_memory_get_env ());\n+ res = shm_unlink (shm_name);\n+ if (res == -1)\n+ {\n+ perror (\"shm_unlink failed\");\n+ exit (1);\n+ }\n+}\n+#undef NAME_MAX\ndiff --git a/libgfortran/caf/shmem/shared_memory.h b/libgfortran/caf/shmem/shared_memory.h\nnew file mode 100644\nindex 00000000000..01ac2811e5d\n--- /dev/null\n+++ b/libgfortran/caf/shmem/shared_memory.h\n@@ -0,0 +1,93 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#ifndef SHARED_MEMORY_H\n+#define SHARED_MEMORY_H\n+\n+#include <stdlib.h>\n+#include <stddef.h>\n+#include <unistd.h>\n+\n+/* Global metadata for shared memory, always kept at offset 0. */\n+\n+typedef struct\n+{\n+ size_t used;\n+ ptrdiff_t master;\n+} global_shared_memory_meta;\n+\n+/* Type realization for shared_memory. */\n+\n+typedef struct shared_memory_act\n+{\n+ union\n+ {\n+ void *base;\n+ global_shared_memory_meta *meta;\n+ } glbl;\n+ size_t size; // const\n+} shared_memory_act;\n+\n+/* A struct to serve as shared memory object. */\n+\n+typedef struct shared_memory_act * shared_memory;\n+\n+#define SHMPTR_NULL ((shared_mem_ptr) {.offset = 0})\n+#define SHMPTR_IS_NULL(x) (x.offset == 0)\n+\n+#define SHMPTR_DEREF(x, s, sm) ((x) = *(__typeof (x) *) s.p)\n+#define SHMPTR_AS(type, s, sm) ((type) (*((void **) sm) + s.offset))\n+#define AS_SHMPTR(p, sm) ((shared_mem_ptr) {.offset = (p) - sm.glbl.base})\n+\n+#define SHARED_MEMORY_RAW_ALLOC(mem, t, n) \\\n+ shared_memory_get_mem_with_alignment (mem, sizeof (t) * n, __alignof__ (t))\n+\n+#define SHARED_MEMORY_RAW_ALLOC_PTR(mem, t) \\\n+ SHMPTR_AS (t *, SHARED_MEMORY_RAW_ALLOC (mem, t, 1), mem)\n+\n+/* A shared-memory pointer is implemented as an offset into the shared\n+ memory region. */\n+\n+typedef struct shared_mem_ptr\n+{\n+ ptrdiff_t offset;\n+} shared_mem_ptr;\n+\n+void shared_memory_init (shared_memory, size_t);\n+\n+void shared_memory_cleanup (shared_memory);\n+\n+void shared_memory_prepare (shared_memory);\n+\n+shared_mem_ptr shared_memory_get_mem_with_alignment (shared_memory mem,\n+\t\t\t\t\t\t size_t size, size_t align);\n+\n+shared_mem_ptr shared_memory_get_master (shared_memory pmem, size_t size,\n+\t\t\t\t\t size_t align);\n+\n+void shared_memory_set_env (pid_t pid);\n+\n+char *shared_memory_get_env (void);\n+\n+#endif\ndiff --git a/libgfortran/caf/shmem/supervisor.c b/libgfortran/caf/shmem/supervisor.c\nnew file mode 100644\nindex 00000000000..e4310b03e43\n--- /dev/null\n+++ b/libgfortran/caf/shmem/supervisor.c\n@@ -0,0 +1,312 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#include \"config.h\"\n+\n+#include \"../caf_error.h\"\n+#include \"supervisor.h\"\n+#include \"teams_mgmt.h\"\n+#include \"thread_support.h\"\n+\n+#include <assert.h>\n+#include <signal.h>\n+#include <string.h>\n+#include <unistd.h>\n+#ifdef HAVE_WAIT_H\n+#include <wait.h>\n+#elif HAVE_SYS_WAIT_H\n+#include <sys/wait.h>\n+#endif\n+\n+#define GFORTRAN_ENV_NUM_IMAGES \"GFORTRAN_NUM_IMAGES\"\n+#define GFORTRAN_ENV_SHARED_MEMORY_SIZE \"GFORTRAN_SHARED_MEMORY_SIZE\"\n+#define GFORTRAN_ENV_IMAGE_NUM \"GFORTRAN_IMAGE_NUM\"\n+\n+image_local *local = NULL;\n+\n+image this_image = {-1, NULL};\n+\n+/* Get image number from environment or sysconf. */\n+\n+static int\n+get_image_num_from_envvar (void)\n+{\n+ char *num_images_char;\n+ int nimages;\n+ num_images_char = getenv (GFORTRAN_ENV_NUM_IMAGES);\n+ if (!num_images_char)\n+ return sysconf (_SC_NPROCESSORS_ONLN); /* TODO: Make portable. */\n+ /* TODO: Error checking. */\n+ nimages = atoi (num_images_char);\n+ return nimages;\n+}\n+\n+/* Get the amount of memory for the shared memory block. This is picked from\n+ an environment variable. If that is not there, pick a reasonable default.\n+ Note that on a 64-bit system which allows overcommit, there is no penalty in\n+ reserving a large space and then not using it. */\n+\n+static size_t\n+get_memory_size_from_envvar (void)\n+{\n+ char *e;\n+ size_t sz = 0;\n+ e = getenv (GFORTRAN_ENV_SHARED_MEMORY_SIZE);\n+ if (e)\n+ {\n+ char suffix[2];\n+ int rv;\n+ rv = sscanf (e, \"%zu%1s\", &sz, suffix);\n+ if (rv == 2)\n+\t{\n+\t switch (suffix[0])\n+\t {\n+\t case 'k':\n+\t case 'K':\n+\t sz *= ((size_t) 1) << 10;\n+\t break;\n+\t case 'm':\n+\t case 'M':\n+\t sz *= ((size_t) 1) << 20;\n+\t break;\n+\t case 'g':\n+\t case 'G':\n+\t sz *= ((size_t) 1) << 30;\n+\t break;\n+\t default:\n+\t sz = 0;\n+\t }\n+\t}\n+ }\n+ if (sz == 0)\n+ {\n+ /* Use 256 MB for 32-bit systems and 4 GB for 64-bit systems. */\n+ if (sizeof (size_t) == 4)\n+\tsz = ((size_t) 1) << 28;\n+ else\n+\tsz = ((size_t) 1) << 34;\n+ }\n+ return sz;\n+}\n+\n+/* Get a supervisor. */\n+\n+static supervisor *\n+get_supervisor (void)\n+{\n+ supervisor *sv;\n+ sv = SHMPTR_AS (supervisor *,\n+\t\t shared_memory_get_master (&local->sm,\n+\t\t\t\t\t sizeof (supervisor)\n+\t\t\t\t\t + sizeof (image_tracker)\n+\t\t\t\t\t\t * local->total_num_images,\n+\t\t\t\t\t __alignof__ (supervisor)),\n+\t\t &local->sm);\n+ sv->failed_images = 0;\n+ sv->finished_images = 0;\n+ return sv;\n+}\n+\n+/* Defined in shmem.c, but we need it here. */\n+\n+extern memid next_memid;\n+\n+#define SUPERVISOR_MAGIC_NUM 0x12345678\n+\n+/* Ensure things are initialized. */\n+\n+void\n+ensure_shmem_initialization (void)\n+{\n+ size_t shmem_size;\n+ char *image_num;\n+\n+ if (local)\n+ return;\n+\n+ local = malloc (sizeof (image_local));\n+ pagesize = sysconf (_SC_PAGE_SIZE);\n+ shmem_size = round_to_pagesize (get_memory_size_from_envvar ());\n+ local->total_num_images = get_image_num_from_envvar ();\n+ shared_memory_init (&local->sm, shmem_size);\n+ shared_memory_prepare (&local->sm);\n+\n+ /* Shared memory needs to be present, before master can be initialized/linked\n+ to. */\n+ image_num = getenv (GFORTRAN_ENV_IMAGE_NUM);\n+ if (image_num)\n+ {\n+ bool created;\n+ this_image = (image) {atoi (image_num), get_supervisor ()};\n+ assert (this_image.supervisor->magic_number == SUPERVISOR_MAGIC_NUM);\n+\n+ alloc_init (&local->ai, &local->sm);\n+\n+ caf_initial_team = caf_current_team\n+\t= (caf_shmem_team_t) calloc (1, sizeof (struct caf_shmem_team));\n+ allocator_lock (&local->ai.alloc);\n+ *caf_initial_team = (struct caf_shmem_team) {\n+\tNULL,\n+\t-1,\n+\tthis_image.image_num,\n+\t0,\n+\tNULL,\n+\t{alloc_get_memory_by_id_created (&local->ai,\n+\t\t\t\t\t local->total_num_images * sizeof (int)\n+\t\t\t\t\t + sizeof (struct shmem_image_info),\n+\t\t\t\t\t next_memid++, &created)}};\n+ if (created)\n+\t{\n+\t counter_barrier_init (&caf_initial_team->u.image_info->image_count,\n+\t\t\t\tlocal->total_num_images);\n+\t collsub_init_supervisor (&caf_initial_team->u.image_info->collsub,\n+\t\t\t\t alloc_get_allocator (&local->ai),\n+\t\t\t\t local->total_num_images);\n+\t caf_initial_team->u.image_info->team_parent_id = 0;\n+\t caf_initial_team->u.image_info->team_id = -1;\n+\t caf_initial_team->u.image_info->image_map_size\n+\t = local->total_num_images;\n+\t caf_initial_team->u.image_info->num_term_images = 0;\n+\t caf_initial_team->u.image_info->lastmemid = 0;\n+\t for (int i = 0; i < local->total_num_images; ++i)\n+\t caf_initial_team->u.image_info->image_map[i] = i;\n+\t}\n+ allocator_unlock (&local->ai.alloc);\n+ sync_init (&local->si, &local->sm);\n+ }\n+ else\n+ {\n+ this_image = (image) {-1, get_supervisor ()};\n+ this_image.supervisor->magic_number = SUPERVISOR_MAGIC_NUM;\n+ counter_barrier_init (&this_image.supervisor->num_active_images,\n+\t\t\t local->total_num_images);\n+ alloc_init_supervisor (&local->ai, &local->sm);\n+ sync_init_supervisor (&local->si, &local->ai);\n+ }\n+}\n+\n+extern char **environ;\n+\n+int\n+supervisor_main_loop (int *argc __attribute__ ((unused)), char ***argv,\n+\t\t int *exit_code)\n+{\n+ supervisor *m;\n+ pid_t new_pid, finished_pid;\n+ image im;\n+ int chstatus;\n+\n+ *exit_code = 0;\n+ shared_memory_set_env (getpid ());\n+ m = this_image.supervisor;\n+\n+ for (im.image_num = 0; im.image_num < local->total_num_images; im.image_num++)\n+ {\n+ if ((new_pid = fork ()))\n+\t{\n+\t if (new_pid == -1)\n+\t caf_runtime_error (\"error spawning child\\n\");\n+\t m->images[im.image_num] = (image_tracker) {new_pid, IMAGE_OK};\n+\t}\n+ else\n+\t{\n+\t static char **new_env;\n+\t static char num_image[32];\n+\t size_t n = 2; /* Add one env-var and one for the term NULL. */\n+\n+\t /* Count the number of entries in the current environment. */\n+\t for (char **e = environ; *e; ++e, ++n)\n+\t ;\n+\t new_env = (char **) malloc (sizeof (char *) * n);\n+\t memcpy (new_env, environ, sizeof (char *) * (n - 2));\n+\t snprintf (num_image, 32, \"%s=%d\", GFORTRAN_ENV_IMAGE_NUM,\n+\t\t im.image_num);\n+\t new_env[n - 2] = num_image;\n+\t new_env[n - 1] = NULL;\n+\t execve ((*argv)[0], *argv, new_env);\n+\t return 1;\n+\t}\n+ }\n+ for (int j, i = 0; i < local->total_num_images; i++)\n+ {\n+ finished_pid = wait (&chstatus);\n+ if (WIFEXITED (chstatus) && !WEXITSTATUS (chstatus))\n+\t{\n+\t for (j = 0;\n+\t j < local->total_num_images && m->images[j].pid != finished_pid;\n+\t j++)\n+\t ;\n+\t /* Only set the status, when it has not been set by the (failing)\n+\t image already. */\n+\t if (m->images[j].status == IMAGE_OK)\n+\t {\n+\t m->images[j].status = IMAGE_SUCCESS;\n+\t atomic_fetch_add (&m->finished_images, 1);\n+\t }\n+\t}\n+ else if (!WIFEXITED (chstatus) || WEXITSTATUS (chstatus))\n+\t{\n+\t for (j = 0;\n+\t j < local->total_num_images && m->images[j].pid != finished_pid;\n+\t j++)\n+\t ;\n+\t dprintf (2, \"ERROR: Image %d(pid: %d) failed with %d.\\n\", j + 1,\n+\t\t finished_pid, WTERMSIG (chstatus));\n+\t if (j == local->total_num_images)\n+\t {\n+\t if (finished_pid == getpid ())\n+\t\t{\n+\t\t dprintf (2,\n+\t\t\t \"WARNING: Supervisor process got signal %d. Killing \"\n+\t\t\t \"childs and exiting.\\n\",\n+\t\t\t WTERMSIG (chstatus));\n+\t\t for (j = 0; j < local->total_num_images; j++)\n+\t\t {\n+\t\t if (m->images[j].status == IMAGE_OK)\n+\t\t\tkill (m->images[j].pid, SIGKILL);\n+\t\t }\n+\t\t exit (1);\n+\t\t}\n+\t dprintf (2,\n+\t\t \"WARNING: Got signal %d for unknown process %d. \"\n+\t\t \"Ignoring and trying to continue.\\n\",\n+\t\t WTERMSIG (chstatus), finished_pid);\n+\t continue;\n+\t }\n+\t m->images[j].status = IMAGE_FAILED;\n+\t atomic_fetch_add (&m->failed_images, 1);\n+\t if (*exit_code < WTERMSIG (chstatus))\n+\t *exit_code = WTERMSIG (chstatus);\n+\t else if (*exit_code == 0)\n+\t *exit_code = 1;\n+\t}\n+ /* Trigger waiting sync images aka sync_table. */\n+ for (j = 0; j < local->total_num_images; j++)\n+\tpthread_cond_signal (&SHMPTR_AS (pthread_cond_t *,\n+\t\t\t\t\t m->sync_shared.sync_images_cond_vars,\n+\t\t\t\t\t &local->sm)[j]);\n+ counter_barrier_add (&m->num_active_images, -1);\n+ }\n+ return 0;\n+}\ndiff --git a/libgfortran/caf/shmem/supervisor.h b/libgfortran/caf/shmem/supervisor.h\nnew file mode 100644\nindex 00000000000..7afb8269674\n--- /dev/null\n+++ b/libgfortran/caf/shmem/supervisor.h\n@@ -0,0 +1,112 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#ifndef SUPERVISOR_H\n+#define SUPERVISOR_H\n+\n+#include \"caf/libcaf.h\"\n+#include \"alloc.h\"\n+#include \"collective_subroutine.h\"\n+#include \"sync.h\"\n+\n+#include <stdatomic.h>\n+\n+typedef enum\n+{\n+ IMAGE_UNKNOWN = 0,\n+ IMAGE_OK,\n+ IMAGE_FAILED,\n+ IMAGE_SUCCESS\n+} image_status;\n+\n+typedef struct\n+{\n+ pid_t pid;\n+ image_status status;\n+} image_tracker;\n+\n+typedef struct supervisor\n+{\n+ ptrdiff_t magic_number;\n+ alloc_shared alloc_shared;\n+ hashmap_shared hms;\n+ collsub_shared collsub_shared;\n+ sync_shared sync_shared;\n+ atomic_int failed_images;\n+ atomic_int finished_images;\n+ counter_barrier num_active_images;\n+ pthread_mutex_t image_tracker_lock;\n+ image_tracker images[];\n+} supervisor;\n+\n+typedef struct\n+{\n+ int image_num;\n+ supervisor *supervisor;\n+} image;\n+\n+extern image this_image;\n+\n+typedef struct\n+{\n+ int total_num_images;\n+ struct shared_memory_act sm;\n+ alloc ai;\n+ sync_t si;\n+} image_local;\n+\n+extern image_local *local;\n+\n+struct caf_shmem_token\n+{\n+ /* The pointer to the memory registered for the current image. For arrays\n+ this is the data member in the descriptor. For components it's the pure\n+ data pointer. */\n+ void *memptr;\n+ /* The descriptor when this token is associated to an allocatable array. */\n+ gfc_descriptor_t *desc;\n+ /* The base address this coarray's memory in the shared memory space. The\n+ base address of image I is computed by base + I * image_size. */\n+ void *base;\n+ /* The size of memory in each image aligned on pointer borders, i.e. each\n+ images memory starts on an address that is aligned to enable maximum speed\n+ for the processor architecure used. */\n+ size_t image_size;\n+ /* The id of this token. */\n+ memid token_id;\n+ /* Set when the caf lib has allocated the memory in memptr and is responsible\n+ for freeing it on deregister. */\n+ bool owning_memory;\n+};\n+typedef struct caf_shmem_token *caf_shmem_token_t;\n+\n+\n+/* Ensure the shared memory environment is up and all support structures are\n+ initialized and linked correctly. */\n+\n+void ensure_shmem_initialization (void);\n+\n+int supervisor_main_loop (int *argc, char ***argv, int *exit_code);\n+\n+#endif\ndiff --git a/libgfortran/caf/shmem/sync.c b/libgfortran/caf/shmem/sync.c\nnew file mode 100644\nindex 00000000000..a456244629c\n--- /dev/null\n+++ b/libgfortran/caf/shmem/sync.c\n@@ -0,0 +1,182 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#include \"libgfortran.h\"\n+#include \"supervisor.h\"\n+#include \"sync.h\"\n+#include \"teams_mgmt.h\"\n+#include \"thread_support.h\"\n+\n+#include <string.h>\n+\n+static inline void\n+lock_table (sync_t *si)\n+{\n+ pthread_mutex_lock (&si->cis->sync_images_table_lock);\n+}\n+\n+static inline void\n+unlock_table (sync_t *si)\n+{\n+ pthread_mutex_unlock (&si->cis->sync_images_table_lock);\n+}\n+\n+void\n+sync_init (sync_t *si, shared_memory sm)\n+{\n+ *si = (sync_t) {\n+ &this_image.supervisor->sync_shared,\n+ SHMPTR_AS (int *, this_image.supervisor->sync_shared.sync_images_table, sm),\n+ SHMPTR_AS (pthread_cond_t *,\n+\t this_image.supervisor->sync_shared.sync_images_cond_vars, sm)};\n+}\n+\n+void\n+sync_init_supervisor (sync_t *si, alloc *ai)\n+{\n+ const int num_images = local->total_num_images;\n+ const size_t table_size_in_bytes = sizeof (int) * num_images * num_images;\n+\n+ si->cis = &this_image.supervisor->sync_shared;\n+\n+ initialize_shared_mutex (&si->cis->event_lock);\n+ initialize_shared_condition (&si->cis->event_cond);\n+\n+ initialize_shared_mutex (&si->cis->sync_images_table_lock);\n+\n+ si->cis->sync_images_table\n+ = allocator_shared_malloc (alloc_get_allocator (ai), table_size_in_bytes);\n+ si->cis->sync_images_cond_vars\n+ = allocator_shared_malloc (alloc_get_allocator (ai),\n+\t\t\t sizeof (pthread_cond_t) * num_images);\n+\n+ si->table = SHMPTR_AS (int *, si->cis->sync_images_table, ai->mem);\n+ si->triggers\n+ = SHMPTR_AS (pthread_cond_t *, si->cis->sync_images_cond_vars, ai->mem);\n+\n+ for (int i = 0; i < num_images; i++)\n+ initialize_shared_condition (&si->triggers[i]);\n+\n+ memset (si->table, 0, table_size_in_bytes);\n+}\n+\n+void\n+sync_table (sync_t *si, int *images, int size)\n+{\n+ /* The variable `table` is an N x N matrix, where N is the number of all\n+ images. The position (i, j) (where i and j are always the real images\n+ index, i.e. after team de-mapping) tells whether image i has seen the same\n+ number of synchronisation calls to sync_table like j. When table(i,j) ==\n+ table(j,i) then the sync for i with this image is completed (here j is the\n+ real image index of the current image). When this holds for all i in the\n+ current set of images (or all images, if the set is empty), then sync table\n+ command is completed.\n+ */\n+ volatile int *table = si->table;\n+ int i;\n+\n+ lock_table (si);\n+ if (size > 0)\n+ {\n+ const size_t img_c = caf_current_team->u.image_info->image_map_size;\n+ for (i = 0; i < size; ++i)\n+\t{\n+\t ++table[images[i] + img_c * this_image.image_num];\n+\t pthread_cond_signal (&si->triggers[images[i]]);\n+\t}\n+ for (;;)\n+\t{\n+\t for (i = 0; i < size; ++i)\n+\t if (this_image.supervisor->images[images[i]].status == IMAGE_OK\n+\t\t&& table[images[i] + this_image.image_num * img_c]\n+\t\t > table[this_image.image_num + images[i] * img_c])\n+\t break;\n+\t if (i == size)\n+\t break;\n+\t pthread_cond_wait (&si->triggers[this_image.image_num],\n+\t\t\t &si->cis->sync_images_table_lock);\n+\t}\n+ }\n+ else\n+ {\n+ int *map = caf_current_team->u.image_info->image_map;\n+ size = caf_current_team->u.image_info->image_count.count;\n+ for (i = 0; i < size; ++i)\n+\t{\n+\t if (this_image.supervisor->images[map[i]].status != IMAGE_OK)\n+\t continue;\n+\t ++table[map[i] + size * this_image.image_num];\n+\t pthread_cond_signal (&si->triggers[map[i]]);\n+\t}\n+ for (;;)\n+\t{\n+\t for (i = 0; i < size; ++i)\n+\t if (this_image.supervisor->images[map[i]].status == IMAGE_OK\n+\t\t&& table[map[i] + size * this_image.image_num]\n+\t\t > table[this_image.image_num + map[i] * size])\n+\t break;\n+\t if (i == size)\n+\t break;\n+\t pthread_cond_wait (&si->triggers[this_image.image_num],\n+\t\t\t &si->cis->sync_images_table_lock);\n+\t}\n+ }\n+ unlock_table (si);\n+}\n+\n+void\n+sync_all (void)\n+{\n+ counter_barrier_wait (&caf_current_team->u.image_info->image_count);\n+}\n+\n+void\n+sync_team (caf_shmem_team_t team)\n+{\n+ counter_barrier_wait (&team->u.image_info->image_count);\n+}\n+\n+void\n+lock_event (sync_t *si)\n+{\n+ pthread_mutex_lock (&si->cis->event_lock);\n+}\n+\n+void\n+unlock_event (sync_t *si)\n+{\n+ pthread_mutex_unlock (&si->cis->event_lock);\n+}\n+\n+void\n+event_post (sync_t *si)\n+{\n+ pthread_cond_broadcast (&si->cis->event_cond);\n+}\n+\n+void\n+event_wait (sync_t *si)\n+{\n+ pthread_cond_wait (&si->cis->event_cond, &si->cis->event_lock);\n+}\ndiff --git a/libgfortran/caf/shmem/sync.h b/libgfortran/caf/shmem/sync.h\nnew file mode 100644\nindex 00000000000..a3e586bca24\n--- /dev/null\n+++ b/libgfortran/caf/shmem/sync.h\n@@ -0,0 +1,79 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#ifndef SYNC_H\n+#define SYNC_H\n+\n+#include \"alloc.h\"\n+#include \"counter_barrier.h\"\n+\n+#include <pthread.h>\n+\n+typedef struct {\n+ /* Mutex and condition variable needed for signaling events. */\n+ pthread_mutex_t event_lock;\n+ pthread_cond_t event_cond;\n+ pthread_mutex_t sync_images_table_lock;\n+ shared_mem_ptr sync_images_table;\n+ shared_mem_ptr sync_images_cond_vars;\n+} sync_shared;\n+\n+typedef struct {\n+ sync_shared *cis;\n+ int *table; // we can cache the table and the trigger pointers here\n+ pthread_cond_t *triggers;\n+} sync_t;\n+\n+typedef pthread_mutex_t lock_t;\n+\n+typedef int event_t;\n+\n+void sync_init (sync_t *, shared_memory);\n+\n+void sync_init_supervisor (sync_t *, alloc *);\n+\n+void sync_all (void);\n+\n+/* Prototype for circular dependency break. */\n+\n+struct caf_shmem_team;\n+typedef struct caf_shmem_team *caf_shmem_team_t;\n+\n+void sync_team (caf_shmem_team_t team);\n+\n+void sync_table (sync_t *, int *, int);\n+\n+void lock_alloc_lock (sync_t *);\n+\n+void unlock_alloc_lock (sync_t *);\n+\n+void lock_event (sync_t *);\n+\n+void unlock_event (sync_t *);\n+\n+void event_post (sync_t *);\n+\n+void event_wait (sync_t *);\n+\n+#endif\ndiff --git a/libgfortran/caf/shmem/teams_mgmt.c b/libgfortran/caf/shmem/teams_mgmt.c\nnew file mode 100644\nindex 00000000000..44a34d727c3\n--- /dev/null\n+++ b/libgfortran/caf/shmem/teams_mgmt.c\n@@ -0,0 +1,83 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#include \"teams_mgmt.h\"\n+#include \"../caf_error.h\"\n+\n+caf_shmem_team_t caf_current_team = NULL, caf_initial_team;\n+caf_shmem_team_t caf_teams_formed = NULL;\n+\n+void\n+update_teams_images (caf_shmem_team_t team)\n+{\n+ pthread_mutex_lock (&team->u.image_info->image_count.mutex);\n+ if (team->u.image_info->num_term_images\n+ != this_image.supervisor->finished_images\n+\t + this_image.supervisor->failed_images)\n+ {\n+ const int old_num = team->u.image_info->num_term_images;\n+ const int sz = team->u.image_info->image_map_size;\n+ int i, good = 0;\n+\n+ for (i = 0; i < sz; ++i)\n+\tif (this_image.supervisor->images[team->u.image_info->image_map[i]]\n+\t .status\n+\t == IMAGE_OK)\n+\t ++good;\n+\n+ team->u.image_info->num_term_images = sz - good;\n+\n+ counter_barrier_add_locked (&team->u.image_info->image_count,\n+\t\t\t\t old_num\n+\t\t\t\t - team->u.image_info->num_term_images);\n+ }\n+ pthread_mutex_unlock (&team->u.image_info->image_count.mutex);\n+}\n+\n+void\n+check_health (int *stat, char *errmsg, size_t errmsg_len)\n+{\n+ if (this_image.supervisor->finished_images\n+ || this_image.supervisor->failed_images)\n+ {\n+ if (this_image.supervisor->finished_images)\n+\t{\n+\t caf_internal_error (\"Stopped images present (currently %d)\", stat,\n+\t\t\t errmsg, errmsg_len,\n+\t\t\t this_image.supervisor->finished_images);\n+\t if (stat)\n+\t *stat = CAF_STAT_STOPPED_IMAGE;\n+\t}\n+ else if (this_image.supervisor->failed_images)\n+\t{\n+\t caf_internal_error (\"Failed images present (currently %d)\", stat,\n+\t\t\t errmsg, errmsg_len,\n+\t\t\t this_image.supervisor->failed_images);\n+\t if (stat)\n+\t *stat = CAF_STAT_FAILED_IMAGE;\n+\t}\n+ }\n+ else if (stat)\n+ *stat = 0;\n+}\ndiff --git a/libgfortran/caf/shmem/teams_mgmt.h b/libgfortran/caf/shmem/teams_mgmt.h\nnew file mode 100644\nindex 00000000000..f96f4aea33e\n--- /dev/null\n+++ b/libgfortran/caf/shmem/teams_mgmt.h\n@@ -0,0 +1,93 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#ifndef TEAMS_MGMT_H\n+#define TEAMS_MGMT_H\n+\n+#include \"alloc.h\"\n+#include \"collective_subroutine.h\"\n+#include \"supervisor.h\"\n+\n+struct caf_shmem_team\n+{\n+ struct caf_shmem_team *parent;\n+ int team_no;\n+ /* The index is the image's index minus one in this team. I.e. if in Fortran\n+ notion the current image is 3, then the value of index is 2. This allows\n+ access to the image_map without having to substract one each time (and\n+ missing it). Returning the image's index to the user is rarer, so adding\n+ one there is cheaper. */\n+ int index;\n+ /* The last memid the parent team used. This is used to restore the memid\n+ on an end team. */\n+ memid parent_teams_last_active_memid;\n+ struct coarray_allocated\n+ {\n+ struct coarray_allocated *next;\n+ caf_shmem_token_t token;\n+ } *allocated;\n+ union\n+ {\n+ void *shm;\n+ struct shmem_image_info\n+ {\n+ counter_barrier image_count;\n+ struct collsub_shared collsub;\n+ int team_parent_id;\n+ int team_id;\n+ int image_map_size;\n+ /* Store the last known number of terminated images (either stopped or\n+\t failed) images. On each access where all images need to be present\n+\t this is checked against the global number and the image_count and\n+\t image_map is updated. */\n+ int num_term_images;\n+ memid lastmemid;\n+ int image_map[];\n+ } *image_info;\n+ } u;\n+};\n+typedef struct caf_shmem_team *caf_shmem_team_t;\n+\n+/* The team currently active. */\n+extern caf_shmem_team_t caf_current_team;\n+\n+/* The initial team. */\n+extern caf_shmem_team_t caf_initial_team;\n+\n+/* Teams formed, but not in used currently. */\n+extern caf_shmem_team_t caf_teams_formed;\n+\n+#define CHECK_TEAM_INTEGRITY(team) \\\n+ if (unlikely (team->u.image_info->num_term_images \\\n+\t\t!= this_image.supervisor->failed_images \\\n+\t\t + this_image.supervisor->finished_images)) \\\n+ update_teams_images (team)\n+\n+void update_teams_images (caf_shmem_team_t);\n+\n+void check_health (int *, char *, size_t);\n+\n+#define HEALTH_CHECK(stat, errmsg, errlen) check_health (stat, errmsg, errlen)\n+\n+#endif\ndiff --git a/libgfortran/caf/shmem/thread_support.c b/libgfortran/caf/shmem/thread_support.c\nnew file mode 100644\nindex 00000000000..572f39400b3\n--- /dev/null\n+++ b/libgfortran/caf/shmem/thread_support.c\n@@ -0,0 +1,73 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#include \"thread_support.h\"\n+\n+#include <errno.h>\n+#include <stdlib.h>\n+#include <stdio.h>\n+\n+#define ERRCHECK(a) \\\n+ do \\\n+ { \\\n+ int rc = a; \\\n+ if (rc) \\\n+\t{ \\\n+\t errno = rc; \\\n+\t perror (#a \" failed\"); \\\n+\t exit (1); \\\n+\t} \\\n+ } \\\n+ while (0)\n+\n+void\n+initialize_shared_mutex (pthread_mutex_t *mutex)\n+{\n+ pthread_mutexattr_t mattr;\n+ ERRCHECK (pthread_mutexattr_init (&mattr));\n+ ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED));\n+ ERRCHECK (pthread_mutex_init (mutex, &mattr));\n+ ERRCHECK (pthread_mutexattr_destroy (&mattr));\n+}\n+\n+void\n+initialize_shared_errorcheck_mutex (pthread_mutex_t *mutex)\n+{\n+ pthread_mutexattr_t mattr;\n+ ERRCHECK (pthread_mutexattr_init (&mattr));\n+ ERRCHECK (pthread_mutexattr_setpshared (&mattr, PTHREAD_PROCESS_SHARED));\n+ ERRCHECK (pthread_mutexattr_settype (&mattr, PTHREAD_MUTEX_ERRORCHECK));\n+ ERRCHECK (pthread_mutex_init (mutex, &mattr));\n+ ERRCHECK (pthread_mutexattr_destroy (&mattr));\n+}\n+\n+void\n+initialize_shared_condition (pthread_cond_t *cond)\n+{\n+ pthread_condattr_t cattr;\n+ ERRCHECK (pthread_condattr_init (&cattr));\n+ ERRCHECK (pthread_condattr_setpshared (&cattr, PTHREAD_PROCESS_SHARED));\n+ ERRCHECK (pthread_cond_init (cond, &cattr));\n+ ERRCHECK (pthread_condattr_destroy (&cattr));\n+}\ndiff --git a/libgfortran/caf/shmem/thread_support.h b/libgfortran/caf/shmem/thread_support.h\nnew file mode 100644\nindex 00000000000..e70b4b83c7d\n--- /dev/null\n+++ b/libgfortran/caf/shmem/thread_support.h\n@@ -0,0 +1,38 @@\n+/* Copyright (C) 2025 Free Software Foundation, Inc.\n+ Contributed by Thomas Koenig, Nicolas Koenig, Andre Vehreschild\n+\n+This file is part of the GNU Fortran Shmem Coarray Library (caf_shmem).\n+\n+Caf_shmem is free software; you can redistribute it and/or modify\n+it under the terms of the GNU General Public License as published by\n+the Free Software Foundation; either version 3, or (at your option)\n+any later version.\n+\n+Caf_shmem is distributed in the hope that it will be useful,\n+but WITHOUT ANY WARRANTY; without even the implied warranty of\n+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n+GNU General Public License for more details.\n+\n+Under Section 7 of GPL version 3, you are granted additional\n+permissions described in the GCC Runtime Library Exception, version\n+3.1, as published by the Free Software Foundation.\n+\n+You should have received a copy of the GNU General Public License and\n+a copy of the GCC Runtime Library Exception along with this program;\n+see the files COPYING3 and COPYING.RUNTIME respectively. If not, see\n+<http://www.gnu.org/licenses/>. */\n+\n+#ifndef THREAD_SUPPORT_H\n+#define THREAD_SUPPORT_H\n+\n+#include <pthread.h>\n+\n+/* Support routines to setup pthread structs in shared memory. */\n+\n+void initialize_shared_mutex (pthread_mutex_t *);\n+\n+void initialize_shared_errorcheck_mutex (pthread_mutex_t *);\n+\n+void initialize_shared_condition (pthread_cond_t *);\n+\n+#endif\n", "prefixes": [ "5/13" ] }